+++ /dev/null
-/* DSP16xx extra modes.
- Copyright (C) 2003 Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* HFmode is the DSP16xx's equivalent of SFmode.
- FIXME: What format is this anyway? */
-FLOAT_MODE (HF, 2, 0);
+++ /dev/null
-/* Definitions of target machine for GNU compiler. AT&T DSP1600.
- Copyright (C) 2000 Free Software Foundation, Inc.
- Contributed by Michael Collison (collison@world.std.com).
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#ifdef RTX_CODE
-extern struct rtx_def *gen_compare_reg (enum rtx_code, rtx, rtx);
-extern int call_address_operand (rtx, enum machine_mode);
-extern int arith_reg_operand (rtx, enum machine_mode);
-extern int symbolic_address_operand (rtx, enum machine_mode);
-extern int Y_address_operand (rtx, enum machine_mode);
-extern int sp_operand (rtx, enum machine_mode);
-extern int sp_operand2 (rtx, enum machine_mode);
-extern int nonmemory_arith_operand (rtx, enum machine_mode);
-extern int dsp16xx_comparison_operator (rtx, enum machine_mode);
-extern int unx_comparison_operator (rtx, enum machine_mode);
-extern int signed_comparison_operator (rtx, enum machine_mode);
-
-extern void notice_update_cc (rtx);
-extern void double_reg_from_memory (rtx[]);
-extern void double_reg_to_memory (rtx[]);
-extern enum rtx_code next_cc_user_code (rtx);
-extern int next_cc_user_unsigned (rtx);
-extern struct rtx_def *gen_tst_reg (rtx);
-extern const char *output_block_move (rtx[]);
-extern enum reg_class preferred_reload_class (rtx, enum reg_class);
-extern enum reg_class secondary_reload_class (enum reg_class,
- enum machine_mode, rtx);
-extern int emit_move_sequence (rtx *, enum machine_mode);
-extern void print_operand (FILE *, rtx, int);
-extern void print_operand_address (FILE *, rtx);
-extern void output_dsp16xx_float_const (rtx *);
-extern void emit_1600_core_shift (enum rtx_code, rtx *, int);
-extern int symbolic_address_p (rtx);
-extern int uns_comparison_operator (rtx, enum machine_mode);
-#endif /* RTX_CODE */
-
-
-#ifdef TREE_CODE
-extern struct rtx_def *dsp16xx_function_arg (CUMULATIVE_ARGS,
- enum machine_mode,
- tree, int);
-extern void dsp16xx_function_arg_advance (CUMULATIVE_ARGS *,
- enum machine_mode,
- tree, int);
-#endif /* TREE_CODE */
-
-extern void dsp16xx_invalid_register_for_compare (void);
-extern int class_max_nregs (enum reg_class, enum machine_mode);
-extern enum reg_class limit_reload_class (enum reg_class, enum machine_mode);
-extern int dsp16xx_register_move_cost (enum reg_class, enum reg_class);
-extern int dsp16xx_makes_calls (void);
-extern long compute_frame_size (int);
-extern int dsp16xx_call_saved_register (int);
-extern int dsp16xx_call_saved_register (int);
-extern void init_emulation_routines (void);
-extern int ybase_regs_ever_used (void);
-extern void override_options (void);
-extern int dsp16xx_starting_frame_offset (void);
-extern int initial_frame_pointer_offset (void);
-extern void asm_output_common (FILE *, const char *, int, int);
-extern void asm_output_local (FILE *, const char *, int, int);
-extern void asm_output_float (FILE *, double);
-extern bool dsp16xx_compare_gen;
-extern int hard_regno_mode_ok (int, enum machine_mode);
-extern enum reg_class dsp16xx_reg_class_from_letter (int);
-extern int regno_reg_class (int);
-extern void function_prologue (FILE *, int);
-extern void function_epilogue (FILE *, int);
-extern int num_1600_core_shifts (int);
+++ /dev/null
-/* Subroutines for assembler code output on the DSP1610.
- Copyright (C) 1994, 1995, 1997, 1998, 2001 Free Software Foundation, Inc.
- Contributed by Michael Collison (collison@isisinc.net).
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* Some output-actions in dsp1600.md need these. */
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "rtl.h"
-#include "regs.h"
-#include "hard-reg-set.h"
-#include "real.h"
-#include "insn-config.h"
-#include "conditions.h"
-#include "output.h"
-#include "insn-attr.h"
-#include "tree.h"
-#include "expr.h"
-#include "function.h"
-#include "flags.h"
-#include "ggc.h"
-#include "toplev.h"
-#include "recog.h"
-#include "tm_p.h"
-#include "target.h"
-#include "target-def.h"
-
-const char *text_seg_name;
-const char *rsect_text;
-const char *data_seg_name;
-const char *rsect_data;
-const char *bss_seg_name;
-const char *rsect_bss;
-const char *const_seg_name;
-const char *rsect_const;
-
-const char *chip_name;
-const char *save_chip_name;
-
-/* Save the operands of a compare. The 16xx has not lt or gt, so
- in these cases we swap the operands and reverse the condition. */
-
-rtx dsp16xx_compare_op0;
-rtx dsp16xx_compare_op1;
-bool dsp16xx_compare_gen;
-
-static const char *fp;
-static const char *sp;
-static const char *rr;
-static const char *a1h;
-
-struct dsp16xx_frame_info current_frame_info;
-struct dsp16xx_frame_info zero_frame_info;
-
-rtx dsp16xx_addhf3_libcall = (rtx) 0;
-rtx dsp16xx_subhf3_libcall = (rtx) 0;
-rtx dsp16xx_mulhf3_libcall = (rtx) 0;
-rtx dsp16xx_divhf3_libcall = (rtx) 0;
-rtx dsp16xx_cmphf3_libcall = (rtx) 0;
-rtx dsp16xx_fixhfhi2_libcall = (rtx) 0;
-rtx dsp16xx_floathihf2_libcall = (rtx) 0;
-rtx dsp16xx_neghf2_libcall = (rtx) 0;
-
-rtx dsp16xx_mulhi3_libcall = (rtx) 0;
-rtx dsp16xx_udivqi3_libcall = (rtx) 0;
-rtx dsp16xx_udivhi3_libcall = (rtx) 0;
-rtx dsp16xx_divqi3_libcall = (rtx) 0;
-rtx dsp16xx_divhi3_libcall = (rtx) 0;
-rtx dsp16xx_modqi3_libcall = (rtx) 0;
-rtx dsp16xx_modhi3_libcall = (rtx) 0;
-rtx dsp16xx_umodqi3_libcall = (rtx) 0;
-rtx dsp16xx_umodhi3_libcall = (rtx) 0;
-rtx dsp16xx_ashrhi3_libcall = (rtx) 0;
-rtx dsp16xx_ashlhi3_libcall = (rtx) 0;
-rtx dsp16xx_ucmphi2_libcall = (rtx) 0;
-rtx dsp16xx_lshrhi3_libcall = (rtx) 0;
-
-static const char *const himode_reg_name[] = HIMODE_REGISTER_NAMES;
-
-#define SHIFT_INDEX_1 0
-#define SHIFT_INDEX_4 1
-#define SHIFT_INDEX_8 2
-#define SHIFT_INDEX_16 3
-
-static const char *const ashift_right_asm[] =
-{
- "%0=%0>>1",
- "%0=%0>>4",
- "%0=%0>>8",
- "%0=%0>>16"
-};
-
-static const char *const ashift_right_asm_first[] =
-{
- "%0=%1>>1",
- "%0=%1>>4",
- "%0=%1>>8",
- "%0=%1>>16"
-};
-
-static const char *const ashift_left_asm[] =
-{
- "%0=%0<<1",
- "%0=%0<<4",
- "%0=%0<<8",
- "%0=%0<<16"
-};
-
-static const char *const ashift_left_asm_first[] =
-{
- "%0=%1<<1",
- "%0=%1<<4",
- "%0=%1<<8",
- "%0=%1<<16"
-};
-
-static const char *const lshift_right_asm[] =
-{
- "%0=%0>>1\n\t%0=%b0&0x7fff",
- "%0=%0>>4\n\t%0=%b0&0x0fff",
- "%0=%0>>8\n\t%0=%b0&0x00ff",
- "%0=%0>>16\n\t%0=%b0&0x0000"
-};
-
-static const char *const lshift_right_asm_first[] =
-{
- "%0=%1>>1\n\t%0=%b0&0x7fff",
- "%0=%1>>4\n\t%0=%b0&0x0fff",
- "%0=%1>>8\n\t%0=%b0&0x00ff",
- "%0=%1>>16\n\t%0=%b0&0x0000"
-};
-
-static int reg_save_size (void);
-static void dsp16xx_output_function_prologue (FILE *, HOST_WIDE_INT);
-static void dsp16xx_output_function_epilogue (FILE *, HOST_WIDE_INT);
-static void dsp16xx_file_start (void);
-static bool dsp16xx_rtx_costs (rtx, int, int, int *);
-static int dsp16xx_address_cost (rtx);
-\f
-/* Initialize the GCC target structure. */
-
-#undef TARGET_ASM_BYTE_OP
-#define TARGET_ASM_BYTE_OP "\tint\t"
-#undef TARGET_ASM_ALIGNED_HI_OP
-#define TARGET_ASM_ALIGNED_HI_OP NULL
-#undef TARGET_ASM_ALIGNED_SI_OP
-#define TARGET_ASM_ALIGNED_SI_OP NULL
-
-#undef TARGET_ASM_FUNCTION_PROLOGUE
-#define TARGET_ASM_FUNCTION_PROLOGUE dsp16xx_output_function_prologue
-#undef TARGET_ASM_FUNCTION_EPILOGUE
-#define TARGET_ASM_FUNCTION_EPILOGUE dsp16xx_output_function_epilogue
-
-#undef TARGET_ASM_FILE_START
-#define TARGET_ASM_FILE_START dsp16xx_file_start
-
-#undef TARGET_RTX_COSTS
-#define TARGET_RTX_COSTS dsp16xx_rtx_costs
-#undef TARGET_ADDRESS_COST
-#define TARGET_ADDRESS_COST dsp16xx_address_cost
-
-struct gcc_target targetm = TARGET_INITIALIZER;
-
-int
-hard_regno_mode_ok (regno, mode)
- int regno;
- enum machine_mode mode;
-{
- switch ((int) mode)
- {
- case VOIDmode:
- return 1;
-
- /* We can't use the c0-c2 for QImode, since they are only
- 8 bits in length. */
-
- case QImode:
- if (regno != REG_C0 && regno != REG_C1 && regno != REG_C2)
- return 1;
- else
- return 0;
-
- /* We only allow a0, a1, y, and p to be allocated for 32-bit modes.
- Additionally we allow the virtual ybase registers to be used for 32-bit
- modes. */
-
- case HFmode:
- case HImode:
-#if 0 /* ??? These modes do not appear in the machine description nor
- are there library routines for them. */
- case SFmode:
- case DFmode:
- case XFmode:
- case SImode:
- case DImode:
-#endif
- if (regno == REG_A0 || regno == REG_A1 || regno == REG_Y || regno == REG_PROD
- || (IS_YBASE_REGISTER_WINDOW(regno) && ((regno & 1) == 0)))
- return 1;
- else
- return 0;
-
- default:
- return 0;
- }
-}
-
-enum reg_class
-dsp16xx_reg_class_from_letter (c)
- int c;
-{
- switch (c)
- {
- case 'A':
- return ACCUM_REGS;
-
- case 'l':
- return A0_REG;
-
- case 'C':
- return A1_REG;
-
- case 'h':
- return ACCUM_HIGH_REGS;
-
- case 'j':
- return A0H_REG;
-
- case 'k':
- return A0L_REG;
-
- case 'q':
- return A1H_REG;
-
- case 'u':
- return A1L_REG;
-
- case 'x':
- return X_REG;
-
- case 'y':
- return YH_REG;
-
- case 'z':
- return YL_REG;
-
- case 't':
- return P_REG;
-
- case 'Z':
- return Y_OR_P_REGS;
-
- case 'd':
- return ACCUM_Y_OR_P_REGS;
-
- case 'a':
- return Y_ADDR_REGS;
-
- case 'B':
- return (TARGET_BMU ? BMU_REGS : NO_REGS);
-
- case 'Y':
- return YBASE_VIRT_REGS;
-
- case 'v':
- return PH_REG;
-
- case 'w':
- return PL_REG;
-
- case 'W':
- return J_REG;
-
- case 'e':
- return YBASE_ELIGIBLE_REGS;
-
- case 'b':
- return ACCUM_LOW_REGS;
-
- case 'c':
- return NON_YBASE_REGS;
-
- case 'f':
- return Y_REG;
-
- case 'D':
- return SLOW_MEM_LOAD_REGS;
-
- default:
- return NO_REGS;
- }
-}
-
-/* Return the class number of the smallest class containing
- reg number REGNO. */
-
-int
-regno_reg_class(regno)
- int regno;
-{
- switch (regno)
- {
- case REG_A0L:
- return (int) A0L_REG;
- case REG_A1L:
- return (int) A1L_REG;
-
- case REG_A0:
- return (int) A0H_REG;
- case REG_A1:
- return (int) A1H_REG;
-
- case REG_X:
- return (int) X_REG;
-
- case REG_Y:
- return (int) YH_REG;
- case REG_YL:
- return (int) YL_REG;
-
- case REG_PROD:
- return (int) PH_REG;
- case REG_PRODL:
- return (int) PL_REG;
-
- case REG_R0: case REG_R1: case REG_R2: case REG_R3:
- return (int) Y_ADDR_REGS;
-
- case REG_J:
- return (int) J_REG;
- case REG_K:
- return (int) GENERAL_REGS;
-
- case REG_YBASE:
- return (int) GENERAL_REGS;
-
- case REG_PT:
- return (int) GENERAL_REGS;
-
- case REG_AR0: case REG_AR1: case REG_AR2: case REG_AR3:
- return (int) BMU_REGS;
-
- case REG_C0: case REG_C1: case REG_C2:
- return (int) GENERAL_REGS;
-
- case REG_PR:
- return (int) GENERAL_REGS;
-
- case REG_RB:
- return (int) GENERAL_REGS;
-
- case REG_YBASE0: case REG_YBASE1: case REG_YBASE2: case REG_YBASE3:
- case REG_YBASE4: case REG_YBASE5: case REG_YBASE6: case REG_YBASE7:
- case REG_YBASE8: case REG_YBASE9: case REG_YBASE10: case REG_YBASE11:
- case REG_YBASE12: case REG_YBASE13: case REG_YBASE14: case REG_YBASE15:
- case REG_YBASE16: case REG_YBASE17: case REG_YBASE18: case REG_YBASE19:
- case REG_YBASE20: case REG_YBASE21: case REG_YBASE22: case REG_YBASE23:
- case REG_YBASE24: case REG_YBASE25: case REG_YBASE26: case REG_YBASE27:
- case REG_YBASE28: case REG_YBASE29: case REG_YBASE30: case REG_YBASE31:
- return (int) YBASE_VIRT_REGS;
-
- default:
- return (int) NO_REGS;
- }
-}
-
-/* A C expression for the maximum number of consecutive registers of class CLASS
- needed to hold a value of mode MODE. */
-
-int
-class_max_nregs(class, mode)
- enum reg_class class ATTRIBUTE_UNUSED;
- enum machine_mode mode;
-{
- return (GET_MODE_SIZE(mode));
-}
-
-enum reg_class
-limit_reload_class (mode, class)
- enum machine_mode mode ATTRIBUTE_UNUSED;
- enum reg_class class;
-{
- return class;
-}
-
-int
-dsp16xx_register_move_cost (from, to)
- enum reg_class from, to;
-{
- if (from == A0H_REG || from == A0L_REG || from == A0_REG ||
- from == A1H_REG || from == ACCUM_HIGH_REGS || from == A1L_REG ||
- from == ACCUM_LOW_REGS || from == A1_REG || from == ACCUM_REGS)
- {
- if (to == Y_REG || to == P_REG)
- return 4;
- else
- return 2;
- }
-
- if (to == A0H_REG || to == A0L_REG || to == A0_REG ||
- to == A1H_REG || to == ACCUM_HIGH_REGS || to == A1L_REG ||
- to == ACCUM_LOW_REGS || to == A1_REG || to == ACCUM_REGS)
- {
- return 2;
- }
-
- if (from == YBASE_VIRT_REGS)
- {
- if (to == YBASE_VIRT_REGS)
- return 16;
-
- if (to == X_REG || to == YH_REG || to == YL_REG ||
- to == Y_REG || to == PL_REG || to == PH_REG ||
- to == P_REG || to == Y_ADDR_REGS || to == YBASE_ELIGIBLE_REGS ||
- to == Y_OR_P_REGS)
- {
- return 8;
- }
- else
- return 10;
- }
-
- if (to == YBASE_VIRT_REGS)
- {
- if (from == X_REG || from == YH_REG || from == YL_REG ||
- from == Y_REG || from == PL_REG || from == PH_REG ||
- from == P_REG || from == Y_ADDR_REGS || from == YBASE_ELIGIBLE_REGS ||
- from == Y_OR_P_REGS)
- {
- return 8;
- }
- else
- return 10;
- }
-
- return 8;
-}
-
-/* Given an rtx X being reloaded into a reg required to be
- in class CLASS, return the class of reg to actually use.
- In general this is just CLASS; but on some machines
- in some cases it is preferable to use a more restrictive class.
- Also, we must ensure that a PLUS is reloaded either
- into an accumulator or an address register. */
-
-enum reg_class
-preferred_reload_class (x, class)
- rtx x;
- enum reg_class class;
-{
- /* The ybase registers cannot have constants copied directly
- to them. */
-
- if (CONSTANT_P (x))
- {
- switch ((int) class)
- {
- case YBASE_VIRT_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_LOW_OR_YBASE_REGS:
- return ACCUM_LOW_REGS;
-
- case ACCUM_OR_YBASE_REGS:
- return ACCUM_REGS;
-
- case X_OR_YBASE_REGS:
- return X_REG;
-
- case Y_OR_YBASE_REGS:
- return Y_REG;
-
- case ACCUM_LOW_YL_PL_OR_YBASE_REGS:
- return YL_OR_PL_OR_ACCUM_LOW_REGS;
-
- case P_OR_YBASE_REGS:
- return P_REG;
-
- case ACCUM_Y_P_OR_YBASE_REGS:
- return ACCUM_Y_OR_P_REGS;
-
- case Y_ADDR_OR_YBASE_REGS:
- return Y_ADDR_REGS;
-
- case YBASE_OR_NOHIGH_YBASE_ELIGIBLE_REGS:
- return NON_HIGH_YBASE_ELIGIBLE_REGS;;
-
- case YBASE_OR_YBASE_ELIGIBLE_REGS:
- return YBASE_ELIGIBLE_REGS;
-
- case NO_HIGH_ALL_REGS:
- return NOHIGH_NON_YBASE_REGS;
-
- case ALL_REGS:
- return NON_YBASE_REGS;
-
- default:
- return class;
- }
- }
-
- /* If x is not an accumulator or a ybase register, restrict the class of registers
- we can copy the register into. */
-
- if (REG_P (x) && !IS_ACCUM_REG (REGNO (x)) && !IS_YBASE_REGISTER_WINDOW (REGNO (x)))
- {
- switch ((int) class)
- {
- case NO_REGS:
- case A0H_REG: case A0L_REG: case A0_REG: case A1H_REG:
- case ACCUM_HIGH_REGS: case A1L_REG: case ACCUM_LOW_REGS:
- case A1_REG: case ACCUM_REGS:
- return class;
-
- case X_REG:
- return (!reload_in_progress ? NO_REGS : class);
-
- case X_OR_ACCUM_LOW_REGS:
- return ACCUM_LOW_REGS;
-
- case X_OR_ACCUM_REGS:
- return ACCUM_REGS;
-
- case YH_REG:
- return (!reload_in_progress ? NO_REGS : class);
-
- case YH_OR_ACCUM_HIGH_REGS:
- return ACCUM_HIGH_REGS;
-
- case X_OR_YH_REGS:
- case YL_REG:
- return (!reload_in_progress ? NO_REGS : class);
-
- case YL_OR_ACCUM_LOW_REGS:
- return ACCUM_LOW_REGS;
-
- case X_OR_YL_REGS:
- case X_OR_Y_REGS: case Y_REG:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_OR_Y_REGS:
- return ACCUM_REGS;
-
- case PH_REG:
- case X_OR_PH_REGS: case PL_REG:
- return (!reload_in_progress ? NO_REGS : class);
-
- case PL_OR_ACCUM_LOW_REGS:
- return ACCUM_LOW_REGS;
-
- case X_OR_PL_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case YL_OR_PL_OR_ACCUM_LOW_REGS:
- return ACCUM_LOW_REGS;
-
- case P_REG:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_OR_P_REGS:
- return ACCUM_REGS;
-
- case YL_OR_P_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_LOW_OR_YL_OR_P_REGS:
- return ACCUM_LOW_REGS;
-
- case Y_OR_P_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_Y_OR_P_REGS:
- return ACCUM_REGS;
-
- case NO_FRAME_Y_ADDR_REGS:
- case Y_ADDR_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_LOW_OR_Y_ADDR_REGS:
- return ACCUM_LOW_REGS;
-
- case ACCUM_OR_Y_ADDR_REGS:
- return ACCUM_REGS;
-
- case X_OR_Y_ADDR_REGS:
- case Y_OR_Y_ADDR_REGS:
- case P_OR_Y_ADDR_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case NON_HIGH_YBASE_ELIGIBLE_REGS:
- return ACCUM_LOW_REGS;
-
- case YBASE_ELIGIBLE_REGS:
- return ACCUM_REGS;
-
- case J_REG:
- case J_OR_DAU_16_BIT_REGS:
- case BMU_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case YBASE_VIRT_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return class;
- else
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_LOW_OR_YBASE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return class;
- else
- return ACCUM_LOW_REGS;
-
- case ACCUM_OR_YBASE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return class;
- else
- return ACCUM_REGS;
-
- case X_OR_YBASE_REGS:
- case Y_OR_YBASE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return YBASE_VIRT_REGS;
- else
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_LOW_YL_PL_OR_YBASE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return ACCUM_LOW_OR_YBASE_REGS;
- else
- return ACCUM_LOW_REGS;
-
- case P_OR_YBASE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return YBASE_VIRT_REGS;
- else
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_Y_P_OR_YBASE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return ACCUM_OR_YBASE_REGS;
- else
- return ACCUM_REGS;
-
- case Y_ADDR_OR_YBASE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return YBASE_VIRT_REGS;
- else
- return (!reload_in_progress ? NO_REGS : class);
-
- case YBASE_OR_NOHIGH_YBASE_ELIGIBLE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return ACCUM_LOW_OR_YBASE_REGS;
- else
- return ACCUM_LOW_REGS;
-
- case YBASE_OR_YBASE_ELIGIBLE_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return ACCUM_OR_YBASE_REGS;
- else
- return ACCUM_REGS;
-
- case NO_HIGH_ALL_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return ACCUM_LOW_OR_YBASE_REGS;
- else
- return ACCUM_LOW_REGS;
-
- case ALL_REGS:
- if (IS_YBASE_ELIGIBLE_REG (REGNO (x)))
- return ACCUM_OR_YBASE_REGS;
- else
- return ACCUM_REGS;
-
- case NOHIGH_NON_ADDR_REGS:
- return ACCUM_LOW_REGS;
-
- case NON_ADDR_REGS:
- case SLOW_MEM_LOAD_REGS:
- return ACCUM_REGS;
-
- case NOHIGH_NON_YBASE_REGS:
- return ACCUM_LOW_REGS;
-
- case NO_ACCUM_NON_YBASE_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case NON_YBASE_REGS:
- return ACCUM_REGS;
-
- default:
- return class;
- }
- }
-
- /* If x (the input) is a ybase register, restrict the class of registers
- we can copy the register into. */
-
- if (REG_P (x) && !TARGET_RESERVE_YBASE
- && IS_YBASE_REGISTER_WINDOW (REGNO(x)))
- {
- switch ((int) class)
- {
- case NO_REGS:
- case A0H_REG: case A0L_REG: case A0_REG: case A1H_REG:
- case ACCUM_HIGH_REGS: case A1L_REG: case ACCUM_LOW_REGS:
- case A1_REG: case ACCUM_REGS: case X_REG:
- case X_OR_ACCUM_LOW_REGS: case X_OR_ACCUM_REGS:
- case YH_REG: case YH_OR_ACCUM_HIGH_REGS:
- case X_OR_YH_REGS: case YL_REG:
- case YL_OR_ACCUM_LOW_REGS: case X_OR_YL_REGS:
- case X_OR_Y_REGS: case Y_REG:
- case ACCUM_OR_Y_REGS: case PH_REG:
- case X_OR_PH_REGS: case PL_REG:
- case PL_OR_ACCUM_LOW_REGS: case X_OR_PL_REGS:
- case YL_OR_PL_OR_ACCUM_LOW_REGS: case P_REG:
- case ACCUM_OR_P_REGS: case YL_OR_P_REGS:
- case ACCUM_LOW_OR_YL_OR_P_REGS: case Y_OR_P_REGS:
- case ACCUM_Y_OR_P_REGS: case NO_FRAME_Y_ADDR_REGS:
- case Y_ADDR_REGS: case ACCUM_LOW_OR_Y_ADDR_REGS:
- case ACCUM_OR_Y_ADDR_REGS: case X_OR_Y_ADDR_REGS:
- case Y_OR_Y_ADDR_REGS: case P_OR_Y_ADDR_REGS:
- case NON_HIGH_YBASE_ELIGIBLE_REGS: case YBASE_ELIGIBLE_REGS:
- default:
- return class;
-
- case J_REG:
- return (!reload_in_progress ? NO_REGS : class);
-
- case J_OR_DAU_16_BIT_REGS:
- return ACCUM_HIGH_REGS;
-
- case BMU_REGS:
- case YBASE_VIRT_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_LOW_OR_YBASE_REGS:
- return ACCUM_LOW_REGS;
-
- case ACCUM_OR_YBASE_REGS:
- return ACCUM_REGS;
-
- case X_OR_YBASE_REGS:
- return X_REG;
-
- case Y_OR_YBASE_REGS:
- return Y_REG;
-
- case ACCUM_LOW_YL_PL_OR_YBASE_REGS:
- return YL_OR_PL_OR_ACCUM_LOW_REGS;
-
- case P_OR_YBASE_REGS:
- return P_REG;
-
- case ACCUM_Y_P_OR_YBASE_REGS:
- return ACCUM_Y_OR_P_REGS;
-
- case Y_ADDR_OR_YBASE_REGS:
- return Y_ADDR_REGS;
-
- case YBASE_OR_NOHIGH_YBASE_ELIGIBLE_REGS:
- return NON_HIGH_YBASE_ELIGIBLE_REGS;
-
- case YBASE_OR_YBASE_ELIGIBLE_REGS:
- return YBASE_ELIGIBLE_REGS;
-
- case NO_HIGH_ALL_REGS:
- return NON_HIGH_YBASE_ELIGIBLE_REGS;
-
- case ALL_REGS:
- return YBASE_ELIGIBLE_REGS;
-
- case NOHIGH_NON_ADDR_REGS:
- return ACCUM_LOW_OR_YL_OR_P_REGS;
-
- case NON_ADDR_REGS:
- return ACCUM_Y_OR_P_REGS;
-
- case SLOW_MEM_LOAD_REGS:
- return ACCUM_OR_Y_ADDR_REGS;
-
- case NOHIGH_NON_YBASE_REGS:
- return NON_HIGH_YBASE_ELIGIBLE_REGS;
-
- case NO_ACCUM_NON_YBASE_REGS:
- return Y_ADDR_REGS;
-
- case NON_YBASE_REGS:
- return YBASE_ELIGIBLE_REGS;
- }
- }
-
- if (GET_CODE (x) == PLUS)
- {
- if (GET_MODE (x) == QImode
- && REG_P (XEXP (x,0))
- && (XEXP (x,0) == frame_pointer_rtx
- || XEXP (x,0) == stack_pointer_rtx)
- && (GET_CODE (XEXP (x,1)) == CONST_INT))
- {
- if (class == ACCUM_HIGH_REGS)
- return class;
-
- /* If the accumulators are not part of the class
- being reloaded into, return NO_REGS. */
-#if 0
- if (!reg_class_subset_p (ACCUM_REGS, class))
- return (!reload_in_progress ? NO_REGS : class);
-#endif
- if (reg_class_subset_p (ACCUM_HIGH_REGS, class))
- return ACCUM_HIGH_REGS;
-
- /* We will use accumulator 'a1l' for reloading a
- PLUS. We can only use one accumulator because
- 'reload_inqi' only allows one alternative to be
- used. */
-
- else if (class == ACCUM_LOW_REGS)
- return A1L_REG;
- else if (class == A0L_REG)
- return NO_REGS;
- else
- return class;
- }
-
- if (class == NON_YBASE_REGS || class == YBASE_ELIGIBLE_REGS)
- return Y_ADDR_REGS;
- else
- return class;
- }
- else if (GET_CODE (x) == MEM)
- {
- /* We can't copy from a memory location into a
- ybase register. */
- if (reg_class_subset_p(YBASE_VIRT_REGS, class))
- {
- switch ((int) class)
- {
- case YBASE_VIRT_REGS:
- return (!reload_in_progress ? NO_REGS : class);
-
- case ACCUM_LOW_OR_YBASE_REGS:
- return ACCUM_LOW_REGS;
-
- case ACCUM_OR_YBASE_REGS:
- return ACCUM_REGS;
-
- case X_OR_YBASE_REGS:
- return X_REG;
-
- case Y_OR_YBASE_REGS:
- return Y_REG;
-
- case ACCUM_LOW_YL_PL_OR_YBASE_REGS:
- return YL_OR_PL_OR_ACCUM_LOW_REGS;
-
- case P_OR_YBASE_REGS:
- return P_REG;
-
- case ACCUM_Y_P_OR_YBASE_REGS:
- return ACCUM_Y_OR_P_REGS;
-
- case Y_ADDR_OR_YBASE_REGS:
- return Y_ADDR_REGS;
-
- case YBASE_OR_NOHIGH_YBASE_ELIGIBLE_REGS:
- return NON_HIGH_YBASE_ELIGIBLE_REGS;
-
- case YBASE_OR_YBASE_ELIGIBLE_REGS:
- return YBASE_ELIGIBLE_REGS;
-
- case NO_HIGH_ALL_REGS:
- return NOHIGH_NON_YBASE_REGS;
-
- case ALL_REGS:
- return NON_YBASE_REGS;
-
- default:
- return class;
- }
- }
- else
- return class;
- }
- else
- return class;
-}
-
-/* Return the register class of a scratch register needed to copy IN into
- or out of a register in CLASS in MODE. If it can be done directly,
- NO_REGS is returned. */
-
-enum reg_class
-secondary_reload_class (class, mode, in)
- enum reg_class class;
- enum machine_mode mode;
- rtx in;
-{
- int regno = -1;
-
- if (GET_CODE (in) == REG || GET_CODE (in) == SUBREG)
- regno = true_regnum (in);
-
- /* If we are reloading a plus into a high accumulator register,
- we need a scratch low accumulator, because the low half gets
- clobbered. */
-
- if (class == ACCUM_HIGH_REGS
- || class == A1H_REG
- || class == A0H_REG)
- {
- if (GET_CODE (in) == PLUS && mode == QImode)
- return ACCUM_LOW_REGS;
- }
-
- if (class == ACCUM_HIGH_REGS
- || class == ACCUM_LOW_REGS
- || class == A1L_REG
- || class == A0L_REG
- || class == A1H_REG
- || class == A0H_REG)
- {
- if (GET_CODE (in) == PLUS && mode == QImode)
- {
- rtx addr0 = XEXP (in, 0);
- rtx addr1 = XEXP (in, 1);
-
- /* If we are reloading a plus (reg:QI) (reg:QI)
- we need an additional register. */
- if (REG_P (addr0) && REG_P (addr1))
- return NO_REGS;
- }
- }
-
- /* We can place anything into ACCUM_REGS and can put ACCUM_REGS
- into anything. */
-
- if ((class == ACCUM_REGS || class == ACCUM_HIGH_REGS ||
- class == ACCUM_LOW_REGS || class == A0H_REG || class == A0L_REG ||
- class == A1H_REG || class == A1_REG) ||
- (regno >= REG_A0 && regno < REG_A1L + 1))
- return NO_REGS;
-
- if (class == ACCUM_OR_YBASE_REGS && REG_P(in)
- && IS_YBASE_ELIGIBLE_REG(regno))
- {
- return NO_REGS;
- }
-
- /* We can copy the ybase registers into:
- r0-r3, a0-a1, y, p, & x or the union of
- any of these. */
-
- if (!TARGET_RESERVE_YBASE && IS_YBASE_REGISTER_WINDOW(regno))
- {
- switch ((int) class)
- {
- case (int) X_REG:
- case (int) X_OR_ACCUM_LOW_REGS:
- case (int) X_OR_ACCUM_REGS:
- case (int) YH_REG:
- case (int) YH_OR_ACCUM_HIGH_REGS:
- case (int) X_OR_YH_REGS:
- case (int) YL_REG:
- case (int) YL_OR_ACCUM_LOW_REGS:
- case (int) X_OR_Y_REGS:
- case (int) X_OR_YL_REGS:
- case (int) Y_REG:
- case (int) ACCUM_OR_Y_REGS:
- case (int) PH_REG:
- case (int) X_OR_PH_REGS:
- case (int) PL_REG:
- case (int) PL_OR_ACCUM_LOW_REGS:
- case (int) X_OR_PL_REGS:
- case (int) YL_OR_PL_OR_ACCUM_LOW_REGS:
- case (int) P_REG:
- case (int) ACCUM_OR_P_REGS:
- case (int) YL_OR_P_REGS:
- case (int) ACCUM_LOW_OR_YL_OR_P_REGS:
- case (int) Y_OR_P_REGS:
- case (int) ACCUM_Y_OR_P_REGS:
- case (int) Y_ADDR_REGS:
- case (int) ACCUM_LOW_OR_Y_ADDR_REGS:
- case (int) ACCUM_OR_Y_ADDR_REGS:
- case (int) X_OR_Y_ADDR_REGS:
- case (int) Y_OR_Y_ADDR_REGS:
- case (int) P_OR_Y_ADDR_REGS:
- case (int) YBASE_ELIGIBLE_REGS:
- return NO_REGS;
-
- default:
- return ACCUM_HIGH_REGS;
- }
- }
-
- /* We can copy r0-r3, a0-a1, y, & p
- directly to the ybase registers. In addition
- we can use any of the ybase virtual registers
- as the secondary reload registers when copying
- between any of these registers. */
-
- if (!TARGET_RESERVE_YBASE && regno != -1)
- {
- switch (regno)
- {
- case REG_A0:
- case REG_A0L:
- case REG_A1:
- case REG_A1L:
- case REG_X:
- case REG_Y:
- case REG_YL:
- case REG_PROD:
- case REG_PRODL:
- case REG_R0:
- case REG_R1:
- case REG_R2:
- case REG_R3:
- if (class == YBASE_VIRT_REGS)
- return NO_REGS;
- else
- {
- switch ((int) class)
- {
- case (int) X_REG:
- case (int) X_OR_ACCUM_LOW_REGS:
- case (int) X_OR_ACCUM_REGS:
- case (int) YH_REG:
- case (int) YH_OR_ACCUM_HIGH_REGS:
- case (int) X_OR_YH_REGS:
- case (int) YL_REG:
- case (int) YL_OR_ACCUM_LOW_REGS:
- case (int) X_OR_Y_REGS:
- case (int) X_OR_YL_REGS:
- case (int) Y_REG:
- case (int) ACCUM_OR_Y_REGS:
- case (int) PH_REG:
- case (int) X_OR_PH_REGS:
- case (int) PL_REG:
- case (int) PL_OR_ACCUM_LOW_REGS:
- case (int) X_OR_PL_REGS:
- case (int) YL_OR_PL_OR_ACCUM_LOW_REGS:
- case (int) P_REG:
- case (int) ACCUM_OR_P_REGS:
- case (int) YL_OR_P_REGS:
- case (int) ACCUM_LOW_OR_YL_OR_P_REGS:
- case (int) Y_OR_P_REGS:
- case (int) ACCUM_Y_OR_P_REGS:
- case (int) Y_ADDR_REGS:
- case (int) ACCUM_LOW_OR_Y_ADDR_REGS:
- case (int) ACCUM_OR_Y_ADDR_REGS:
- case (int) X_OR_Y_ADDR_REGS:
- case (int) Y_OR_Y_ADDR_REGS:
- case (int) P_OR_Y_ADDR_REGS:
- case (int) YBASE_ELIGIBLE_REGS:
- return YBASE_VIRT_REGS;
-
- default:
- break;
- }
- }
- }
- }
-
- /* Memory or constants can be moved from or to any register
- except the ybase virtual registers. */
- if (regno == -1 && GET_CODE(in) != PLUS)
- {
- if (class == YBASE_VIRT_REGS)
- return NON_YBASE_REGS;
- else
- return NO_REGS;
- }
-
- if (GET_CODE (in) == PLUS && mode == QImode)
- {
- rtx addr0 = XEXP (in, 0);
- rtx addr1 = XEXP (in, 1);
-
- /* If we are reloading a plus (reg:QI) (reg:QI)
- we need a low accumulator, not a high one. */
- if (REG_P (addr0) && REG_P (addr1))
- return ACCUM_LOW_REGS;
- }
-
-#if 0
- if (REG_P(in))
- return ACCUM_REGS;
-#endif
-
- /* Otherwise, we need a high accumulator(s). */
- return ACCUM_HIGH_REGS;
-}
-
-int
-symbolic_address_operand (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- return (symbolic_address_p (op));
-}
-
-int
-symbolic_address_p (op)
- rtx op;
-{
- switch (GET_CODE (op))
- {
- case SYMBOL_REF:
- case LABEL_REF:
- return 1;
-
- case CONST:
- op = XEXP (op, 0);
- return ((GET_CODE (XEXP (op, 0)) == SYMBOL_REF
- || GET_CODE (XEXP (op, 0)) == LABEL_REF)
- && GET_CODE (XEXP (op, 1)) == CONST_INT
- && INTVAL (XEXP (op,1)) < 0x20);
-
- default:
- return 0;
- }
-}
-
-/* For a Y address space operand we allow only *rn, *rn++, *rn--.
- This routine only recognizes *rn, the '<>' constraints recognize
- (*rn++), and (*rn--). */
-
-int
-Y_address_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (memory_address_p (mode, op) && !symbolic_address_p (op));
-}
-
-int
-sp_operand (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- return (GET_CODE (op) == PLUS
- && (XEXP (op, 0) == stack_pointer_rtx
- || XEXP (op, 0) == frame_pointer_rtx)
- && GET_CODE (XEXP (op,1)) == CONST_INT);
-}
-
-int
-sp_operand2 (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- if ((GET_CODE (op) == PLUS
- && (XEXP (op, 0) == stack_pointer_rtx
- || XEXP (op, 0) == frame_pointer_rtx)
- && (REG_P (XEXP (op,1))
- && IS_ADDRESS_REGISTER (REGNO (XEXP(op, 1))))))
- return 1;
- else if ((GET_CODE (op) == PLUS
- && (XEXP (op, 1) == stack_pointer_rtx
- || XEXP (op, 1) == frame_pointer_rtx)
- && (REG_P (XEXP (op,0))
- && IS_ADDRESS_REGISTER (REGNO (XEXP(op, 1))))))
- return 1;
- else
- return 0;
-}
-
-int
-nonmemory_arith_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (immediate_operand (op, mode) || arith_reg_operand (op, mode));
-}
-
-int
-arith_reg_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (register_operand (op, mode)
- && (GET_CODE (op) != REG
- || REGNO (op) >= FIRST_PSEUDO_REGISTER
- || (!(IS_YBASE_REGISTER_WINDOW (REGNO (op)))
- && REGNO (op) != FRAME_POINTER_REGNUM)));
-}
-
-int
-call_address_operand (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- if (symbolic_address_p (op) || REG_P(op))
- {
- return 1;
- }
-
- return 0;
-}
-
-int
-dsp16xx_comparison_operator (op, mode)
- register rtx op;
- enum machine_mode mode;
-{
- return ((mode == VOIDmode || GET_MODE (op) == mode)
- && GET_RTX_CLASS (GET_CODE (op)) == '<'
- && (GET_CODE(op) != GE && GET_CODE (op) != LT &&
- GET_CODE (op) != GEU && GET_CODE (op) != LTU));
-}
-
-void
-notice_update_cc(exp)
- rtx exp;
-{
- if (GET_CODE (exp) == SET)
- {
- /* Jumps do not alter the cc's. */
-
- if (SET_DEST (exp) == pc_rtx)
- return;
-
- /* Moving register or memory into a register:
- it doesn't alter the cc's, but it might invalidate
- the RTX's which we remember the cc's came from.
- (Note that moving a constant 0 or 1 MAY set the cc's). */
- if (REG_P (SET_DEST (exp))
- && (REG_P (SET_SRC (exp)) || GET_CODE (SET_SRC (exp)) == MEM))
- {
- if (cc_status.value1
- && reg_overlap_mentioned_p (SET_DEST (exp), cc_status.value1))
- cc_status.value1 = 0;
- if (cc_status.value2
- && reg_overlap_mentioned_p (SET_DEST (exp), cc_status.value2))
- cc_status.value2 = 0;
- return;
- }
- /* Moving register into memory doesn't alter the cc's.
- It may invalidate the RTX's which we remember the cc's came from. */
- if (GET_CODE (SET_DEST (exp)) == MEM && REG_P (SET_SRC (exp)))
- {
- if (cc_status.value1 && GET_CODE (cc_status.value1) == MEM)
- cc_status.value1 = 0;
- if (cc_status.value2 && GET_CODE (cc_status.value2) == MEM)
- cc_status.value2 = 0;
- return;
- }
- /* Function calls clobber the cc's. */
- else if (GET_CODE (SET_SRC (exp)) == CALL)
- {
- CC_STATUS_INIT;
- return;
- }
- /* Tests and compares set the cc's in predictable ways. */
- else if (SET_DEST (exp) == cc0_rtx)
- {
- CC_STATUS_INIT;
- cc_status.value1 = SET_SRC (exp);
- return;
- }
- /* Certain instructions effect the condition codes. */
- else if (GET_MODE_CLASS (GET_MODE (SET_SRC (exp))) == MODE_INT)
- switch (GET_CODE (SET_SRC (exp)))
- {
- case PLUS:
- case MINUS:
- if (REG_P (SET_DEST (exp)))
- {
- /* Address registers don't set the condition codes. */
- if (IS_ADDRESS_REGISTER (REGNO (SET_DEST (exp))))
- {
- CC_STATUS_INIT;
- break;
- }
- }
- case ASHIFTRT:
- case LSHIFTRT:
- case ASHIFT:
- case AND:
- case IOR:
- case XOR:
- case MULT:
- case NEG:
- case NOT:
- cc_status.value1 = SET_SRC (exp);
- cc_status.value2 = SET_DEST (exp);
- break;
-
- default:
- CC_STATUS_INIT;
- }
- else
- {
- CC_STATUS_INIT;
- }
- }
- else if (GET_CODE (exp) == PARALLEL
- && GET_CODE (XVECEXP (exp, 0, 0)) == SET)
- {
- if (SET_DEST (XVECEXP (exp, 0, 0)) == pc_rtx)
- return;
-
- if (SET_DEST (XVECEXP (exp, 0, 0)) == cc0_rtx)
- {
- CC_STATUS_INIT;
- cc_status.value1 = SET_SRC (XVECEXP (exp, 0, 0));
- return;
- }
-
- CC_STATUS_INIT;
- }
- else
- {
- CC_STATUS_INIT;
- }
-}
-
-int
-dsp16xx_makes_calls ()
-{
- rtx insn;
-
- for (insn = get_insns (); insn; insn = next_insn (insn))
- if (GET_CODE (insn) == CALL_INSN)
- return (1);
-
- return 0;
-}
-
-long
-compute_frame_size (size)
- int size;
-{
- long total_size;
- long var_size;
- long args_size;
- long extra_size;
- long reg_size;
-
- /* This value is needed to compute reg_size. */
- current_frame_info.function_makes_calls = !leaf_function_p ();
-
- reg_size = 0;
- extra_size = 0;
- var_size = size;
- args_size = current_function_outgoing_args_size;
- reg_size = reg_save_size ();
-
- total_size = var_size + args_size + extra_size + reg_size;
-
-
- /* Save other computed information. */
- current_frame_info.total_size = total_size;
- current_frame_info.var_size = var_size;
- current_frame_info.args_size = args_size;
- current_frame_info.extra_size = extra_size;
- current_frame_info.reg_size = reg_size;
- current_frame_info.initialized = reload_completed;
- current_frame_info.reg_size = reg_size / UNITS_PER_WORD;
-
- if (reg_size)
- {
- unsigned long offset = args_size + var_size + reg_size;
- current_frame_info.sp_save_offset = offset;
- current_frame_info.fp_save_offset = offset - total_size;
- }
-
- return total_size;
-}
-
-int
-dsp16xx_call_saved_register (regno)
- int regno;
-{
-#if 0
- if (regno == REG_PR && current_frame_info.function_makes_calls)
- return 1;
-#endif
- return (regs_ever_live[regno] && !call_used_regs[regno] &&
- !IS_YBASE_REGISTER_WINDOW(regno));
-}
-
-int
-ybase_regs_ever_used ()
-{
- int regno;
- int live = 0;
-
- for (regno = REG_YBASE0; regno <= REG_YBASE31; regno++)
- if (regs_ever_live[regno])
- {
- live = 1;
- break;
- }
-
- return live;
-}
-
-static void
-dsp16xx_output_function_prologue (file, size)
- FILE *file;
- HOST_WIDE_INT size;
-{
- int regno;
- long total_size;
- fp = reg_names[FRAME_POINTER_REGNUM];
- sp = reg_names[STACK_POINTER_REGNUM];
- rr = reg_names[RETURN_ADDRESS_REGNUM]; /* return address register */
- a1h = reg_names[REG_A1];
-
- total_size = compute_frame_size (size);
-
- fprintf (file, "\t/* FUNCTION PROLOGUE: */\n");
- fprintf (file, "\t/* total=%ld, vars= %ld, regs= %d, args=%d, extra= %ld */\n",
- current_frame_info.total_size,
- current_frame_info.var_size,
- current_frame_info.reg_size,
- current_function_outgoing_args_size,
- current_frame_info.extra_size);
-
- fprintf (file, "\t/* fp save offset= %ld, sp save_offset= %ld */\n\n",
- current_frame_info.fp_save_offset,
- current_frame_info.sp_save_offset);
- /* Set up the 'ybase' register window. */
-
- if (ybase_regs_ever_used())
- {
- fprintf (file, "\t%s=%s\n", a1h, reg_names[REG_YBASE]);
- if (TARGET_YBASE_HIGH)
- fprintf (file, "\t%s=%sh-32\n", reg_names[REG_A1], a1h);
- else
- fprintf (file, "\t%s=%sh+32\n", reg_names[REG_A1], a1h);
- fprintf (file, "\t%s=%s\n", reg_names[REG_YBASE], a1h);
- }
-
- if (current_frame_info.var_size)
- {
- if (current_frame_info.var_size == 1)
- fprintf (file, "\t*%s++\n", sp);
- else
- {
- if (SMALL_INTVAL(current_frame_info.var_size) && ((current_frame_info.var_size & 0x8000) == 0))
- fprintf (file, "\t%s=%ld\n\t*%s++%s\n", reg_names[REG_J], current_frame_info.var_size, sp, reg_names[REG_J]);
- else
- fatal_error ("stack size > 32k");
- }
- }
-
- /* Save any registers this function uses, unless they are
- used in a call, in which case we don't need to. */
-
- for(regno = 0; regno < FIRST_PSEUDO_REGISTER; ++ regno)
- if (dsp16xx_call_saved_register (regno))
- {
- fprintf (file, "\tpush(*%s)=%s\n", sp, reg_names[regno]);
- }
-
- /* For debugging purposes, we want the return address to be at a predictable
- location. */
- if (current_frame_info.function_makes_calls)
- fprintf (file, "\tpush(*%s)=%s\n", sp, reg_names[RETURN_ADDRESS_REGNUM]);
-
- if (current_frame_info.args_size)
- {
- if (current_frame_info.args_size == 1)
- fprintf (file, "\t*%s++\n", sp);
- else
- error ("stack size > 32k");
- }
-
- if (frame_pointer_needed)
- {
- fprintf (file, "\t%s=%s\n", a1h, sp);
- fprintf (file, "\t%s=%s\n", fp, a1h); /* Establish new base frame */
- fprintf (file, "\t%s=%ld\n", reg_names[REG_J], -total_size);
- fprintf (file, "\t*%s++%s\n", fp, reg_names[REG_J]);
- }
-
- fprintf (file, "\t/* END FUNCTION PROLOGUE: */\n\n");
-}
-
-void
-init_emulation_routines ()
-{
- dsp16xx_addhf3_libcall = (rtx) 0;
- dsp16xx_subhf3_libcall = (rtx) 0;
- dsp16xx_mulhf3_libcall = (rtx) 0;
- dsp16xx_divhf3_libcall = (rtx) 0;
- dsp16xx_cmphf3_libcall = (rtx) 0;
- dsp16xx_fixhfhi2_libcall = (rtx) 0;
- dsp16xx_floathihf2_libcall = (rtx) 0;
- dsp16xx_neghf2_libcall = (rtx) 0;
-
- dsp16xx_mulhi3_libcall = (rtx) 0;
- dsp16xx_udivqi3_libcall = (rtx) 0;
- dsp16xx_udivhi3_libcall = (rtx) 0;
- dsp16xx_divqi3_libcall = (rtx) 0;
- dsp16xx_divhi3_libcall = (rtx) 0;
- dsp16xx_modqi3_libcall = (rtx) 0;
- dsp16xx_modhi3_libcall = (rtx) 0;
- dsp16xx_umodqi3_libcall = (rtx) 0;
- dsp16xx_umodhi3_libcall = (rtx) 0;
- dsp16xx_ashrhi3_libcall = (rtx) 0;
- dsp16xx_ashlhi3_libcall = (rtx) 0;
- dsp16xx_ucmphi2_libcall = (rtx) 0;
- dsp16xx_lshrhi3_libcall = (rtx) 0;
-
-}
-static void
-dsp16xx_output_function_epilogue (file, size)
- FILE *file;
- HOST_WIDE_INT size ATTRIBUTE_UNUSED;
-{
- int regno;
-
- fp = reg_names[FRAME_POINTER_REGNUM];
- sp = reg_names[STACK_POINTER_REGNUM];
- rr = reg_names[RETURN_ADDRESS_REGNUM]; /* return address register */
- a1h = reg_names[REG_A1];
-
- fprintf (file, "\n\t/* FUNCTION EPILOGUE: */\n");
-
- if (current_frame_info.args_size)
- {
- if (current_frame_info.args_size == 1)
- fprintf (file, "\t*%s--\n", sp);
- else
- {
- fprintf (file, "\t%s=%ld\n\t*%s++%s\n",
- reg_names[REG_J], -current_frame_info.args_size, sp, reg_names[REG_J]);
- }
- }
-
- if (ybase_regs_ever_used())
- {
- fprintf (file, "\t%s=%s\n", a1h, reg_names[REG_YBASE]);
- if (TARGET_YBASE_HIGH)
- fprintf (file, "\t%s=%sh+32\n", reg_names[REG_A1], a1h);
- else
- fprintf (file, "\t%s=%sh-32\n", reg_names[REG_A1], a1h);
- fprintf (file, "\t%s=%s\n", reg_names[REG_YBASE], a1h);
- }
-
- if (current_frame_info.function_makes_calls)
- fprintf (file, "\t%s=pop(*%s)\n", reg_names[RETURN_ADDRESS_REGNUM], sp);
-
- for (regno = FIRST_PSEUDO_REGISTER - 1; regno >= 0; --regno)
- if (dsp16xx_call_saved_register(regno))
- {
- fprintf (file, "\t%s=pop(*%s)\n", reg_names[regno], sp);
- }
-
- if (current_frame_info.var_size)
- {
- if (current_frame_info.var_size == 1)
- fprintf (file, "\t*%s--\n", sp);
- else
- {
- fprintf (file, "\t%s=%ld\n\t*%s++%s\n",
- reg_names[REG_J], -current_frame_info.var_size, sp, reg_names[REG_J]);
- }
- }
-
- fprintf (file, "\treturn\n");
- /* Reset the frame info for the next function. */
- current_frame_info = zero_frame_info;
- init_emulation_routines ();
-}
-
-/* Emit insns to move operands[1] into operands[0].
-
- Return 1 if we have written out everything that needs to be done to
- do the move. Otherwise, return 0 and the caller will emit the move
- normally. */
-
-int
-emit_move_sequence (operands, mode)
- rtx *operands;
- enum machine_mode mode;
-{
- register rtx operand0 = operands[0];
- register rtx operand1 = operands[1];
-
- /* We can only store registers to memory. */
-
- if (GET_CODE (operand0) == MEM && GET_CODE (operand1) != REG)
- operands[1] = force_reg (mode, operand1);
-
- return 0;
-}
-
-void
-double_reg_from_memory (operands)
- rtx operands[];
-{
- rtx xoperands[4];
-
- if (GET_CODE(XEXP(operands[1],0)) == POST_INC)
- {
- output_asm_insn ("%u0=%1", operands);
- output_asm_insn ("%w0=%1", operands);
- }
- else if (GET_CODE(XEXP(operands[1],0)) == POST_DEC)
- {
- xoperands[1] = XEXP (XEXP (operands[1], 0), 0);
- xoperands[0] = operands[0];
-
- /* We can't use j anymore since the compiler can allocate it. */
-/* output_asm_insn ("j=-3\n\t%u0=*%1++\n\t%w0=*%1++j", xoperands); */
- output_asm_insn ("%u0=*%1++\n\t%w0=*%1--\n\t*%1--\n\t*%1--", xoperands);
- }
- else if (GET_CODE(XEXP(operands[1],0)) == PLUS)
- {
- rtx addr;
- int offset = 0;
-
- output_asm_insn ("%u0=%1", operands);
-
-
- /* In order to print out the least significant word we must
- use 'offset + 1'. */
- addr = XEXP (operands[1], 0);
- if (GET_CODE (XEXP(addr,0)) == CONST_INT)
- offset = INTVAL(XEXP(addr,0)) + 1;
- else if (GET_CODE (XEXP(addr,1)) == CONST_INT)
- offset = INTVAL(XEXP(addr,1)) + 1;
-
- fprintf (asm_out_file, "\t%s=*(%d)\n", reg_names[REGNO(operands[0]) + 1], offset + 31);
- }
- else
- {
- xoperands[1] = XEXP(operands[1],0);
- xoperands[0] = operands[0];
-
- output_asm_insn ("%u0=*%1++\n\t%w0=*%1--", xoperands);
- }
-}
-
-
-void
-double_reg_to_memory (operands)
- rtx operands[];
-{
- rtx xoperands[4];
-
- if (GET_CODE(XEXP(operands[0],0)) == POST_INC)
- {
- output_asm_insn ("%0=%u1", operands);
- output_asm_insn ("%0=%w1", operands);
- }
- else if (GET_CODE(XEXP(operands[0],0)) == POST_DEC)
- {
- xoperands[0] = XEXP (XEXP (operands[0], 0), 0);
- xoperands[1] = operands[1];
-
- /* We can't use j anymore since the compiler can allocate it. */
-
-/* output_asm_insn ("j=-3\n\t*%0++=%u1\n\t*%0++j=%w1", xoperands); */
- output_asm_insn ("*%0++=%u1\n\t*%0--=%w1\n\t*%0--\n\t*%0--", xoperands);
-
- }
- else if (GET_CODE(XEXP(operands[0],0)) == PLUS)
- {
- rtx addr;
- int offset = 0;
-
- output_asm_insn ("%0=%u1", operands);
-
- /* In order to print out the least significant word we must
- use 'offset + 1'. */
- addr = XEXP (operands[0], 0);
- if (GET_CODE (XEXP(addr,0)) == CONST_INT)
- offset = INTVAL(XEXP(addr,0)) + 1;
- else if (GET_CODE (XEXP(addr,1)) == CONST_INT)
- offset = INTVAL(XEXP(addr,1)) + 1;
- else
- fatal_error ("invalid addressing mode");
-
- fprintf (asm_out_file, "\t*(%d)=%s\n", offset + 31, reg_names[REGNO(operands[1]) + 1]);
- }
- else
- {
- xoperands[0] = XEXP(operands[0],0);
- xoperands[1] = operands[1];
-
- output_asm_insn ("*%0++=%u1\n\t*%0--=%w1", xoperands);
- }
-}
-
-void
-override_options ()
-{
- if (chip_name == (char *) 0)
- chip_name = DEFAULT_CHIP_NAME;
-
- if (text_seg_name == (char *) 0)
- text_seg_name = DEFAULT_TEXT_SEG_NAME;
-
- if (data_seg_name == (char *) 0)
- data_seg_name = DEFAULT_DATA_SEG_NAME;
-
- if (bss_seg_name == (char *) 0)
- bss_seg_name = DEFAULT_BSS_SEG_NAME;
-
- if (const_seg_name == (char *) 0)
- const_seg_name = DEFAULT_CONST_SEG_NAME;
-
- save_chip_name = xstrdup (chip_name);
-
- rsect_text = concat (".rsect \"", text_seg_name, "\"", NULL);
- rsect_data = concat (".rsect \"", data_seg_name, "\"", NULL);
- rsect_bss = concat (".rsect \"", bss_seg_name, "\"", NULL);
- rsect_const = concat (".rsect \"", const_seg_name, "\"", NULL);
-}
-
-int
-next_cc_user_unsigned (insn)
- rtx insn;
-{
- switch (next_cc_user_code (insn))
- {
- case GTU:
- case GEU:
- case LTU:
- case LEU:
- return 1;
- default:
- return 0;
- }
-}
-
-enum rtx_code
-next_cc_user_code (insn)
- rtx insn;
-{
- /* If no insn could be found we assume that the jump has been
- deleted and the compare will be deleted later. */
-
- if (!(insn = next_cc0_user (insn)))
- return (enum rtx_code) 0;
- else if (GET_CODE (insn) == JUMP_INSN
- && GET_CODE (PATTERN (insn)) == SET
- && GET_CODE (SET_SRC (PATTERN (insn))) == IF_THEN_ELSE)
- return GET_CODE (XEXP (SET_SRC (PATTERN (insn)), 0));
- else if (GET_CODE (insn) == INSN
- && GET_CODE (PATTERN (insn)) == SET
- && comparison_operator (SET_SRC (PATTERN (insn)), VOIDmode))
- return GET_CODE (SET_SRC (PATTERN (insn)));
- else
- abort ();
-}
-
-void
-print_operand(file, op, letter)
- FILE *file;
- rtx op;
- int letter;
-{
- enum rtx_code code;
-
- code = GET_CODE(op);
-
- switch (letter)
- {
- case 'I':
- code = reverse_condition (code);
- /* Fallthrough */
-
- case 'C':
- if (code == EQ)
- {
- fputs ("eq", file);
- return;
- }
- else if (code == NE)
- {
- fputs ("ne", file);
- return;
- }
- else if (code == GT || code == GTU)
- {
- fputs ("gt", file);
- return;
- }
- else if (code == LT || code == LTU)
- {
- fputs ("mi", file);
- return;
- }
- else if (code == GE || code == GEU)
- {
- fputs ("pl", file);
- return;
- }
- else if (code == LE || code == LEU)
- {
- fputs ("le", file);
- return;
- }
- else
- abort ();
- break;
-
- default:
- break;
- }
-
- if (code == REG)
- {
- /* Print the low half of a 32-bit register pair. */
- if (letter == 'w')
- fprintf (file, "%s", reg_names[REGNO (op) + 1]);
- else if (letter == 'u' || !letter)
- fprintf (file, "%s", reg_names[REGNO (op)]);
- else if (letter == 'b')
- fprintf (file, "%sh", reg_names[REGNO (op)]);
- else if (letter == 'm')
- fprintf (file, "%s", himode_reg_name[REGNO (op)]);
- else
- output_operand_lossage ("bad register extension code");
- }
- else if (code == MEM)
- output_address (XEXP(op,0));
- else if (code == CONST_INT)
- {
- HOST_WIDE_INT val = INTVAL (op);
-
- if (letter == 'H')
- fprintf (file, HOST_WIDE_INT_PRINT_HEX, val & 0xffff);
- else if (letter == 'h')
- fprintf (file, HOST_WIDE_INT_PRINT_DEC, val);
- else if (letter == 'U')
- fprintf (file, HOST_WIDE_INT_PRINT_HEX, (val >> 16) & 0xffff);
- else
- output_addr_const(file, op);
- }
- else if (code == CONST_DOUBLE && GET_MODE(op) != DImode)
- {
- long l;
- REAL_VALUE_TYPE r;
- REAL_VALUE_FROM_CONST_DOUBLE (r, op);
- REAL_VALUE_TO_TARGET_SINGLE (r, l);
- fprintf (file, "0x%lx", l);
- }
- else if (code == CONST)
- {
- rtx addr = XEXP (op, 0);
-
- if (GET_CODE (addr) != PLUS)
- {
- output_addr_const(file, op);
- return;
- }
-
- if ((GET_CODE (XEXP (addr, 0)) == SYMBOL_REF
- || GET_CODE (XEXP (addr, 0)) == LABEL_REF)
- && (GET_CODE (XEXP (addr, 1)) == CONST_INT))
- {
- int n = INTVAL (XEXP(addr, 1));
- output_addr_const (file, XEXP (addr, 0));
-
- if (n >= 0)
- fprintf (file, "+");
-
- n = (int) (short) n;
- fprintf (file, "%d", n);
- }
- else if ((GET_CODE (XEXP (addr, 1)) == SYMBOL_REF
- || GET_CODE (XEXP (addr, 1)) == LABEL_REF)
- && (GET_CODE (XEXP (addr, 0)) == CONST_INT))
- {
- int n = INTVAL (XEXP(addr, 0));
- output_addr_const (file, XEXP (addr, 1));
-
- if (n >= 0)
- fprintf (file, "+");
-
- n = (int) (short) n;
- fprintf (file, "%d", n);
- }
- else
- output_addr_const(file, op);
- }
- else
- output_addr_const (file, op);
-}
-
-
-void
-print_operand_address(file, addr)
- FILE *file;
- rtx addr;
-{
- rtx base;
- int offset = 0;;
-
- switch (GET_CODE (addr))
- {
- case REG:
- fprintf (file, "*%s", reg_names[REGNO (addr)]);
- break;
- case POST_DEC:
- fprintf (file, "*%s--", reg_names[REGNO (XEXP (addr, 0))]);
- break;
- case POST_INC:
- fprintf (file, "*%s++", reg_names[REGNO (XEXP (addr, 0))]);
- break;
- case PLUS:
- if (GET_CODE (XEXP(addr,0)) == CONST_INT)
- offset = INTVAL(XEXP(addr,0)), base = XEXP(addr,1);
- else if (GET_CODE (XEXP(addr,1)) == CONST_INT)
- offset = INTVAL(XEXP(addr,1)), base = XEXP(addr,0);
- else
- abort();
- if (GET_CODE (base) == REG && REGNO(base) == STACK_POINTER_REGNUM)
- {
- if (offset >= -31 && offset <= 0)
- offset = 31 + offset;
- else
- fatal_error ("invalid offset in ybase addressing");
- }
- else
- fatal_error ("invalid register in ybase addressing");
-
- fprintf (file, "*(%d)", offset);
- break;
-
- default:
- if (FITS_5_BITS (addr))
- fprintf (file, "*(0x%x)", (int)(INTVAL (addr) & 0x20));
- else
- output_addr_const (file, addr);
- }
-}
-
-void
-output_dsp16xx_float_const (operands)
- rtx *operands;
-{
- rtx src = operands[1];
-
- REAL_VALUE_TYPE d;
- long value;
-
- REAL_VALUE_FROM_CONST_DOUBLE (d, src);
- REAL_VALUE_TO_TARGET_SINGLE (d, value);
-
- operands[1] = GEN_INT (value);
- output_asm_insn ("%u0=%U1\n\t%w0=%H1", operands);
-}
-
-static int
-reg_save_size ()
-{
- int reg_save_size = 0;
- int regno;
-
- for (regno = 0; regno < FIRST_PSEUDO_REGISTER; regno++)
- if (dsp16xx_call_saved_register (regno))
- {
- reg_save_size += UNITS_PER_WORD;
- }
-
- /* If the function makes calls we will save need to save the 'pr' register. */
- if (current_frame_info.function_makes_calls)
- reg_save_size += 1;
-
- return (reg_save_size);
-}
-
-#if 0
-int
-dsp16xx_starting_frame_offset()
-{
- int reg_save_size = 0;
- int regno;
-
- for (regno = 0; regno < FIRST_PSEUDO_REGISTER; regno++)
- if (dsp16xx_call_saved_register (regno))
- {
- reg_save_size += UNITS_PER_WORD;
- }
-
- return (reg_save_size);
-}
-#endif
-
-int
-initial_frame_pointer_offset()
-{
- int offset = 0;
-
- offset = compute_frame_size (get_frame_size());
-
-#ifdef STACK_GROWS_DOWNWARD
- return (offset);
-#else
- return (-offset);
-#endif
-}
-
-/* Generate the minimum number of 1600 core shift instructions
- to shift by 'shift_amount'. */
-
-#if 0
-void
-emit_1600_core_shift (shift_op, operands, shift_amount, mode)
- enum rtx_code shift_op;
- rtx *operands;
- int shift_amount;
- enum machine_mode mode;
-{
- int quotient;
- int i;
- int first_shift_emitted = 0;
-
- while (shift_amount != 0)
- {
- if (shift_amount/16)
- {
- quotient = shift_amount/16;
- shift_amount = shift_amount - (quotient * 16);
- for (i = 0; i < quotient; i++)
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx (shift_op, mode,
- first_shift_emitted
- ? operands[0] : operands[1],
- GEN_INT (16))));
- first_shift_emitted = 1;
- }
- else if (shift_amount/8)
- {
- quotient = shift_amount/8;
- shift_amount = shift_amount - (quotient * 8);
- for (i = 0; i < quotient; i++)
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx (shift_op, mode,
- first_shift_emitted
- ? operands[0] : operands[1],
- GEN_INT (8))));
- first_shift_emitted = 1;
- }
- else if (shift_amount/4)
- {
- quotient = shift_amount/4;
- shift_amount = shift_amount - (quotient * 4);
- for (i = 0; i < quotient; i++)
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx (shift_op, mode,
- first_shift_emitted
- ? operands[0] : operands[1],
- GEN_INT (4))));
- first_shift_emitted = 1;
- }
- else if (shift_amount/1)
- {
- quotient = shift_amount/1;
- shift_amount = shift_amount - (quotient * 1);
- for (i = 0; i < quotient; i++)
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx (shift_op, mode,
- first_shift_emitted
- ? operands[0] : operands[1],
- GEN_INT (1))));
- first_shift_emitted = 1;
- }
- }
-}
-#else
-void
-emit_1600_core_shift (shift_op, operands, shift_amount)
- enum rtx_code shift_op;
- rtx *operands;
- int shift_amount;
-{
- int quotient;
- int i;
- int first_shift_emitted = 0;
- const char * const *shift_asm_ptr;
- const char * const *shift_asm_ptr_first;
-
- if (shift_op == ASHIFT)
- {
- shift_asm_ptr = ashift_left_asm;
- shift_asm_ptr_first = ashift_left_asm_first;
- }
- else if (shift_op == ASHIFTRT)
- {
- shift_asm_ptr = ashift_right_asm;
- shift_asm_ptr_first = ashift_right_asm_first;
- }
- else if (shift_op == LSHIFTRT)
- {
- shift_asm_ptr = lshift_right_asm;
- shift_asm_ptr_first = lshift_right_asm_first;
- }
- else
- fatal_error ("invalid shift operator in emit_1600_core_shift");
-
- while (shift_amount != 0)
- {
- if (shift_amount/16)
- {
- quotient = shift_amount/16;
- shift_amount = shift_amount - (quotient * 16);
- for (i = 0; i < quotient; i++)
- output_asm_insn ((first_shift_emitted ? shift_asm_ptr[SHIFT_INDEX_16]
- : shift_asm_ptr_first[SHIFT_INDEX_16]), operands);
- first_shift_emitted = 1;
- }
- else if (shift_amount/8)
- {
- quotient = shift_amount/8;
- shift_amount = shift_amount - (quotient * 8);
- for (i = 0; i < quotient; i++)
- output_asm_insn ((first_shift_emitted ? shift_asm_ptr[SHIFT_INDEX_8]
- : shift_asm_ptr_first[SHIFT_INDEX_8]), operands);
- first_shift_emitted = 1;
- }
- else if (shift_amount/4)
- {
- quotient = shift_amount/4;
- shift_amount = shift_amount - (quotient * 4);
- for (i = 0; i < quotient; i++)
- output_asm_insn ((first_shift_emitted ? shift_asm_ptr[SHIFT_INDEX_4]
- : shift_asm_ptr_first[SHIFT_INDEX_4]), operands);
- first_shift_emitted = 1;
- }
- else if (shift_amount/1)
- {
- quotient = shift_amount/1;
- shift_amount = shift_amount - (quotient * 1);
- for (i = 0; i < quotient; i++)
- output_asm_insn ((first_shift_emitted ? shift_asm_ptr[SHIFT_INDEX_1]
- : shift_asm_ptr_first[SHIFT_INDEX_1]), operands);
- first_shift_emitted = 1;
- }
- }
-}
-#endif
-
-int
-num_1600_core_shifts (shift_amount)
-int shift_amount;
-{
- int quotient;
- int i;
- int first_shift_emitted = 0;
- int num_shifts = 0;
-
- while (shift_amount != 0)
- {
- if (shift_amount/16)
- {
- quotient = shift_amount/16;
- shift_amount = shift_amount - (quotient * 16);
- for (i = 0; i < quotient; i++)
- num_shifts++;
- first_shift_emitted = 1;
- }
- else if (shift_amount/8)
- {
- quotient = shift_amount/8;
- shift_amount = shift_amount - (quotient * 8);
- for (i = 0; i < quotient; i++)
- num_shifts++;
-
- first_shift_emitted = 1;
- }
- else if (shift_amount/4)
- {
- quotient = shift_amount/4;
- shift_amount = shift_amount - (quotient * 4);
- for (i = 0; i < quotient; i++)
- num_shifts++;
-
- first_shift_emitted = 1;
- }
- else if (shift_amount/1)
- {
- quotient = shift_amount/1;
- shift_amount = shift_amount - (quotient * 1);
- for (i = 0; i < quotient; i++)
- num_shifts++;
-
- first_shift_emitted = 1;
- }
- }
- return num_shifts;
-}
-
-void
-asm_output_common(file, name, size, rounded)
- FILE *file;
- const char *name;
- int size ATTRIBUTE_UNUSED;
- int rounded;
-{
- bss_section ();
- (*targetm.asm_out.globalize_label) (file, name);
- assemble_name (file, name);
- fputs (":", file);
- if (rounded > 1)
- fprintf (file, "%d * int\n", rounded);
- else
- fprintf (file, "int\n");
-}
-
-void
-asm_output_local(file, name, size, rounded)
- FILE *file;
- const char *name;
- int size ATTRIBUTE_UNUSED;
- int rounded;
-{
- bss_section ();
- assemble_name (file, name);
- fputs (":", file);
- if (rounded > 1)
- fprintf (file, "%d * int\n", rounded);
- else
- fprintf (file, "int\n");
-}
-
-static int
-dsp16xx_address_cost (addr)
- rtx addr;
-{
- switch (GET_CODE (addr))
- {
- default:
- break;
-
- case REG:
- return 1;
-
- case CONST:
- {
- rtx offset = const0_rtx;
- addr = eliminate_constant_term (addr, &offset);
-
- if (GET_CODE (addr) == LABEL_REF)
- return 2;
-
- if (GET_CODE (addr) != SYMBOL_REF)
- return 4;
-
- if (INTVAL (offset) == 0)
- return 2;
- }
- /* fall through */
-
- case POST_INC: case POST_DEC:
- return (GET_MODE (addr) == QImode ? 1 : 2);
-
- case SYMBOL_REF: case LABEL_REF:
- return 2;
-
- case PLUS:
- {
- register rtx plus0 = XEXP (addr, 0);
- register rtx plus1 = XEXP (addr, 1);
-
- if (GET_CODE (plus0) != REG && GET_CODE (plus1) == REG)
- {
- plus0 = XEXP (addr, 1);
- plus1 = XEXP (addr, 0);
- }
-
- if (GET_CODE (plus0) != REG)
- break;
-
- switch (GET_CODE (plus1))
- {
- default:
- break;
-
- case CONST_INT:
- return 4;
-
- case CONST:
- case SYMBOL_REF:
- case LABEL_REF:
- return dsp16xx_address_cost (plus1) + 1;
- }
- }
- }
-
- return 4;
-}
-
-\f
-/* Determine whether a function argument is passed in a register, and
- which register.
-
- The arguments are CUM, which summarizes all the previous
- arguments; MODE, the machine mode of the argument; TYPE,
- the data type of the argument as a tree node or 0 if that is not known
- (which happens for C support library functions); and NAMED,
- which is 1 for an ordinary argument and 0 for nameless arguments that
- correspond to `...' in the called function's prototype.
-
- The value of the expression should either be a `reg' RTX for the
- hard register in which to pass the argument, or zero to pass the
- argument on the stack.
-
- On the dsp1610 the first four words of args are normally in registers
- and the rest are pushed. If we a long or on float mode, the argument
- must begin on an even register boundary
-
- Note that FUNCTION_ARG and FUNCTION_INCOMING_ARG were different.
- For structures that are passed in memory, but could have been
- passed in registers, we first load the structure into the
- register, and then when the last argument is passed, we store
- the registers into the stack locations. This fixes some bugs
- where GCC did not expect to have register arguments, followed. */
-
-struct rtx_def *
-dsp16xx_function_arg (args_so_far, mode, type, named)
- CUMULATIVE_ARGS args_so_far;
- enum machine_mode mode;
- tree type;
- int named;
-{
- if (TARGET_REGPARM)
- {
- if ((args_so_far & 1) != 0
- && (mode == HImode || GET_MODE_CLASS(mode) == MODE_FLOAT))
- args_so_far++;
-
- if (type == void_type_node)
- return (struct rtx_def *) 0;
-
- if (named && args_so_far < 4 && !MUST_PASS_IN_STACK (mode,type))
- return gen_rtx_REG (mode, args_so_far + FIRST_REG_FOR_FUNCTION_ARG);
- else
- return (struct rtx_def *) 0;
- }
- else
- return (struct rtx_def *) 0;
-}
-
-/* Advance the argument to the next argument position. */
-
-void
-dsp16xx_function_arg_advance (cum, mode, type, named)
- CUMULATIVE_ARGS *cum; /* current arg information */
- enum machine_mode mode; /* current arg mode */
- tree type; /* type of the argument or 0 if lib support */
- int named ATTRIBUTE_UNUSED;/* whether or not the argument was named */
-{
- if (TARGET_REGPARM)
- {
- if ((*cum & 1) != 0
- && (mode == HImode || GET_MODE_CLASS(mode) == MODE_FLOAT))
- *cum += 1;
-
- if (mode != BLKmode)
- *cum += GET_MODE_SIZE (mode);
- else
- *cum += int_size_in_bytes (type);
- }
-}
-
-static void
-dsp16xx_file_start ()
-{
- fprintf (asm_out_file, "#include <%s.h>\n", save_chip_name);
-}
-
-rtx
-gen_tst_reg (x)
- rtx x;
-{
- enum machine_mode mode;
-
- mode = GET_MODE (x);
-
- if (mode == QImode)
- emit_insn (gen_rtx_PARALLEL
- (VOIDmode,
- gen_rtvec (2, gen_rtx_SET (VOIDmode, cc0_rtx, x),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)))));
- else if (mode == HImode)
- emit_insn (gen_rtx_SET (VOIDmode, cc0_rtx, x));
- else
- fatal_error ("invalid mode for gen_tst_reg");
-
- return cc0_rtx;
-}
-
-rtx
-gen_compare_reg (code, x, y)
- enum rtx_code code;
- rtx x, y;
-{
- enum machine_mode mode;
-
- mode = GET_MODE (x);
- /* For floating point compare insns, a call is generated so don't
- do anything here. */
-
- if (GET_MODE_CLASS (mode) == MODE_FLOAT)
- return cc0_rtx;
-
- if (mode == QImode)
- {
- if (code == GTU || code == GEU
- || code == LTU || code == LEU)
- {
- emit_insn (gen_rtx_PARALLEL
- (VOIDmode,
- gen_rtvec (3,
- gen_rtx_SET (VOIDmode, cc0_rtx,
- gen_rtx_COMPARE (mode, x, y)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)))));
- }
- else
- {
- emit_insn (gen_rtx_PARALLEL
- (VOIDmode,
- gen_rtvec (3, gen_rtx_SET (VOIDmode, cc0_rtx,
- gen_rtx_COMPARE (mode, x, y)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)))));
- }
- }
- else if (mode == HImode)
- {
- if (code == GTU || code == GEU
- || code == LTU || code == LEU)
- {
- emit_insn (gen_rtx_PARALLEL
- (VOIDmode,
- gen_rtvec (5,
- gen_rtx_SET (VOIDmode, cc0_rtx,
- gen_rtx_COMPARE (VOIDmode, x, y)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (QImode)))));
- }
- else
- emit_insn (gen_rtx_SET (VOIDmode, cc0_rtx,
- gen_rtx_COMPARE (VOIDmode,
- force_reg (HImode, x),
- force_reg (HImode,y))));
- }
- else
- fatal_error ("invalid mode for integer comparison in gen_compare_reg");
-
- return cc0_rtx;
-}
-
-const char *
-output_block_move (operands)
- rtx operands[];
-{
- int loop_count = INTVAL(operands[2]);
- rtx xoperands[4];
-
- fprintf (asm_out_file, "\tdo %d {\n", loop_count);
- xoperands[0] = operands[4];
- xoperands[1] = operands[1];
- output_asm_insn ("%0=*%1++", xoperands);
-
- xoperands[0] = operands[0];
- xoperands[1] = operands[4];
- output_asm_insn ("*%0++=%1", xoperands);
-
- fprintf (asm_out_file, "\t}\n");
- return "";
-}
-
-int
-uns_comparison_operator (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- if (mode == VOIDmode || GET_MODE (op) == mode)
- {
- enum rtx_code code;
-
- code = GET_CODE(op);
-
- if (code == LEU || code == LTU || code == GEU
- || code == GTU)
- {
- return 1;
- }
- else
- return 0;
- }
-
- return 0;
-}
-
-int
-signed_comparison_operator (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- if (mode == VOIDmode || GET_MODE (op) == mode)
- {
- enum rtx_code code;
-
- code = GET_CODE(op);
-
- if (!(code == LEU || code == LTU || code == GEU
- || code == GTU))
- {
- return 1;
- }
- else
- return 0;
- }
-
- return 0;
-}
-\f
-static bool
-dsp16xx_rtx_costs (x, code, outer_code, total)
- rtx x;
- int code;
- int outer_code ATTRIBUTE_UNUSED;
- int *total;
-{
- switch (code)
- {
- case CONST_INT:
- *total = (unsigned HOST_WIDE_INT) INTVAL (x) < 65536 ? 0 : 2;
- return true;
-
- case LABEL_REF:
- case SYMBOL_REF:
- case CONST:
- *total = COSTS_N_INSNS (1);
- return true;
-
- case CONST_DOUBLE:
- *total = COSTS_N_INSNS (2);
- return true;
-
- case MEM:
- *total = COSTS_N_INSNS (GET_MODE (x) == QImode ? 2 : 4);
- return true;
-
- case DIV:
- case MOD:
- *total = COSTS_N_INSNS (38);
- return true;
-
- case MULT:
- if (GET_MODE (x) == QImode)
- *total = COSTS_N_INSNS (2);
- else
- *total = COSTS_N_INSNS (38);
- return true;
-
- case PLUS:
- case MINUS:
- case AND:
- case IOR:
- case XOR:
- if (GET_MODE_CLASS (GET_MODE (x)) == MODE_INT)
- {
- *total = 1;
- return false;
- }
- else
- {
- *total = COSTS_N_INSNS (38);
- return true;
- }
-
- case NEG:
- case NOT:
- *total = COSTS_N_INSNS (1);
- return true;
-
- case ASHIFT:
- case ASHIFTRT:
- case LSHIFTRT:
- if (GET_CODE (XEXP (x, 1)) == CONST_INT)
- {
- HOST_WIDE_INT number = INTVAL (XEXP (x, 1));
- if (number == 1 || number == 4 || number == 8
- || number == 16)
- *total = COSTS_N_INSNS (1);
- else if (TARGET_BMU)
- *total = COSTS_N_INSNS (2);
- else
- *total = COSTS_N_INSNS (num_1600_core_shifts (number));
- return true;
- }
- break;
- }
-
- if (TARGET_BMU)
- *total = COSTS_N_INSNS (1);
- else
- *total = COSTS_N_INSNS (15);
- return true;
-}
+++ /dev/null
-/* Definitions of target machine for GNU compiler. AT&T DSP1600.
- Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003
- Free Software Foundation, Inc.
- Contributed by Michael Collison (collison@isisinc.net).
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-extern const char *low_reg_names[];
-extern const char *text_seg_name;
-extern const char *rsect_text;
-extern const char *data_seg_name;
-extern const char *rsect_data;
-extern const char *bss_seg_name;
-extern const char *rsect_bss;
-extern const char *const_seg_name;
-extern const char *rsect_const;
-extern const char *chip_name;
-extern const char *save_chip_name;
-extern GTY(()) rtx dsp16xx_compare_op0;
-extern GTY(()) rtx dsp16xx_compare_op1;
-extern GTY(()) rtx dsp16xx_addhf3_libcall;
-extern GTY(()) rtx dsp16xx_subhf3_libcall;
-extern GTY(()) rtx dsp16xx_mulhf3_libcall;
-extern GTY(()) rtx dsp16xx_divhf3_libcall;
-extern GTY(()) rtx dsp16xx_cmphf3_libcall;
-extern GTY(()) rtx dsp16xx_fixhfhi2_libcall;
-extern GTY(()) rtx dsp16xx_floathihf2_libcall;
-extern GTY(()) rtx dsp16xx_neghf2_libcall;
-extern GTY(()) rtx dsp16xx_mulhi3_libcall;
-extern GTY(()) rtx dsp16xx_udivqi3_libcall;
-extern GTY(()) rtx dsp16xx_udivhi3_libcall;
-extern GTY(()) rtx dsp16xx_divqi3_libcall;
-extern GTY(()) rtx dsp16xx_divhi3_libcall;
-extern GTY(()) rtx dsp16xx_modqi3_libcall;
-extern GTY(()) rtx dsp16xx_modhi3_libcall;
-extern GTY(()) rtx dsp16xx_umodqi3_libcall;
-extern GTY(()) rtx dsp16xx_umodhi3_libcall;
-
-extern GTY(()) rtx dsp16xx_ashrhi3_libcall;
-extern GTY(()) rtx dsp16xx_ashlhi3_libcall;
-extern GTY(()) rtx dsp16xx_lshrhi3_libcall;
-
-/* RUN-TIME TARGET SPECIFICATION */
-#define DSP16XX 1
-
-/* Name of the AT&T assembler */
-
-#define ASM_PROG "as1600"
-
-/* Name of the AT&T linker */
-
-#define LD_PROG "ld1600"
-
-/* Define which switches take word arguments */
-#define WORD_SWITCH_TAKES_ARG(STR) \
- (!strcmp (STR, "ifile") ? 1 : \
- 0)
-
-#undef CC1_SPEC
-#define CC1_SPEC "%{!O*:-O}"
-
-/* Define this as a spec to call the AT&T assembler */
-
-#define CROSS_ASM_SPEC "%{!S:as1600 %a %i\n }"
-
-/* Define this as a spec to call the AT&T linker */
-
-#define CROSS_LINK_SPEC "%{!c:%{!M:%{!MM:%{!E:%{!S:ld1600 %l %X %{o*} %{m} \
- %{r} %{s} %{t} %{u*} %{x}\
- %{!A:%{!nostdlib:%{!nostartfiles:%S}}} %{static:}\
- %{L*} %D %o %{!nostdlib:-le1600 %L -le1600}\
- %{!A:%{!nostdlib:%{!nostartfiles:%E}}}\n }}}}}"
-
-/* Nothing complicated here, just link with libc.a under normal
- circumstances */
-#define LIB_SPEC "-lc"
-
-/* Specify the startup file to link with. */
-#define STARTFILE_SPEC "%{mmap1:m1_crt0.o%s} \
-%{mmap2:m2_crt0.o%s} \
-%{mmap3:m3_crt0.o%s} \
-%{mmap4:m4_crt0.o%s} \
-%{!mmap*: %{!ifile*: m4_crt0.o%s} %{ifile*: \
-%ea -ifile option requires a -map option}}"
-
-/* Specify the end file to link with */
-
-#define ENDFILE_SPEC "%{mmap1:m1_crtn.o%s} \
-%{mmap2:m2_crtn.o%s} \
-%{mmap3:m3_crtn.o%s} \
-%{mmap4:m4_crtn.o%s} \
-%{!mmap*: %{!ifile*: m4_crtn.o%s} %{ifile*: \
-%ea -ifile option requires a -map option}}"
-
-
-/* Tell gcc where to look for the startfile */
-/*#define STANDARD_STARTFILE_PREFIX "/d1600/lib"*/
-
-/* Tell gcc where to look for it's executables */
-/*#define STANDARD_EXEC_PREFIX "/d1600/bin"*/
-
-/* Command line options to the AT&T assembler */
-#define ASM_SPEC "%{V} %{v:%{!V:-V}} %{g*:-g}"
-
-/* Command line options for the AT&T linker */
-
-#define LINK_SPEC "%{V} %{v:%{!V:-V}} %{minit:-i} \
-%{!ifile*:%{mmap1:m1_deflt.if%s} \
- %{mmap2:m2_deflt.if%s} \
- %{mmap3:m3_deflt.if%s} \
- %{mmap4:m4_deflt.if%s} \
- %{!mmap*:m4_deflt.if%s}} \
-%{ifile*:%*} %{r}"
-
-/* Include path is determined from the environment variable */
-#define INCLUDE_DEFAULTS \
-{ \
- { 0, 0, 0, 0, 0 } \
-}
-
-/* Names to predefine in the preprocessor for this target machine. */
-#define TARGET_CPU_CPP_BUILTINS() \
- do \
- { \
- builtin_define_std ("dsp1600"); \
- builtin_define_std ("DSP1600"); \
- } \
- while (0)
-
-#ifdef __MSDOS__
-# define TARGET_OS_CPP_BUILTINS() \
- do \
- { \
- builtin_define_std ("MSDOS"); \
- } \
- while (0)
-#else
-# define TARGET_OS_CPP_BUILTINS() \
- do \
- { \
- builtin_define_std ("dsp1610"); \
- builtin_define_std ("DSP1610"); \
- } \
- while (0)
-#endif
-
-/* Run-time compilation parameters selecting different hardware subsets. */
-
-extern int target_flags;
-
-/* Macros used in the machine description to test the flags. */
-
-#define MASK_REGPARM 0x00000001 /* Pass parameters in registers */
-#define MASK_NEAR_CALL 0x00000002 /* The call is on the same 4k page */
-#define MASK_NEAR_JUMP 0x00000004 /* The jump is on the same 4k page */
-#define MASK_BMU 0x00000008 /* Use the 'bmu' shift instructions */
-#define MASK_MAP1 0x00000040 /* Link with map1 */
-#define MASK_MAP2 0x00000080 /* Link with map2 */
-#define MASK_MAP3 0x00000100 /* Link with map3 */
-#define MASK_MAP4 0x00000200 /* Link with map4 */
-#define MASK_YBASE_HIGH 0x00000400 /* The ybase register window starts high */
-#define MASK_INIT 0x00000800 /* Have the linker generate tables to
- initialize data at startup */
-#define MASK_RESERVE_YBASE 0x00002000 /* Reserved the ybase registers */
-#define MASK_DEBUG 0x00004000 /* Debugging turned on*/
-#define MASK_SAVE_TEMPS 0x00008000 /* Save temps. option seen */
-
-/* Compile passing first two args in regs 0 and 1.
- This exists only to test compiler features that will
- be needed for RISC chips. It is not usable
- and is not intended to be usable on this cpu. */
-#define TARGET_REGPARM (target_flags & MASK_REGPARM)
-
-/* The call is on the same 4k page, so instead of loading
- the 'pt' register and branching, we can branch directly */
-
-#define TARGET_NEAR_CALL (target_flags & MASK_NEAR_CALL)
-
-/* The jump is on the same 4k page, so instead of loading
- the 'pt' register and branching, we can branch directly */
-
-#define TARGET_NEAR_JUMP (target_flags & MASK_NEAR_JUMP)
-
-/* Generate shift instructions to use the 1610 Bit Manipulation
- Unit. */
-#define TARGET_BMU (target_flags & MASK_BMU)
-
-#define TARGET_YBASE_HIGH (target_flags & MASK_YBASE_HIGH)
-
-/* Direct the linker to output extra info for initialized data */
-#define TARGET_MASK_INIT (target_flags & MASK_INIT)
-
-#define TARGET_INLINE_MULT (target_flags & MASK_INLINE_MULT)
-
-/* Reserve the ybase registers *(0) - *(31) */
-#define TARGET_RESERVE_YBASE (target_flags & MASK_RESERVE_YBASE)
-
-/* We turn this option on internally after seeing "-g" */
-#define TARGET_DEBUG (target_flags & MASK_DEBUG)
-
-/* We turn this option on internally after seeing "-save-temps */
-#define TARGET_SAVE_TEMPS (target_flags & MASK_SAVE_TEMPS)
-
-
-/* Macro to define tables used to set the flags.
- This is a list in braces of pairs in braces,
- each pair being { "NAME", VALUE }
- where VALUE is the bits to set or minus the bits to clear.
- An empty string NAME is used to identify the default VALUE. */
-
-
-#define TARGET_SWITCHES \
- { \
- { "regparm", MASK_REGPARM, \
- N_("Pass parameters in registers (default)") }, \
- { "no-regparm", -MASK_REGPARM, \
- N_("Don't pass parameters in registers") }, \
- { "near-call", MASK_NEAR_JUMP, \
- N_("Generate code for near calls") }, \
- { "no-near-call", -MASK_NEAR_CALL, \
- N_("Don't generate code for near calls") }, \
- { "near-jump", MASK_NEAR_JUMP, \
- N_("Generate code for near jumps") }, \
- { "no-near-jump", -MASK_NEAR_JUMP, \
- N_("Don't generate code for near jumps") }, \
- { "bmu", MASK_BMU, \
- N_("Generate code for a bit-manipulation unit") }, \
- { "no-bmu", -MASK_BMU, \
- N_("Don't generate code for a bit-manipulation unit") }, \
- { "map1", MASK_MAP1, \
- N_("Generate code for memory map1") }, \
- { "map2", MASK_MAP2, \
- N_("Generate code for memory map2") }, \
- { "map3", MASK_MAP3, \
- N_("Generate code for memory map3") }, \
- { "map4", MASK_MAP4, \
- N_("Generate code for memory map4") }, \
- { "init", MASK_INIT, \
- N_("Ouput extra code for initialized data") }, \
- { "reserve-ybase", MASK_RESERVE_YBASE, \
- N_("Don't let reg. allocator use ybase registers") }, \
- { "debug", MASK_DEBUG, \
- N_("Output extra debug info in Luxworks environment") }, \
- { "save-temporaries", MASK_SAVE_TEMPS, \
- N_("Save temp. files in Luxworks environment") }, \
- { "", TARGET_DEFAULT, ""} \
- }
-
-/* Default target_flags if no switches are specified */
-#ifndef TARGET_DEFAULT
-#define TARGET_DEFAULT MASK_REGPARM|MASK_YBASE_HIGH
-#endif
-
-#define TARGET_OPTIONS \
-{ \
- { "text=", &text_seg_name, \
- N_("Specify alternate name for text section"), 0}, \
- { "data=", &data_seg_name, \
- N_("Specify alternate name for data section"), 0}, \
- { "bss=", &bss_seg_name, \
- N_("Specify alternate name for bss section"), 0}, \
- { "const=", &const_seg_name, \
- N_("Specify alternate name for constant section"), 0}, \
- { "chip=", &chip_name, \
- N_("Specify alternate name for dsp16xx chip"), 0}, \
-}
-
-/* Sometimes certain combinations of command options do not make sense
- on a particular target machine. You can define a macro
- `OVERRIDE_OPTIONS' to take account of this. This macro, if
- defined, is executed once just after all the command options have
- been parsed.
-
- Don't use this macro to turn on various extra optimizations for
- `-O'. That is what `OPTIMIZATION_OPTIONS' is for. */
-
-#define OVERRIDE_OPTIONS override_options ()
-
-#define OPTIMIZATION_OPTIONS(LEVEL,SIZE) \
-{ \
- if (LEVEL >= 2) \
- { \
- /* The dsp16xx family has so few registers \
- * that running the first instruction \
- * scheduling is bad for reg. allocation \
- * since it increases lifetimes of pseudos. \
- * So turn of first scheduling pass. \
- */ \
- flag_schedule_insns = FALSE; \
- } \
-}
-\f
-/* STORAGE LAYOUT */
-
-/* Define this if most significant bit is lowest numbered
- in instructions that operate on numbered bit-fields.
- */
-#define BITS_BIG_ENDIAN 0
-
-/* Define this if most significant byte of a word is the lowest numbered.
- We define big-endian, but since the 1600 series cannot address bytes
- it does not matter. */
-#define BYTES_BIG_ENDIAN 1
-
-/* Define this if most significant word of a multiword number is numbered.
- For the 1600 we can decide arbitrarily since there are no machine instructions for them. */
-#define WORDS_BIG_ENDIAN 1
-
-/* number of bits in an addressable storage unit */
-#define BITS_PER_UNIT 16
-
-/* Maximum number of bits in a word. */
-#define MAX_BITS_PER_WORD 16
-
-/* Width of a word, in units (bytes). */
-#define UNITS_PER_WORD 1
-
-/* Allocation boundary (in *bits*) for storing pointers in memory. */
-#define POINTER_BOUNDARY 16
-
-/* Allocation boundary (in *bits*) for storing arguments in argument list. */
-#define PARM_BOUNDARY 16
-
-/* Boundary (in *bits*) on which stack pointer should be aligned. */
-#define STACK_BOUNDARY 16
-
-/* Allocation boundary (in *bits*) for the code of a function. */
-#define FUNCTION_BOUNDARY 16
-
-/* Biggest alignment that any data type can require on this machine, in bits. */
-#define BIGGEST_ALIGNMENT 16
-
-/* Biggest alignment that any structure field can require on this machine, in bits */
-#define BIGGEST_FIELD_ALIGNMENT 16
-
-/* Alignment of field after `int : 0' in a structure. */
-#define EMPTY_FIELD_BOUNDARY 16
-
-/* Number of bits which any structure or union's size must be a multiple of. Each structure
- or union's size is rounded up to a multiple of this */
-#define STRUCTURE_SIZE_BOUNDARY 16
-
-/* Define this if move instructions will actually fail to work
- when given unaligned data. */
-#define STRICT_ALIGNMENT 1
-
-/* An integer expression for the size in bits of the largest integer machine mode that
- should actually be used. All integer machine modes of this size or smaller can be
- used for structures and unions with the appropriate sizes. */
-#define MAX_FIXED_MODE_SIZE 32
-\f
-/* LAYOUT OF SOURCE LANGUAGE DATA TYPES */
-
-#define SHORT_TYPE_SIZE 16
-#define INT_TYPE_SIZE 16
-#define LONG_TYPE_SIZE 32
-#define LONG_LONG_TYPE_SIZE 32
-#define FLOAT_TYPE_SIZE 32
-#define DOUBLE_TYPE_SIZE 32
-#define LONG_DOUBLE_TYPE_SIZE 32
-
-/* An expression whose value is 1 or 0, according to whether the type char should be
- signed or unsigned by default. */
-
-#define DEFAULT_SIGNED_CHAR 1
-
-/* A C expression to determine whether to give an enum type only as many bytes
- as it takes to represent the range of possible values of that type. A nonzero
- value means to do that; a zero value means all enum types should be allocated
- like int. */
-
-#define DEFAULT_SHORT_ENUMS 0
-
-/* A C expression for a string describing the name of the data type to use for
- size values. */
-
-#define SIZE_TYPE "unsigned int"
-
-/* A C expression for a string describing the name of the data type to use for the
- result of subtracting two pointers */
-
-#define PTRDIFF_TYPE "int"
-
-\f
-/* REGISTER USAGE. */
-
-#define ALL_16_BIT_REGISTERS 1
-
-/* Number of actual hardware registers.
- The hardware registers are assigned numbers for the compiler
- from 0 to FIRST_PSEUDO_REGISTER-1 */
-
-#define FIRST_PSEUDO_REGISTER (REG_YBASE31 + 1)
-
-/* 1 for registers that have pervasive standard uses
- and are not available for the register allocator.
-
- The registers are laid out as follows:
-
- {a0,a0l,a1,a1l,x,y,yl,p,pl} - Data Arithmetic Unit
- {r0,r1,r2,r3,j,k,ybase} - Y Space Address Arithmetic Unit
- {pt} - X Space Address Arithmetic Unit
- {ar0,ar1,ar2,ar3} - Bit Manipulation UNit
- {pr} - Return Address Register
-
- We reserve r2 for the Stack Pointer.
- We specify r3 for the Frame Pointer but allow the compiler
- to omit it when possible since we have so few pointer registers. */
-
-#define REG_A0 0
-#define REG_A0L 1
-#define REG_A1 2
-#define REG_A1L 3
-#define REG_X 4
-#define REG_Y 5
-#define REG_YL 6
-#define REG_PROD 7
-#define REG_PRODL 8
-#define REG_R0 9
-#define REG_R1 10
-#define REG_R2 11
-#define REG_R3 12
-#define REG_J 13
-#define REG_K 14
-#define REG_YBASE 15
-#define REG_PT 16
-#define REG_AR0 17
-#define REG_AR1 18
-#define REG_AR2 19
-#define REG_AR3 20
-#define REG_C0 21
-#define REG_C1 22
-#define REG_C2 23
-#define REG_PR 24
-#define REG_RB 25
-#define REG_YBASE0 26
-#define REG_YBASE1 27
-#define REG_YBASE2 28
-#define REG_YBASE3 29
-#define REG_YBASE4 30
-#define REG_YBASE5 31
-#define REG_YBASE6 32
-#define REG_YBASE7 33
-#define REG_YBASE8 34
-#define REG_YBASE9 35
-#define REG_YBASE10 36
-#define REG_YBASE11 37
-#define REG_YBASE12 38
-#define REG_YBASE13 39
-#define REG_YBASE14 40
-#define REG_YBASE15 41
-#define REG_YBASE16 42
-#define REG_YBASE17 43
-#define REG_YBASE18 44
-#define REG_YBASE19 45
-#define REG_YBASE20 46
-#define REG_YBASE21 47
-#define REG_YBASE22 48
-#define REG_YBASE23 49
-#define REG_YBASE24 50
-#define REG_YBASE25 51
-#define REG_YBASE26 52
-#define REG_YBASE27 53
-#define REG_YBASE28 54
-#define REG_YBASE29 55
-#define REG_YBASE30 56
-#define REG_YBASE31 57
-
-/* Do we have an accumulator register? */
-#define IS_ACCUM_REG(REGNO) IN_RANGE ((REGNO), REG_A0, REG_A1L)
-#define IS_ACCUM_LOW_REG(REGNO) ((REGNO) == REG_A0L || (REGNO) == REG_A1L)
-
-/* Do we have a virtual ybase register */
-#define IS_YBASE_REGISTER_WINDOW(REGNO) ((REGNO) >= REG_YBASE0 && (REGNO) <= REG_YBASE31)
-
-#define IS_YBASE_ELIGIBLE_REG(REGNO) (IS_ACCUM_REG (REGNO) || IS_ADDRESS_REGISTER(REGNO) \
- || REGNO == REG_X || REGNO == REG_Y || REGNO == REG_YL \
- || REGNO == REG_PROD || REGNO == REG_PRODL)
-
-#define IS_ADDRESS_REGISTER(REGNO) ((REGNO) >= REG_R0 && (REGNO) <= REG_R3)
-
-#define FIXED_REGISTERS \
-{0, 0, 0, 0, 0, 0, 0, 0, 0, \
- 0, 0, 0, 1, 0, 0, 1, \
- 1, \
- 0, 0, 0, 0, \
- 1, 1, 1, \
- 1, 0, \
- 0, 0, 0, 0, 0, 0, 0, 0, \
- 0, 0, 0, 0, 0, 0, 0, 0, \
- 0, 0, 0, 0, 0, 0, 0, 0, \
- 0, 0, 0, 0, 0, 0, 0, 0}
-
-/* 1 for registers not available across function calls.
- These must include the FIXED_REGISTERS and also any
- registers that can be used without being saved.
- The latter must include the registers where values are returned
- and the register where structure-value addresses are passed.
- On the 1610 'a0' holds return values from functions. 'r0' holds
- structure-value addresses.
-
- In addition we don't save either j, k, ybase or any of the
- bit manipulation registers. */
-
-
-#define CALL_USED_REGISTERS \
-{1, 1, 1, 1, 0, 1, 1, 1, 1, /* 0-8 */ \
- 1, 0, 0, 1, 1, 1, 1, /* 9-15 */ \
- 1, /* 16 */ \
- 0, 0, 1, 1, /* 17-20 */ \
- 1, 1, 1, /* 21-23 */ \
- 1, 1, /* 24-25 */ \
- 0, 0, 0, 0, 0, 0, 0, 0, /* 26-33 */ \
- 0, 0, 0, 0, 0, 0, 0, 0, /* 34-41 */ \
- 0, 0, 0, 0, 0, 0, 0, 0, /* 42-49 */ \
- 0, 0, 0, 0, 0, 0, 0, 0} /* 50-57 */
-
-/* List the order in which to allocate registers. Each register must be
- listed once, even those in FIXED_REGISTERS.
-
- We allocate in the following order:
- */
-
-#if 0
-#define REG_ALLOC_ORDER \
-{ REG_R0, REG_R1, REG_R2, REG_PROD, REG_Y, REG_X, \
- REG_PRODL, REG_YL, REG_AR0, REG_AR1, \
- REG_RB, REG_A0, REG_A1, REG_A0L, \
- REG_A1L, REG_AR2, REG_AR3, \
- REG_YBASE, REG_J, REG_K, REG_PR, REG_PT, REG_C0, \
- REG_C1, REG_C2, REG_R3, \
- REG_YBASE0, REG_YBASE1, REG_YBASE2, REG_YBASE3, \
- REG_YBASE4, REG_YBASE5, REG_YBASE6, REG_YBASE7, \
- REG_YBASE8, REG_YBASE9, REG_YBASE10, REG_YBASE11, \
- REG_YBASE12, REG_YBASE13, REG_YBASE14, REG_YBASE15, \
- REG_YBASE16, REG_YBASE17, REG_YBASE18, REG_YBASE19, \
- REG_YBASE20, REG_YBASE21, REG_YBASE22, REG_YBASE23, \
- REG_YBASE24, REG_YBASE25, REG_YBASE26, REG_YBASE27, \
- REG_YBASE28, REG_YBASE29, REG_YBASE30, REG_YBASE31 }
-#else
-#define REG_ALLOC_ORDER \
-{ \
- REG_A0, REG_A0L, REG_A1, REG_A1L, REG_Y, REG_YL, \
- REG_PROD, \
- REG_PRODL, REG_R0, REG_J, REG_K, REG_AR2, REG_AR3, \
- REG_X, REG_R1, REG_R2, REG_RB, REG_AR0, REG_AR1, \
- REG_YBASE0, REG_YBASE1, REG_YBASE2, REG_YBASE3, \
- REG_YBASE4, REG_YBASE5, REG_YBASE6, REG_YBASE7, \
- REG_YBASE8, REG_YBASE9, REG_YBASE10, REG_YBASE11, \
- REG_YBASE12, REG_YBASE13, REG_YBASE14, REG_YBASE15, \
- REG_YBASE16, REG_YBASE17, REG_YBASE18, REG_YBASE19, \
- REG_YBASE20, REG_YBASE21, REG_YBASE22, REG_YBASE23, \
- REG_YBASE24, REG_YBASE25, REG_YBASE26, REG_YBASE27, \
- REG_YBASE28, REG_YBASE29, REG_YBASE30, REG_YBASE31, \
- REG_R3, REG_YBASE, REG_PT, REG_C0, REG_C1, REG_C2, \
- REG_PR }
-#endif
-/* Zero or more C statements that may conditionally modify two
- variables `fixed_regs' and `call_used_regs' (both of type `char
- []') after they have been initialized from the two preceding
- macros.
-
- This is necessary in case the fixed or call-clobbered registers
- depend on target flags.
-
- You need not define this macro if it has no work to do.
-
- If the usage of an entire class of registers depends on the target
- flags, you may indicate this to GCC by using this macro to modify
- `fixed_regs' and `call_used_regs' to 1 for each of the registers in
- the classes which should not be used by GCC. Also define the macro
- `REG_CLASS_FROM_LETTER' to return `NO_REGS' if it is called with a
- letter for a class that shouldn't be used.
-
- (However, if this class is not included in `GENERAL_REGS' and all
- of the insn patterns whose constraints permit this class are
- controlled by target switches, then GCC will automatically avoid
- using these registers when the target switches are opposed to
- them.) If the user tells us there is no BMU, we can't use
- ar0-ar3 for register allocation */
-
-#define CONDITIONAL_REGISTER_USAGE \
-do \
- { \
- if (!TARGET_BMU) \
- { \
- int regno; \
- \
- for (regno = REG_AR0; regno <= REG_AR3; regno++) \
- fixed_regs[regno] = call_used_regs[regno] = 1; \
- } \
- if (TARGET_RESERVE_YBASE) \
- { \
- int regno; \
- \
- for (regno = REG_YBASE0; regno <= REG_YBASE31; regno++) \
- fixed_regs[regno] = call_used_regs[regno] = 1; \
- } \
- } \
-while (0)
-
-/* Determine which register classes are very likely used by spill registers.
- local-alloc.c won't allocate pseudos that have these classes as their
- preferred class unless they are "preferred or nothing". */
-
-#define CLASS_LIKELY_SPILLED_P(CLASS) \
- ((CLASS) != ALL_REGS && (CLASS) != YBASE_VIRT_REGS)
-
-/* Return number of consecutive hard regs needed starting at reg REGNO
- to hold something of mode MODE.
- This is ordinarily the length in words of a value of mode MODE
- but can be less for certain modes in special long registers. */
-
-#define HARD_REGNO_NREGS(REGNO, MODE) \
- (GET_MODE_SIZE(MODE))
-
-/* Value is 1 if hard register REGNO can hold a value of machine-mode MODE. */
-
-#define HARD_REGNO_MODE_OK(REGNO, MODE) hard_regno_mode_ok(REGNO, MODE)
-
-/* Value is 1 if it is a good idea to tie two pseudo registers
- when one has mode MODE1 and one has mode MODE2.
- If HARD_REGNO_MODE_OK could produce different values for MODE1 and MODE2,
- for any hard reg, then this must be 0 for correct output. */
-#define MODES_TIEABLE_P(MODE1, MODE2) \
- (((MODE1) == (MODE2)) || \
- (GET_MODE_CLASS((MODE1)) == MODE_FLOAT) \
- == (GET_MODE_CLASS((MODE2)) == MODE_FLOAT))
-
-/* Specify the registers used for certain standard purposes.
- The values of these macros are register numbers. */
-
-/* DSP1600 pc isn't overloaded on a register. */
-/* #define PC_REGNUM */
-
-/* Register to use for pushing function arguments.
- This is r3 in our case */
-#define STACK_POINTER_REGNUM REG_R3
-
-/* Base register for access to local variables of the function.
- This is r2 in our case */
-#define FRAME_POINTER_REGNUM REG_R2
-
-/* We can debug without the frame pointer */
-#define CAN_DEBUG_WITHOUT_FP 1
-
-/* The 1610 saves the return address in this register */
-#define RETURN_ADDRESS_REGNUM REG_PR
-
-/* Base register for access to arguments of the function. */
-#define ARG_POINTER_REGNUM FRAME_POINTER_REGNUM
-
-/* Register in which static-chain is passed to a function. */
-
-#define STATIC_CHAIN_REGNUM 4
-
-/* Register in which address to store a structure value
- is passed to a function. This is 'r0' in our case */
-#define STRUCT_VALUE_REGNUM REG_R0
-\f
-/* Define the classes of registers for register constraints in the
- machine description. Also define ranges of constants.
-
- One of the classes must always be named ALL_REGS and include all hard regs.
- If there is more than one class, another class must be named NO_REGS
- and contain no registers.
-
- The name GENERAL_REGS must be the name of a class (or an alias for
- another name such as ALL_REGS). This is the class of registers
- that is allowed by "g" or "r" in a register constraint.
- Also, registers outside this class are allocated only when
- instructions express preferences for them.
-
- The classes must be numbered in nondecreasing order; that is,
- a larger-numbered class must never be contained completely
- in a smaller-numbered class.
-
- For any two classes, it is very desirable that there be another
- class that represents their union. */
-
-
-enum reg_class
-{
- NO_REGS,
- A0H_REG,
- A0L_REG,
- A0_REG,
- A1H_REG,
- ACCUM_HIGH_REGS,
- A1L_REG,
- ACCUM_LOW_REGS,
- A1_REG,
- ACCUM_REGS,
- X_REG,
- X_OR_ACCUM_LOW_REGS,
- X_OR_ACCUM_REGS,
- YH_REG,
- YH_OR_ACCUM_HIGH_REGS,
- X_OR_YH_REGS,
- YL_REG,
- YL_OR_ACCUM_LOW_REGS,
- X_OR_YL_REGS,
- X_OR_Y_REGS,
- Y_REG,
- ACCUM_OR_Y_REGS,
- PH_REG,
- X_OR_PH_REGS,
- PL_REG,
- PL_OR_ACCUM_LOW_REGS,
- X_OR_PL_REGS,
- YL_OR_PL_OR_ACCUM_LOW_REGS,
- P_REG,
- ACCUM_OR_P_REGS,
- YL_OR_P_REGS,
- ACCUM_LOW_OR_YL_OR_P_REGS,
- Y_OR_P_REGS,
- ACCUM_Y_OR_P_REGS,
- NO_FRAME_Y_ADDR_REGS,
- Y_ADDR_REGS,
- ACCUM_LOW_OR_Y_ADDR_REGS,
- ACCUM_OR_Y_ADDR_REGS,
- X_OR_Y_ADDR_REGS,
- Y_OR_Y_ADDR_REGS,
- P_OR_Y_ADDR_REGS,
- NON_HIGH_YBASE_ELIGIBLE_REGS,
- YBASE_ELIGIBLE_REGS,
- J_REG,
- J_OR_DAU_16_BIT_REGS,
- BMU_REGS,
- NOHIGH_NON_ADDR_REGS,
- NON_ADDR_REGS,
- SLOW_MEM_LOAD_REGS,
- NOHIGH_NON_YBASE_REGS,
- NO_ACCUM_NON_YBASE_REGS,
- NON_YBASE_REGS,
- YBASE_VIRT_REGS,
- ACCUM_LOW_OR_YBASE_REGS,
- ACCUM_OR_YBASE_REGS,
- X_OR_YBASE_REGS,
- Y_OR_YBASE_REGS,
- ACCUM_LOW_YL_PL_OR_YBASE_REGS,
- P_OR_YBASE_REGS,
- ACCUM_Y_P_OR_YBASE_REGS,
- Y_ADDR_OR_YBASE_REGS,
- YBASE_OR_NOHIGH_YBASE_ELIGIBLE_REGS,
- YBASE_OR_YBASE_ELIGIBLE_REGS,
- NO_HIGH_ALL_REGS,
- ALL_REGS,
- LIM_REG_CLASSES
-};
-
-/* GENERAL_REGS must be the name of a register class */
-#define GENERAL_REGS ALL_REGS
-
-#define N_REG_CLASSES (int) LIM_REG_CLASSES
-
-/* Give names of register classes as strings for dump file. */
-
-#define REG_CLASS_NAMES \
-{ \
- "NO_REGS", \
- "A0H_REG", \
- "A0L_REG", \
- "A0_REG", \
- "A1H_REG", \
- "ACCUM_HIGH_REGS", \
- "A1L_REG", \
- "ACCUM_LOW_REGS", \
- "A1_REG", \
- "ACCUM_REGS", \
- "X_REG", \
- "X_OR_ACCUM_LOW_REGS", \
- "X_OR_ACCUM_REGS", \
- "YH_REG", \
- "YH_OR_ACCUM_HIGH_REGS", \
- "X_OR_YH_REGS", \
- "YL_REG", \
- "YL_OR_ACCUM_LOW_REGS", \
- "X_OR_YL_REGS", \
- "X_OR_Y_REGS", \
- "Y_REG", \
- "ACCUM_OR_Y_REGS", \
- "PH_REG", \
- "X_OR_PH_REGS", \
- "PL_REG", \
- "PL_OR_ACCUM_LOW_REGS", \
- "X_OR_PL_REGS", \
- "PL_OR_YL_OR_ACCUM_LOW_REGS", \
- "P_REG", \
- "ACCUM_OR_P_REGS", \
- "YL_OR_P_REGS", \
- "ACCUM_LOW_OR_YL_OR_P_REGS", \
- "Y_OR_P_REGS", \
- "ACCUM_Y_OR_P_REGS", \
- "NO_FRAME_Y_ADDR_REGS", \
- "Y_ADDR_REGS", \
- "ACCUM_LOW_OR_Y_ADDR_REGS", \
- "ACCUM_OR_Y_ADDR_REGS", \
- "X_OR_Y_ADDR_REGS", \
- "Y_OR_Y_ADDR_REGS", \
- "P_OR_Y_ADDR_REGS", \
- "NON_HIGH_YBASE_ELIGIBLE_REGS", \
- "YBASE_ELIGIBLE_REGS", \
- "J_REG", \
- "J_OR_DAU_16_BIT_REGS", \
- "BMU_REGS", \
- "NOHIGH_NON_ADDR_REGS", \
- "NON_ADDR_REGS", \
- "SLOW_MEM_LOAD_REGS", \
- "NOHIGH_NON_YBASE_REGS", \
- "NO_ACCUM_NON_YBASE_REGS", \
- "NON_YBASE_REGS", \
- "YBASE_VIRT_REGS", \
- "ACCUM_LOW_OR_YBASE_REGS", \
- "ACCUM_OR_YBASE_REGS", \
- "X_OR_YBASE_REGS", \
- "Y_OR_YBASE_REGS", \
- "ACCUM_LOW_YL_PL_OR_YBASE_REGS", \
- "P_OR_YBASE_REGS", \
- "ACCUM_Y_P_OR_YBASE_REGS", \
- "Y_ADDR_OR_YBASE_REGS", \
- "YBASE_OR_NOHIGH_YBASE_ELIGIBLE_REGS", \
- "YBASE_OR_YBASE_ELIGIBLE_REGS", \
- "NO_HIGH_ALL_REGS", \
- "ALL_REGS" \
-}
-
-/* Define which registers fit in which classes.
- This is an initializer for a vector of HARD_REG_SET
- of length N_REG_CLASSES. */
-
-#define REG_CLASS_CONTENTS \
-{ \
- {0x00000000, 0x00000000}, /* no reg */ \
- {0x00000001, 0x00000000}, /* a0h */ \
- {0x00000002, 0x00000000}, /* a0l */ \
- {0x00000003, 0x00000000}, /* a0h:a0l */ \
- {0x00000004, 0x00000000}, /* a1h */ \
- {0x00000005, 0x00000000}, /* accum high */ \
- {0x00000008, 0x00000000}, /* a1l */ \
- {0x0000000A, 0x00000000}, /* accum low */ \
- {0x0000000c, 0x00000000}, /* a1h:a1l */ \
- {0x0000000f, 0x00000000}, /* accum regs */ \
- {0x00000010, 0x00000000}, /* x reg */ \
- {0x0000001A, 0x00000000}, /* x & accum_low_regs */ \
- {0x0000001f, 0x00000000}, /* x & accum regs */ \
- {0x00000020, 0x00000000}, /* y high */ \
- {0x00000025, 0x00000000}, /* yh, accum high */ \
- {0x00000030, 0x00000000}, /* x & yh */ \
- {0x00000040, 0x00000000}, /* y low */ \
- {0x0000004A, 0x00000000}, /* y low, accum_low */ \
- {0x00000050, 0x00000000}, /* x & yl */ \
- {0x00000060, 0x00000000}, /* yl:yh */ \
- {0x00000070, 0x00000000}, /* x, yh,a nd yl */ \
- {0x0000006F, 0x00000000}, /* accum, y */ \
- {0x00000080, 0x00000000}, /* p high */ \
- {0x00000090, 0x00000000}, /* x & ph */ \
- {0x00000100, 0x00000000}, /* p low */ \
- {0x0000010A, 0x00000000}, /* p_low and accum_low */ \
- {0x00000110, 0x00000000}, /* x & pl */ \
- {0x0000014A, 0x00000000}, /* pl,yl,a1l,a0l */ \
- {0x00000180, 0x00000000}, /* pl:ph */ \
- {0x0000018F, 0x00000000}, /* accum, p */ \
- {0x000001C0, 0x00000000}, /* pl:ph and yl */ \
- {0x000001CA, 0x00000000}, /* pl:ph, yl, a0l, a1l */ \
- {0x000001E0, 0x00000000}, /* y or p */ \
- {0x000001EF, 0x00000000}, /* accum, y or p */ \
- {0x00000E00, 0x00000000}, /* r0-r2 */ \
- {0x00001E00, 0x00000000}, /* r0-r3 */ \
- {0x00001E0A, 0x00000000}, /* r0-r3, accum_low */ \
- {0x00001E0F, 0x00000000}, /* accum,r0-r3 */ \
- {0x00001E10, 0x00000000}, /* x,r0-r3 */ \
- {0x00001E60, 0x00000000}, /* y,r0-r3 */ \
- {0x00001F80, 0x00000000}, /* p,r0-r3 */ \
- {0x00001FDA, 0x00000000}, /* ph:pl, r0-r3, x,a0l,a1l */ \
- {0x00001fff, 0x00000000}, /* accum,x,y,p,r0-r3 */ \
- {0x00002000, 0x00000000}, /* j */ \
- {0x00002025, 0x00000000}, /* j, yh, a1h, a0h */ \
- {0x001E0000, 0x00000000}, /* ar0-ar3 */ \
- {0x03FFE1DA, 0x00000000}, /* non_addr except yh,a0h,a1h */ \
- {0x03FFE1FF, 0x00000000}, /* non_addr regs */ \
- {0x03FFFF8F, 0x00000000}, /* non ybase except yh, yl, and x */ \
- {0x03FFFFDA, 0x00000000}, /* non ybase regs except yh,a0h,a1h */ \
- {0x03FFFFF0, 0x00000000}, /* non ybase except a0,a0l,a1,a1l */ \
- {0x03FFFFFF, 0x00000000}, /* non ybase regs */ \
- {0xFC000000, 0x03FFFFFF}, /* virt ybase regs */ \
- {0xFC00000A, 0x03FFFFFF}, /* accum_low, virt ybase regs */ \
- {0xFC00000F, 0x03FFFFFF}, /* accum, virt ybase regs */ \
- {0xFC000010, 0x03FFFFFF}, /* x,virt ybase regs */ \
- {0xFC000060, 0x03FFFFFF}, /* y,virt ybase regs */ \
- {0xFC00014A, 0x03FFFFFF}, /* accum_low, yl, pl, ybase */ \
- {0xFC000180, 0x03FFFFFF}, /* p,virt ybase regs */ \
- {0xFC0001EF, 0x03FFFFFF}, /* accum,y,p,ybase regs */ \
- {0xFC001E00, 0x03FFFFFF}, /* r0-r3, ybase regs */ \
- {0xFC001FDA, 0x03FFFFFF}, /* r0-r3, pl:ph,yl,x,a1l,a0l */ \
- {0xFC001FFF, 0x03FFFFFF}, /* virt ybase, ybase eligible regs */ \
- {0xFCFFFFDA, 0x03FFFFFF}, /* all regs except yh,a0h,a1h */ \
- {0xFFFFFFFF, 0x03FFFFFF} /* all regs */ \
-}
-
-
-/* The same information, inverted:
- Return the class number of the smallest class containing
- reg number REGNO. This could be a conditional expression
- or could index an array. */
-
-#define REGNO_REG_CLASS(REGNO) regno_reg_class(REGNO)
-
-/* The class value for index registers, and the one for base regs. */
-
-#define INDEX_REG_CLASS NO_REGS
-#define BASE_REG_CLASS Y_ADDR_REGS
-
-/* Get reg_class from a letter such as appears in the machine description. */
-
-#define REG_CLASS_FROM_LETTER(C) \
- dsp16xx_reg_class_from_letter(C)
-
-#define SECONDARY_RELOAD_CLASS(CLASS, MODE, X) \
- secondary_reload_class(CLASS, MODE, X)
-
-/* When defined, the compiler allows registers explicitly used in the
- rtl to be used as spill registers but prevents the compiler from
- extending the lifetime of these registers. */
-
-#define SMALL_REGISTER_CLASSES 1
-
-/* Macros to check register numbers against specific register classes. */
-
-/* These assume that REGNO is a hard or pseudo reg number.
- They give nonzero only if REGNO is a hard reg of the suitable class
- or a pseudo reg currently allocated to a suitable hard reg.
- Since they use reg_renumber, they are safe only once reg_renumber
- has been allocated, which happens in local-alloc.c. */
-
-/* A C expression which is nonzero if register REGNO is suitable for use
- as a base register in operand addresses. It may be either a suitable
- hard register or a pseudo register that has been allocated such a
- hard register.
-
- On the 1610 the Y address pointers can be used as a base registers */
-#define REGNO_OK_FOR_BASE_P(REGNO) \
-(((REGNO) >= REG_R0 && (REGNO) < REG_R3 + 1) || ((unsigned) reg_renumber[REGNO] >= REG_R0 \
- && (unsigned) reg_renumber[REGNO] < REG_R3 + 1))
-
-#define REGNO_OK_FOR_YBASE_P(REGNO) \
- (((REGNO) == REG_YBASE) || ((unsigned) reg_renumber[REGNO] == REG_YBASE))
-
-#define REGNO_OK_FOR_INDEX_P(REGNO) 0
-
-#ifdef ALL_16_BIT_REGISTERS
-#define IS_32_BIT_REG(REGNO) 0
-#else
-#define IS_32_BIT_REG(REGNO) \
- ((REGNO) == REG_A0 || (REGNO) == REG_A1 || (REGNO) == REG_Y || (REGNO) == REG_PROD)
-#endif
-
-/* Given an rtx X being reloaded into a reg required to be
- in class CLASS, return the class of reg to actually use.
- In general this is just CLASS; but on some machines
- in some cases it is preferable to use a more restrictive class.
- Also, we must ensure that a PLUS is reloaded either
- into an accumulator or an address register. */
-
-#define PREFERRED_RELOAD_CLASS(X,CLASS) preferred_reload_class (X, CLASS)
-
-/* A C expression that places additional restrictions on the register
- class to use when it is necessary to be able to hold a value of
- mode MODE in a reload register for which class CLASS would
- ordinarily be used.
-
- Unlike `PREFERRED_RELOAD_CLASS', this macro should be used when
- there are certain modes that simply can't go in certain reload
- classes.
-
- The value is a register class; perhaps CLASS, or perhaps another,
- smaller class.
-
- Don't define this macro unless the target machine has limitations
- which require the macro to do something nontrivial. */
-
-#if 0
-#define LIMIT_RELOAD_CLASS(MODE, CLASS) dsp16xx_limit_reload_class (MODE, CLASS)
-#endif
-
-/* A C expression for the maximum number of consecutive registers of class CLASS
- needed to hold a value of mode MODE */
-#define CLASS_MAX_NREGS(CLASS, MODE) \
- class_max_nregs(CLASS, MODE)
-
-/* The letters 'I' through 'P' in a register constraint string
- can be used to stand for particular ranges of immediate operands.
- This macro defines what the ranges are.
- C is the letter, and VALUE is a constant value.
- Return 1 if VALUE is in the range specified by C.
-
- For the 16xx, the following constraints are used:
- 'I' requires a non-negative 16-bit value.
- 'J' requires a non-negative 9-bit value
- 'K' requires a constant 0 operand.
- 'L' constant for use in add or sub from low 16-bits
- 'M' 32-bit value -- low 16-bits zero
- 'N' constant for use incrementing or decrementing an address register
- 'O' constant for use with and'ing only high 16-bit
- 'P' constant for use with and'ing only low 16-bit
- */
-
-#define SMALL_INT(X) (SMALL_INTVAL (INTVAL (X)))
-#define SMALL_INTVAL(I) ((unsigned) (I) < 0x10000)
-#define SHORT_IMMEDIATE(X) (SHORT_INTVAL (INTVAL(X)))
-#define SHORT_INTVAL(I) ((unsigned) (I) < 0x100)
-#define ADD_LOW_16(I) ((I) >= 0 && (I) <= 32767)
-#define ADD_HIGH_16(I) (((I) & 0x0000ffff) == 0)
-#define AND_LOW_16(I) ((I) >= 0 && (I) <= 32767)
-#define AND_HIGH_16(I) (((I) & 0x0000ffff) == 0)
-
-#define CONST_OK_FOR_LETTER_P(VALUE, C) \
- ((C) == 'I' ? (SMALL_INTVAL(VALUE)) \
- : (C) == 'J' ? (SHORT_INTVAL(VALUE)) \
- : (C) == 'K' ? ((VALUE) == 0) \
- : (C) == 'L' ? ((VALUE) >= 0 && (VALUE) <= 32767) \
- : (C) == 'M' ? (((VALUE) & 0x0000ffff) == 0) \
- : (C) == 'N' ? ((VALUE) == -1 || (VALUE) == 1 \
- || (VALUE) == -2 || (VALUE) == 2) \
- : (C) == 'O' ? (((VALUE) & 0xffff0000) == 0xffff0000) \
- : (C) == 'P' ? (((VALUE) & 0x0000ffff) == 0xffff) \
- : 0)
-
-#define CONST_DOUBLE_OK_FOR_LETTER_P(VALUE, C) 1
-
-/* Optional extra constraints for this machine */
-#define EXTRA_CONSTRAINT(OP,C) \
- ((C) == 'R' ? symbolic_address_p (OP) \
- : 0)
-\f
-/* DESCRIBING STACK LAYOUT AND CALLING CONVENTIONS */
-
-/* Define this if pushing a word on the stack
- makes the stack pointer a smaller address. */
-/* #define STACK_GROWS_DOWNWARD */
-
-/* Define this if the nominal address of the stack frame
- is at the high-address end of the local variables;
- that is, each additional local variable allocated
- goes at a more negative offset in the frame. */
-/* #define FRAME_GROWS_DOWNWARD */
-
-#define ARGS_GROW_DOWNWARD
-
-/* We use post decrement on the 1600 because there isn't
- a pre-decrement addressing mode. This means that we
- assume the stack pointer always points at the next
- FREE location on the stack. */
-#define STACK_PUSH_CODE POST_INC
-
-/* Offset within stack frame to start allocating local variables at.
- If FRAME_GROWS_DOWNWARD, this is the offset to the END of the
- first local allocated. Otherwise, it is the offset to the BEGINNING
- of the first local allocated. */
-#define STARTING_FRAME_OFFSET 0
-
-/* Offset from the stack pointer register to the first
- location at which outgoing arguments are placed. */
-#define STACK_POINTER_OFFSET (0)
-
-struct dsp16xx_frame_info
-{
- unsigned long total_size; /* # bytes that the entire frame takes up */
- unsigned long var_size; /* # bytes that variables take up */
- unsigned long args_size; /* # bytes that outgoing arguments take up */
- unsigned long extra_size; /* # bytes of extra gunk */
- unsigned int reg_size; /* # bytes needed to store regs */
- long fp_save_offset; /* offset from vfp to store registers */
- unsigned long sp_save_offset; /* offset from new sp to store registers */
- int pr_save_offset; /* offset to saved PR */
- int initialized; /* != 0 if frame size already calculated */
- int num_regs; /* number of registers saved */
- int function_makes_calls; /* Does the function make calls */
-};
-
-extern struct dsp16xx_frame_info current_frame_info;
-
-#define RETURN_ADDR_OFF current_frame_info.pr_save_offset
-
-/* If we generate an insn to push BYTES bytes,
- this says how many the stack pointer really advances by. */
-/* #define PUSH_ROUNDING(BYTES) ((BYTES)) */
-
-/* If defined, the maximum amount of space required for outgoing
- arguments will be computed and placed into the variable
- 'current_function_outgoing_args_size'. No space will be pushed
- onto the stack for each call; instead, the function prologue should
- increase the stack frame size by this amount.
-
- It is not proper to define both 'PUSH_ROUNDING' and
- 'ACCUMULATE_OUTGOING_ARGS'. */
-#define ACCUMULATE_OUTGOING_ARGS 1
-
-/* Offset of first parameter from the argument pointer
- register value. */
-
-#define FIRST_PARM_OFFSET(FNDECL) (0)
-
-/* Value is 1 if returning from a function call automatically
- pops the arguments described by the number-of-args field in the call.
- FUNDECL is the declaration node of the function (as a tree),
- FUNTYPE is the data type of the function (as a tree),
- or for a library call it is an identifier node for the subroutine name. */
-
-#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0
-
-/* Define how to find the value returned by a function.
- VALTYPE is the data type of the value (as a tree).
- If the precise function being called is known, FUNC is its FUNCTION_DECL;
- otherwise, FUNC is 0. On the 1610 all function return their values
- in a0 (i.e. the upper 16 bits). If the return value is 32-bits the
- entire register is significant. */
-
-#define VALUE_REGNO(MODE) (REG_Y)
-
-#define FUNCTION_VALUE(VALTYPE, FUNC) \
- gen_rtx_REG (TYPE_MODE (VALTYPE), VALUE_REGNO(TYPE_MODE(VALTYPE)))
-
-/* Define how to find the value returned by a library function
- assuming the value has mode MODE. */
-#define LIBCALL_VALUE(MODE) gen_rtx_REG (MODE, VALUE_REGNO(MODE))
-
-/* 1 if N is a possible register number for a function value. */
-#define FUNCTION_VALUE_REGNO_P(N) ((N) == REG_Y)
-\f
-
-/* Define where to put the arguments to a function.
- Value is zero to push the argument on the stack,
- or a hard register in which to store the argument.
-
- MODE is the argument's machine mode.
- TYPE is the data type of the argument (as a tree).
- This is null for libcalls where that information may
- not be available.
- CUM is a variable of type CUMULATIVE_ARGS which gives info about
- the preceding args and about the function being called.
- NAMED is nonzero if this argument is a named parameter
- (otherwise it is an extra parameter matching an ellipsis). */
-
-/* On the 1610 all args are pushed, except if -mregparm is specified
- then the first two words of arguments are passed in a0, a1. */
-#define FUNCTION_ARG(CUM, MODE, TYPE, NAMED) \
- dsp16xx_function_arg (CUM, MODE, TYPE, NAMED)
-
-/* Define the first register to be used for argument passing */
-#define FIRST_REG_FOR_FUNCTION_ARG REG_Y
-
-/* Define the profitability of saving registers around calls.
- NOTE: For now we turn this off because of a bug in the
- caller-saves code and also because i'm not sure it is helpful
- on the 1610. */
-
-#define CALLER_SAVE_PROFITABLE(REFS,CALLS) 0
-
-/* This indicates that an argument is to be passed with an invisible reference
- (i.e., a pointer to the object is passed).
-
- On the dsp16xx, we do this if it must be passed on the stack. */
-
-#define FUNCTION_ARG_PASS_BY_REFERENCE(CUM, MODE, TYPE, NAMED) \
- (MUST_PASS_IN_STACK (MODE, TYPE))
-
-/* For an arg passed partly in registers and partly in memory,
- this is the number of registers used.
- For args passed entirely in registers or entirely in memory, zero. */
-
-#define FUNCTION_ARG_PARTIAL_NREGS(CUM, MODE, TYPE, NAMED) (0)
-
-/* Define a data type for recording info about an argument list
- during the scan of that argument list. This data type should
- hold all necessary information about the function itself
- and about the args processed so far, enough to enable macros
- such as FUNCTION_ARG to determine where the next arg should go. */
-#define CUMULATIVE_ARGS int
-
-/* Initialize a variable CUM of type CUMULATIVE_ARGS
- for a call to a function whose data type is FNTYPE.
- For a library call, FNTYPE is 0. */
-#define INIT_CUMULATIVE_ARGS(CUM, FNTYPE, LIBNAME, INDIRECT, N_NAMED_ARGS) \
- ((CUM) = 0)
-
-/* Update the data in CUM to advance over an argument
- of mode MODE and data type TYPE.
- (TYPE is null for libcalls where that information may not be available.) */
-
-#define FUNCTION_ARG_ADVANCE(CUM, MODE, TYPE, NAMED) \
- dsp16xx_function_arg_advance (&CUM, MODE,TYPE, NAMED)
-
-/* 1 if N is a possible register number for function argument passing. */
-#define FUNCTION_ARG_REGNO_P(N) \
- ((N) == REG_Y || (N) == REG_YL || (N) == REG_PROD || (N) == REG_PRODL)
-
-/* Output assembler code to FILE to increment profiler label # LABELNO
- for profiling a function entry. */
-
-#define FUNCTION_PROFILER(FILE, LABELNO) \
- internal_error ("profiling not implemented yet")
-
-/* EXIT_IGNORE_STACK should be nonzero if, when returning from a function,
- the stack pointer does not matter. The value is tested only in
- functions that have frame pointers.
- No definition is equivalent to always zero. */
-
-#define EXIT_IGNORE_STACK (0)
-
-#define TRAMPOLINE_TEMPLATE(FILE) \
- internal_error ("trampolines not yet implemented");
-
-/* Length in units of the trampoline for entering a nested function.
- This is a dummy value */
-
-#define TRAMPOLINE_SIZE 20
-
-/* Emit RTL insns to initialize the variable parts of a trampoline.
- FNADDR is an RTX for the address of the function's pure code.
- CXT is an RTX for the static chain value for the function. */
-
-#define INITIALIZE_TRAMPOLINE(TRAMP, FNADDR, CXT) \
- internal_error ("trampolines not yet implemented");
-
-/* A C expression which is nonzero if a function must have and use a
- frame pointer. If its value is nonzero the functions will have a
- frame pointer. */
-#define FRAME_POINTER_REQUIRED (current_function_calls_alloca)
-
-/* A C statement to store in the variable 'DEPTH' the difference
- between the frame pointer and the stack pointer values immediately
- after the function prologue. */
-#define INITIAL_FRAME_POINTER_OFFSET(DEPTH) \
-{ (DEPTH) = initial_frame_pointer_offset(); \
-}
-\f
-/* IMPLICIT CALLS TO LIBRARY ROUTINES */
-
-#define ADDHF3_LIBCALL "__Emulate_addhf3"
-#define SUBHF3_LIBCALL "__Emulate_subhf3"
-#define MULHF3_LIBCALL "__Emulate_mulhf3"
-#define DIVHF3_LIBCALL "__Emulate_divhf3"
-#define CMPHF3_LIBCALL "__Emulate_cmphf3"
-#define FIXHFHI2_LIBCALL "__Emulate_fixhfhi2"
-#define FLOATHIHF2_LIBCALL "__Emulate_floathihf2"
-#define NEGHF2_LIBCALL "__Emulate_neghf2"
-
-#define UMULHI3_LIBCALL "__Emulate_umulhi3"
-#define MULHI3_LIBCALL "__Emulate_mulhi3"
-#define UDIVQI3_LIBCALL "__Emulate_udivqi3"
-#define UDIVHI3_LIBCALL "__Emulate_udivhi3"
-#define DIVQI3_LIBCALL "__Emulate_divqi3"
-#define DIVHI3_LIBCALL "__Emulate_divhi3"
-#define MODQI3_LIBCALL "__Emulate_modqi3"
-#define MODHI3_LIBCALL "__Emulate_modhi3"
-#define UMODQI3_LIBCALL "__Emulate_umodqi3"
-#define UMODHI3_LIBCALL "__Emulate_umodhi3"
-#define ASHRHI3_LIBCALL "__Emulate_ashrhi3"
-#define LSHRHI3_LIBCALL "__Emulate_lshrhi3"
-#define ASHLHI3_LIBCALL "__Emulate_ashlhi3"
-#define LSHLHI3_LIBCALL "__Emulate_lshlhi3" /* NOT USED */
-
-/* Define this macro if calls to the ANSI C library functions memcpy and
- memset should be generated instead of the BSD function bcopy & bzero. */
-#define TARGET_MEM_FUNCTIONS
-
-\f
-/* ADDRESSING MODES */
-
-/* The 1610 has post-increment and decrement, but no pre-modify */
-#define HAVE_POST_INCREMENT 1
-#define HAVE_POST_DECREMENT 1
-
-/* Recognize any constant value that is a valid address. */
-#define CONSTANT_ADDRESS_P(X) CONSTANT_P (X)
-
-/* Maximum number of registers that can appear in a valid memory address. */
-#define MAX_REGS_PER_ADDRESS 1
-
-/* The macros REG_OK_FOR..._P assume that the arg is a REG rtx
- and check its validity for a certain class.
- We have two alternate definitions for each of them.
- The usual definition accepts all pseudo regs; the other rejects
- them unless they have been allocated suitable hard regs.
- The symbol REG_OK_STRICT causes the latter definition to be used.
-
- Most source files want to accept pseudo regs in the hope that
- they will get allocated to the class that the insn wants them to be in.
- Source files for reload pass need to be strict.
- After reload, it makes no difference, since pseudo regs have
- been eliminated by then. */
-
-#ifndef REG_OK_STRICT
-
-/* Nonzero if X is a hard reg that can be used as an index
- or if it is a pseudo reg. */
-#define REG_OK_FOR_INDEX_P(X) 0
-
-/* Nonzero if X is a hard reg that can be used as a base reg
- or if it is a pseudo reg. */
-#define REG_OK_FOR_BASE_P(X) \
- ((REGNO (X) >= REG_R0 && REGNO (X) < REG_R3 + 1 ) \
- || (REGNO (X) >= FIRST_PSEUDO_REGISTER))
-
-/* Nonzero if X is the 'ybase' register */
-#define REG_OK_FOR_YBASE_P(X) \
- (REGNO(X) == REG_YBASE || (REGNO (X) >= FIRST_PSEUDO_REGISTER))
-#else
-
-/* Nonzero if X is a hard reg that can be used as an index. */
-#define REG_OK_FOR_INDEX_P(X) REGNO_OK_FOR_INDEX_P (REGNO (X))
-
-/* Nonzero if X is a hard reg that can be used as a base reg. */
-#define REG_OK_FOR_BASE_P(X) REGNO_OK_FOR_BASE_P (REGNO (X))
-
-/* Nonzero if X is the 'ybase' register */
-#define REG_OK_FOR_YBASE_P(X) REGNO_OK_FOR_YBASE_P (REGNO(X))
-
-#endif
-\f
-/* GO_IF_LEGITIMATE_ADDRESS recognizes an RTL expression
- that is a valid memory address for an instruction.
- The MODE argument is the machine mode for the MEM expression
- that wants to use this address.
-
- On the 1610, the actual legitimate addresses must be N (N must fit in
- 5 bits), *rn (register indirect), *rn++, or *rn-- */
-
-#define INT_FITS_5_BITS(I) ((unsigned long) (I) < 0x20)
-#define INT_FITS_16_BITS(I) ((unsigned long) (I) < 0x10000)
-#define YBASE_CONST_OFFSET(I) ((I) >= -31 && (I) <= 0)
-#define YBASE_OFFSET(X) (GET_CODE (X) == CONST_INT && YBASE_CONST_OFFSET (INTVAL(X)))
-
-#define FITS_16_BITS(X) (GET_CODE (X) == CONST_INT && INT_FITS_16_BITS(INTVAL(X)))
-#define FITS_5_BITS(X) (GET_CODE (X) == CONST_INT && INT_FITS_5_BITS(INTVAL(X)))
-#define ILLEGAL_HIMODE_ADDR(MODE, CONST) ((MODE) == HImode && CONST == -31)
-
-#define INDIRECTABLE_ADDRESS_P(X) \
- ((GET_CODE(X) == REG && REG_OK_FOR_BASE_P(X)) \
- || ((GET_CODE(X) == POST_DEC || GET_CODE(X) == POST_INC) \
- && REG_P(XEXP(X,0)) && REG_OK_FOR_BASE_P(XEXP(X,0))) \
- || (GET_CODE(X) == CONST_INT && (unsigned long) (X) < 0x20))
-
-
-#define INDEXABLE_ADDRESS_P(X,MODE) \
- ((GET_CODE(X) == PLUS && GET_CODE (XEXP (X,0)) == REG && \
- XEXP(X,0) == stack_pointer_rtx && YBASE_OFFSET(XEXP(X,1)) && \
- !ILLEGAL_HIMODE_ADDR(MODE, INTVAL(XEXP(X,1)))) || \
- (GET_CODE(X) == PLUS && GET_CODE (XEXP (X,1)) == REG && \
- XEXP(X,1) == stack_pointer_rtx && YBASE_OFFSET(XEXP(X,0)) && \
- !ILLEGAL_HIMODE_ADDR(MODE, INTVAL(XEXP(X,0)))))
-
-#define GO_IF_LEGITIMATE_ADDRESS(MODE, X, ADDR) \
-{ \
- if (INDIRECTABLE_ADDRESS_P(X)) \
- goto ADDR; \
-}
-
-\f
-/* Try machine-dependent ways of modifying an illegitimate address
- to be legitimate. If we find one, return the new, valid address.
- This macro is used in only one place: `memory_address' in explow.c.
-
- OLDX is the address as it was before break_out_memory_refs was called.
- In some cases it is useful to look at this to decide what needs to be done.
-
- MODE and WIN are passed so that this macro can use
- GO_IF_LEGITIMATE_ADDRESS.
-
- It is always safe for this macro to do nothing. It exists to recognize
- opportunities to optimize the output.
-
- For the 1610, we need not do anything. However, if we don't,
- `memory_address' will try lots of things to get a valid address, most of
- which will result in dead code and extra pseudos. So we make the address
- valid here.
-
- This is easy: The only valid addresses are an offset from a register
- and we know the address isn't valid. So just call either `force_operand'
- or `force_reg' unless this is a (plus (reg ...) (const_int 0)). */
-
-#define LEGITIMIZE_ADDRESS(X,OLDX,MODE,WIN) \
-{ if (GET_CODE (X) == PLUS && XEXP (X, 1) == const0_rtx) \
- X = XEXP (x, 0); \
- if (GET_CODE (X) == MULT || GET_CODE (X) == PLUS) \
- X = force_operand (X, 0); \
- else \
- X = force_reg (Pmode, X); \
- goto WIN; \
-}
-
-/* Go to LABEL if ADDR (a legitimate address expression)
- has an effect that depends on the machine mode it is used for.
- On the 1610, only postdecrement and postincrement address depend thus
- (the amount of decrement or increment being the length of the operand). */
-
-#define GO_IF_MODE_DEPENDENT_ADDRESS(ADDR,LABEL) \
- if (GET_CODE (ADDR) == POST_INC || GET_CODE (ADDR) == POST_DEC) goto LABEL
-
-/* Nonzero if the constant value X is a legitimate general operand.
- It is given that X satisfies CONSTANT_P or is a CONST_DOUBLE. */
-#define LEGITIMATE_CONSTANT_P(X) (1)
-
-\f
-/* CONDITION CODE INFORMATION */
-
-/* Store in cc_status the expressions
- that the condition codes will describe
- after execution of an instruction whose pattern is EXP.
- Do not alter them if the instruction would not alter the cc's. */
-
-#define NOTICE_UPDATE_CC(EXP, INSN) \
- notice_update_cc( (EXP) )
-\f
-/* DESCRIBING RELATIVE COSTS OF OPERATIONS */
-
-/* A c expression for the cost of moving data from a register in
- class FROM to one in class TO. The classes are expressed using
- the enumeration values such as GENERAL_REGS. A value of 2 is
- the default. */
-#define REGISTER_MOVE_COST(MODE,FROM,TO) dsp16xx_register_move_cost (FROM, TO)
-
-/* A C expression for the cost of moving data of mode MODE between
- a register and memory. A value of 2 is the default. */
-#define MEMORY_MOVE_COST(MODE,CLASS,IN) \
- (GET_MODE_CLASS(MODE) == MODE_INT && MODE == QImode ? 12 \
- : 16)
-
-/* A C expression for the cost of a branch instruction. A value of
- 1 is the default; */
-#define BRANCH_COST 1
-\f
-
-/* Define this because otherwise gcc will try to put the function address
- in any old pseudo register. We can only use pt. */
-#define NO_FUNCTION_CSE
-
-/* Define this macro as a C expression which is nonzero if accessing less
- than a word of memory (i.e a char or short) is no faster than accessing
- a word of memory, i.e if such access require more than one instruction
- or if there is no difference in cost between byte and (aligned) word
- loads. */
-#define SLOW_BYTE_ACCESS 1
-
-/* Define this macro if unaligned accesses have a cost many times greater than
- aligned accesses, for example if they are emulated in a trap handler */
-/* define SLOW_UNALIGNED_ACCESS(MODE, ALIGN) */
-
-\f
-/* DIVIDING THE OUTPUT IN SECTIONS */
-/* Output before read-only data. */
-
-#define DEFAULT_TEXT_SEG_NAME ".text"
-#define TEXT_SECTION_ASM_OP rsect_text
-
-/* Output before constants and strings */
-#define DEFAULT_CONST_SEG_NAME ".const"
-#define READONLY_DATA_SECTION_ASM_OP rsect_const
-
-/* Output before writable data. */
-#define DEFAULT_DATA_SEG_NAME ".data"
-#define DATA_SECTION_ASM_OP rsect_data
-
-#define DEFAULT_BSS_SEG_NAME ".bss"
-#define BSS_SECTION_ASM_OP rsect_bss
-
-/* We will default to using 1610 if the user doesn't
- specify it. */
-#define DEFAULT_CHIP_NAME "1610"
-\f
-/* THE OVERALL FRAMEWORK OF AN ASSEMBLER FILE */
-
-/* A C string constant describing how to begin a comment in the target
- assembler language. */
-#define ASM_COMMENT_START ""
-#define ASM_COMMENT_END ""
-
-/* Output to assembler file text saying following lines
- may contain character constants, extra white space, comments, etc. */
-#define ASM_APP_ON ""
-
-/* Output to assembler file text saying following lines
- no longer contain unusual constructs. */
-#define ASM_APP_OFF ""
-\f
-/* OUTPUT OF DATA */
-
-/* This is how we output a 'c' character string. For the 16xx
- assembler we have to do it one letter at a time */
-
-#define ASCII_LENGTH 10
-
-#define ASM_OUTPUT_ASCII(MYFILE, MYSTRING, MYLENGTH) \
- do { \
- FILE *_hide_asm_out_file = (MYFILE); \
- const unsigned char *_hide_p = (const unsigned char *) (MYSTRING); \
- int _hide_thissize = (MYLENGTH); \
- { \
- FILE *asm_out_file = _hide_asm_out_file; \
- const unsigned char *p = _hide_p; \
- int thissize = _hide_thissize; \
- int i; \
- \
- for (i = 0; i < thissize; i++) \
- { \
- register int c = p[i]; \
- \
- if (i % ASCII_LENGTH == 0) \
- fprintf (asm_out_file, "\tint "); \
- \
- if (c >= ' ' && c < 0177 && c != '\'') \
- { \
- putc ('\'', asm_out_file); \
- putc (c, asm_out_file); \
- putc ('\'', asm_out_file); \
- } \
- else \
- { \
- fprintf (asm_out_file, "%d", c); \
- /* After an octal-escape, if a digit follows, \
- terminate one string constant and start another. \
- The VAX assembler fails to stop reading the escape \
- after three digits, so this is the only way we \
- can get it to parse the data properly. \
- if (i < thissize - 1 && ISDIGIT (p[i + 1])) \
- fprintf (asm_out_file, "\'\n\tint \'"); \
- */ \
- } \
- /* if: \
- we are not at the last char (i != thissize -1) \
- and (we are not at a line break multiple \
- but i == 0) (it will be the very first time) \
- then put out a comma to extend. \
- */ \
- if ((i != thissize - 1) && ((i + 1) % ASCII_LENGTH)) \
- fprintf(asm_out_file, ","); \
- if (!((i + 1) % ASCII_LENGTH)) \
- fprintf (asm_out_file, "\n"); \
- } \
- fprintf (asm_out_file, "\n"); \
- } \
- } \
- while (0)
-
-#define ASM_PN_FORMAT "*L%s_%lu"
-\f
-/* OUTPUT OF UNINITIALIZED VARIABLES */
-
-/* This says how to output an assembler line
- to define a global common symbol. */
-
-#define ASM_OUTPUT_COMMON(FILE, NAME, SIZE, ROUNDED) \
- asm_output_common (FILE, NAME, SIZE, ROUNDED);
-
-/* This says how to output an assembler line
- to define a local common symbol. */
-
-#define ASM_OUTPUT_LOCAL(FILE, NAME, SIZE, ROUNDED) \
- asm_output_local (FILE, NAME, SIZE, ROUNDED);
-\f
-/* OUTPUT AND GENERATION OF LABELS */
-
-/* Globalizing directive for a label. */
-#define GLOBAL_ASM_OP ".global "
-
-/* A C statement to output to the stdio stream any text necessary
- for declaring the name of an external symbol named name which
- is referenced in this compilation but not defined. */
-
-#define ASM_OUTPUT_EXTERNAL(FILE, DECL, NAME) \
-{ \
- fprintf (FILE, ".extern "); \
- assemble_name (FILE, NAME); \
- fprintf (FILE, "\n"); \
-}
-/* A C statement to output on stream an assembler pseudo-op to
- declare a library function named external. */
-
-#define ASM_OUTPUT_EXTERNAL_LIBCALL(FILE, FUN) \
-{ \
- fprintf (FILE, ".extern "); \
- assemble_name (FILE, XSTR (FUN, 0)); \
- fprintf (FILE, "\n"); \
-}
-
-/* The prefix to add to user-visible assembler symbols. */
-
-#define USER_LABEL_PREFIX "_"
-
-/* This is how to store into the string LABEL
- the symbol_ref name of an internal numbered label where
- PREFIX is the class of label and NUM is the number within the class.
- This is suitable for output with `assemble_name'. */
-#define ASM_GENERATE_INTERNAL_LABEL(LABEL,PREFIX,NUM) \
- sprintf (LABEL, "*%s%lu", PREFIX, (unsigned long)(NUM))
-
-\f
-/* OUTPUT OF ASSEMBLER INSTRUCTIONS */
-
-/* How to refer to registers in assembler output.
- This sequence is indexed by compiler's hard-register-number (see above). */
-
-#define REGISTER_NAMES \
-{"a0", "a0l", "a1", "a1l", "x", "y", "yl", "p", "pl", \
- "r0", "r1", "r2", "r3", "j", "k", "ybase", "pt", \
- "ar0", "ar1", "ar2", "ar3", \
- "c0", "c1", "c2", "pr", "rb", \
- "*(0)", "*(1)", "*(2)", "*(3)", "*(4)", "*(5)", \
- "*(6)", "*(7)", "*(8)", "*(9)", "*(10)", "*(11)", \
- "*(12)", "*(13)", "*(14)", "*(15)", "*(16)", "*(17)", \
- "*(18)", "*(19)", "*(20)", "*(21)", "*(22)", "*(23)", \
- "*(24)", "*(25)", "*(26)", "*(27)", "*(28)", "*(29)", \
- "*(30)", "*(31)" }
-
-#define HIMODE_REGISTER_NAMES \
-{"a0", "a0", "a1", "a1", "x", "y", "y", "p", "p", \
- "r0", "r1", "r2", "r3", "j", "k", "ybase", "pt", \
- "ar0", "ar1", "ar2", "ar3", \
- "c0", "c1", "c2", "pr", "rb", \
- "*(0)", "*(1)", "*(2)", "*(3)", "*(4)", "*(5)", \
- "*(6)", "*(7)", "*(8)", "*(9)", "*(10)", "*(11)", \
- "*(12)", "*(13)", "*(14)", "*(15)", "*(16)", "*(17)", \
- "*(18)", "*(19)", "*(20)", "*(21)", "*(22)", "*(23)", \
- "*(24)", "*(25)", "*(26)", "*(27)", "*(28)", "*(29)", \
- "*(30)", "*(31)" }
-
-#define PRINT_OPERAND_PUNCT_VALID_P(CODE) 0
-
-/* Print operand X (an rtx) in assembler syntax to file FILE.
- CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified.
- For `%' followed by punctuation, CODE is the punctuation and X is null.
-
- DSP1610 extensions for operand codes:
-
- %H - print lower 16 bits of constant
- %U - print upper 16 bits of constant
- %w - print low half of register (e.g 'a0l')
- %u - print upper half of register (e.g 'a0')
- %b - print high half of accumulator for F3 ALU instructions
- %h - print constant in decimal */
-
-#define PRINT_OPERAND(FILE, X, CODE) print_operand(FILE, X, CODE)
-
-
-/* Print a memory address as an operand to reference that memory location. */
-
-#define PRINT_OPERAND_ADDRESS(FILE, ADDR) print_operand_address (FILE, ADDR)
-
-/* This is how to output an insn to push a register on the stack.
- It need not be very fast code since it is used only for profiling */
-#define ASM_OUTPUT_REG_PUSH(FILE,REGNO) \
- internal_error ("profiling not implemented yet");
-
-/* This is how to output an insn to pop a register from the stack.
- It need not be very fast code since it is used only for profiling */
-#define ASM_OUTPUT_REG_POP(FILE,REGNO) \
- internal_error ("profiling not implemented yet");
-\f
-/* OUTPUT OF DISPATCH TABLES */
-
-/* This macro should be provided on machines where the addresses in a dispatch
- table are relative to the table's own address. */
-#define ASM_OUTPUT_ADDR_DIFF_ELT(FILE, BODY, VALUE, REL) \
- fprintf (FILE, "\tint L%d-L%d\n", VALUE, REL)
-
-/* This macro should be provided on machines where the addresses in a dispatch
- table are absolute. */
-#define ASM_OUTPUT_ADDR_VEC_ELT(FILE, VALUE) \
- fprintf (FILE, "\tint L%d\n", VALUE)
-
-/* ASSEMBLER COMMANDS FOR ALIGNMENT */
-
-/* This is how to output an assembler line that says to advance
- the location counter to a multiple of 2**LOG bytes. We should
- not have to do any alignment since the 1610 is a word machine. */
-#define ASM_OUTPUT_ALIGN(FILE,LOG)
-
-/* Define this macro if ASM_OUTPUT_SKIP should not be used in the text section
- because it fails to put zero1 in the bytes that are skipped. */
-#define ASM_NO_SKIP_IN_TEXT 1
-
-#define ASM_OUTPUT_SKIP(FILE,SIZE) \
- fprintf (FILE, "\t%d * int 0\n", (int)(SIZE))
-
-/* CONTROLLING DEBUGGING INFORMATION FORMAT */
-
-#define PREFERRED_DEBUGGING_TYPE DWARF2_DEBUG
-
-#define ASM_OUTPUT_DEF(asm_out_file, LABEL1, LABEL2) \
- do { \
- fprintf (asm_out_file, ".alias " ); \
- ASM_OUTPUT_LABELREF(asm_out_file, LABEL1); \
- fprintf (asm_out_file, "=" ); \
- ASM_OUTPUT_LABELREF(asm_out_file, LABEL2); \
- fprintf (asm_out_file, "\n" ); \
- } while (0)
-
-\f
-/* MISCELLANEOUS PARAMETERS */
-
-/* Specify the machine mode that this machine uses
- for the index in the tablejump instruction. */
-#define CASE_VECTOR_MODE QImode
-
-/* Define as C expression which evaluates to nonzero if the tablejump
- instruction expects the table to contain offsets from the address of the
- table.
- Do not define this if the table should contain absolute addresses. */
-/* #define CASE_VECTOR_PC_RELATIVE 1 */
-
-/* Max number of bytes we can move from memory to memory
- in one reasonably fast instruction. */
-#define MOVE_MAX 1
-
-/* Defining this macro causes the compiler to omit a sign-extend, zero-extend,
- or bitwise 'and' instruction that truncates the count of a shift operation
- to a width equal to the number of bits needed to represent the size of the
- object being shifted. Do not define this macro unless the truncation applies
- to both shift operations and bit-field operations (if any). */
-/* #define SHIFT_COUNT_TRUNCATED */
-
-/* Value is 1 if truncating an integer of INPREC bits to OUTPREC bits
- is done just by pretending it is already truncated. */
-#define TRULY_NOOP_TRUNCATION(OUTPREC, INPREC) 1
-
-/* When a prototype says `char' or `short', really pass an `int'. */
-#define PROMOTE_PROTOTYPES 1
-
-/* An alias for the machine mode used for pointers */
-#define Pmode QImode
-
-/* A function address in a call instruction
- is a byte address (for indexing purposes)
- so give the MEM rtx a byte's mode. */
-#define FUNCTION_MODE QImode
-
-#if !defined(__DATE__)
-#define TARGET_VERSION fprintf (stderr, " (%s)", VERSION_INFO1)
-#else
-#define TARGET_VERSION fprintf (stderr, " (%s, %s)", VERSION_INFO1, __DATE__)
-#endif
-
-#define VERSION_INFO1 "Lucent DSP16xx C Cross Compiler, version 1.3.0b"
-
-
-/* Define this as 1 if `char' should by default be signed; else as 0. */
-#define DEFAULT_SIGNED_CHAR 1
-
-/* Define this so gcc does not output a call to __main, since we
- are not currently supporting c++. */
-#define INIT_SECTION_ASM_OP 1
-
+++ /dev/null
-;;- Machine description for the AT&T DSP1600 for GCC
-;; Copyright (C) 1994, 1995, 1997, 1998, 2001, 2002
-;; Free Software Foundation, Inc.
-;; Contributed by Michael Collison (collison@isisinc.net).
-
-;; This file is part of GCC.
-
-;; GCC is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GCC is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GCC; see the file COPYING. If not, write to
-;; the Free Software Foundation, 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-
-;;- See file "rtl.def" for documentation on define_insn, match_*, et. al.
-\f
-;; Attribute specifications
-
-; Type of each instruction. Default is arithmetic.
-; I'd like to write the list as this, but genattrtab won't accept it.
-;
-; "jump,cond_jump,call, ; flow-control instructions
-; load_i,load, store, move ; Y space address arithmetic instructions
-; malu,special,f3_alu,f3_alu_i ; data arithmetic unit instructions
-; shift_i,shift, bfield_i, bfield ; bit manipulation unit instructions
-; arith, ; integer unit instructions
-; nop
-
-; Classification of each insn. Some insns of TYPE_BRANCH are multi-word.
-(define_attr "type"
- "jump,cond_jump,call,load_i,load,move,store,malu,malu_mul,tstqi,special,special_2,f3_alu,f3_alu_i,f3_alu_i_mult,shift_i,shift,shift_multiple,shift_i_multiple,bfield_i,bfield,nop,ld_short_i,data_move,data_move_i,data_move_memory,data_move_memory_2,data_move_short_i,data_move_multiple,data_move_2,nothing"
- (const_string "malu"))
-
-;; Data arithmetic unit
-(define_function_unit "dau" 1 1 (eq_attr "type" "data_move,data_move_i,f3_alu_i") 2 0)
-
-(define_function_unit "dau" 1 1 (eq_attr "type" "special_2") 3 0)
-
-(define_function_unit "dau" 1 1 (eq_attr "type" "data_move_2") 4 0)
-
-;; Bit manipulation
-(define_function_unit "bmu" 1 1 (eq_attr "type" "shift_i,shift_i_multiple") 2 0)
-
-(define_function_unit "bmu" 1 1 (eq_attr "type" "shift_multiple") 4 0)
-
-;; Y-memory addressing arithmetic unit
-(define_function_unit "yaau" 1 1 (eq_attr "type" "data_move_memory") 2 0)
-
-(define_function_unit "yaau" 1 1 (eq_attr "type" "data_move_memory_2") 4 0)
-
-\f
-;; ....................
-;;
-;; Test against 0 instructions
-;;
-;; ....................
-
-(define_expand "tsthi"
- [(set (cc0)
- (match_operand:HI 0 "register_operand" ""))]
- ""
- "
-{
- dsp16xx_compare_gen = false;
- dsp16xx_compare_op0 = operands[0];
- dsp16xx_compare_op1 = const0_rtx;
- DONE;
-}")
-
-(define_insn "tsthi_1"
- [(set (cc0)
- (match_operand:HI 0 "register_operand" "A"))]
- ""
- "%0=%0"
- [(set_attr "type" "malu")])
-
-(define_expand "tstqi"
- [(set (cc0)
- (match_operand:QI 0 "register_operand" ""))]
- ""
- "
-{
- dsp16xx_compare_gen = false;
- dsp16xx_compare_op0 = operands[0];
- dsp16xx_compare_op1 = const0_rtx;
- DONE;
-}")
-
-(define_split
- [(set (cc0)
- (match_operand:QI 0 "register_operand" "j,q"))
- (clobber (match_scratch:QI 1 "=k,u"))]
- "reload_completed"
- [(set (match_dup 1)
- (const_int 0))
- (parallel [(set (cc0)
- (match_dup 0))
- (use (match_dup 1))])]
- "")
-
-(define_insn "tstqi_split"
- [(set (cc0)
- (match_operand:QI 0 "register_operand" "j,q"))
- (use (match_scratch:QI 1 "=k,u"))]
- ""
- "@
- %b0-0
- %b0-0"
- [(set_attr "type" "f3_alu_i,f3_alu_i")])
-
-(define_insn "tstqi_1"
- [(set (cc0)
- (match_operand:QI 0 "register_operand" "j,q"))
- (clobber (match_scratch:QI 1 "=k,u"))]
- ""
- "@
- %1=0\;%b0-0
- %1=0\;%b0-0"
- [(set_attr "type" "tstqi,tstqi")])
-
-\f
-;;
-;; ....................
-;;
-;; Bit test instructions
-;;
-;; ....................
-
-(define_insn ""
- [(set (cc0)
- (and:HI (match_operand:HI 0 "register_operand" "A,!A")
- (match_operand:HI 1 "register_operand" "Z,A")))]
- ""
- "*
-{
- switch (which_alternative)
- {
- case 0:
- case 1:
- return \"%0&%1\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "f3_alu,f3_alu")])
-
-
-;;(define_insn ""
-;; [(set (cc0)
-;; (and:QI (match_operand:QI 0 "register_operand" "h")
-;; (match_operand:QI 1 "const_int_operand" "I")))]
-;; ""
-;; "%b0&%H1"
-;; [(set_attr "type" "f3_alu_i")])
-\f
-;;
-;;
-;; Compare Instructions
-;;
-
-(define_expand "cmphi"
- [(parallel [(set (cc0)
- (compare (match_operand:HI 0 "general_operand" "")
- (match_operand:HI 1 "general_operand" "")))
- (clobber (match_scratch:QI 2 ""))
- (clobber (match_scratch:QI 3 ""))
- (clobber (match_scratch:QI 4 ""))
- (clobber (match_scratch:QI 5 ""))])]
- ""
- "
-{
- if (GET_CODE (operands[1]) == CONST_INT)
- operands[1] = force_reg (HImode, operands[1]);
-
- dsp16xx_compare_gen = true;
- dsp16xx_compare_op0 = operands[0];
- dsp16xx_compare_op1 = operands[1];
- DONE;
-}")
-
-(define_insn ""
- [(set (cc0)
- (compare (match_operand:HI 0 "general_operand" "Z*r*m*i")
- (match_operand:HI 1 "general_operand" "Z*r*m*i")))
- (clobber (match_scratch:QI 2 "=&A"))
- (clobber (match_scratch:QI 3 "=&A"))
- (clobber (match_scratch:QI 4 "=&A"))
- (clobber (match_scratch:QI 5 "=&A"))]
- "next_cc_user_unsigned (insn)"
- "*
-{
- if (GET_CODE(operands[0]) == REG)
- {
- if (REGNO (operands[0]) == REG_Y ||
- REGNO (operands[0]) == REG_PROD)
- {
- output_asm_insn (\"a0=%0\", operands);
- }
- else if (IS_YBASE_REGISTER_WINDOW (REGNO (operands[0])))
- output_asm_insn (\"a0=%u0\;a0l=%w0\", operands);
- else
- fatal_error (\"Invalid register for compare\");
- }
- else if (GET_CODE(operands[0]) == CONST_INT)
- output_asm_insn (\"a0=%U0\;a0l=%H0\", operands);
- else if (GET_CODE (operands[0]) == MEM)
- {
- rtx xoperands[2];
-
- xoperands[0] = gen_rtx_REG (HImode, REG_A0);
- xoperands[1] = operands[0];
- double_reg_from_memory (xoperands);
- }
-
- if (GET_CODE(operands[1]) == REG)
- {
- if (REGNO (operands[1]) == REG_Y || REGNO (operands[1]) == REG_PROD)
- output_asm_insn (\"a1=%1\", operands);
- else if (IS_YBASE_REGISTER_WINDOW (REGNO (operands[1])))
- output_asm_insn (\"a1=%u1\;a1l=%w1\", operands);
- else
- fatal_error (\"Invalid register for compare\");
- }
- else if (GET_CODE (operands[1]) == MEM)
- {
- rtx xoperands[2];
-
- xoperands[0] = gen_rtx_REG (HImode, REG_A1);
- xoperands[1] = operands[1];
- double_reg_from_memory (xoperands);
- }
- else if (GET_CODE(operands[1]) == CONST_INT)
- {
- output_asm_insn (\"a1=%U1\;a1l=%H1\", operands);
- }
-
- return \"psw = 0\;a0 - a1\";
-}")
-
-(define_insn ""
- [(set (cc0) (compare (match_operand:HI 0 "register_operand" "A,!A")
- (match_operand:HI 1 "register_operand" "Z,*A")))]
- ""
- "@
- %0-%1
- %0-%1"
- [(set_attr "type" "malu,f3_alu")])
-
-(define_expand "cmpqi"
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "")
- (match_operand:QI 1 "nonmemory_operand" "")))
- (clobber (match_operand:QI 2 "register_operand" ""))
- (clobber (match_operand:QI 3 "register_operand" ""))])]
- ""
- "
- {
- if (operands[0]) /* Avoid unused code warning */
- {
- dsp16xx_compare_gen = true;
- dsp16xx_compare_op0 = operands[0];
- dsp16xx_compare_op1 = operands[1];
- DONE;
- }
- }")
-
-(define_split
- [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "")
- (match_operand:QI 1 "register_operand" "")))
- (clobber (match_scratch:QI 2 ""))
- (clobber (match_scratch:QI 3 ""))]
- "reload_completed && next_cc_user_unsigned (insn)"
- [(set (match_dup 2)
- (const_int 0))
- (set (match_dup 3)
- (const_int 0))
- (parallel [(set (cc0)
- (compare (match_dup 0)
- (match_dup 1)))
- (use (match_dup 2))
- (use (match_dup 3))])]
- "")
-
-(define_split
- [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "")
- (match_operand:QI 1 "const_int_operand" "")))
- (clobber (match_scratch:QI 2 ""))
- (clobber (match_scratch:QI 3 ""))]
- "reload_completed && next_cc_user_unsigned (insn)"
- [(set (match_dup 2)
- (const_int 0))
- (parallel [(set (cc0)
- (compare (match_dup 0)
- (match_dup 1)))
- (use (match_dup 2))])]
- "")
-
-(define_insn "cmpqi_split_unsigned_reg"
- [(set (cc0) (compare (match_operand:QI 0 "register_operand" "k,k,!k,u,u,!u")
- (match_operand:QI 1 "register_operand" "w,z,u,w,z,k")))
- (use (match_scratch:QI 2 "=j,j,j,q,q,q"))
- (use (match_scratch:QI 3 "=v,y,q,v,y,j"))]
- "next_cc_user_unsigned (insn)"
- "@
- %2-%3
- %2-%3
- %2-%3
- %2-%3
- %2-%3
- %2-%3"
- [(set_attr "type" "malu,malu,malu,malu,malu,malu")])
-
-(define_insn "cmpqi_split_unsigned_int"
- [(set (cc0) (compare (match_operand:QI 0 "register_operand" "k,u")
- (match_operand:QI 1 "const_int_operand" "i,i")))
- (use (match_scratch:QI 2 "=j,q"))]
- "next_cc_user_unsigned (insn)"
- "@
- %0-%H1
- %0-%H1"
- [(set_attr "type" "f3_alu_i,f3_alu_i")])
-
-(define_insn ""
- [(set (cc0) (compare (match_operand:QI 0 "register_operand" "k,k,!k,k,u,u,!u,u")
- (match_operand:QI 1 "nonmemory_operand" "w,z,u,i,w,z,k,i")))
- (clobber (match_scratch:QI 2 "=j,j,j,j,q,q,q,q"))
- (clobber (match_scratch:QI 3 "=v,y,q,X,v,y,j,X"))]
- "next_cc_user_unsigned (insn)"
- "@
- %2=0\;%3=0\;%2-%3
- %2=0\;%3=0\;%2-%3
- %2=0\;%3=0\;%2-%3
- %2=0\;%0-%H1
- %2=0\;%3=0\;%2-%3
- %2=0\;%3=0\;%2-%3
- %2=0\;%3=0\;%2-%3
- %2=0\;%0-%H1")
-
-(define_split
- [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "")
- (match_operand:QI 1 "register_operand" "")))
- (clobber (match_scratch:QI 2 ""))
- (clobber (match_scratch:QI 3 ""))]
- "reload_completed"
- [(set (match_dup 2)
- (const_int 0))
- (set (match_dup 3)
- (const_int 0))
- (parallel [(set (cc0)
- (compare (match_dup 0)
- (match_dup 1)))
- (use (match_dup 2))
- (use (match_dup 3))])]
- "")
-
-(define_split
- [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "")
- (match_operand:QI 1 "const_int_operand" "")))
- (clobber (match_scratch:QI 2 ""))
- (clobber (match_scratch:QI 3 ""))]
- "reload_completed"
- [(set (match_dup 2)
- (const_int 0))
- (parallel [(set (cc0)
- (compare (match_dup 0)
- (match_dup 1)))
- (use (match_dup 2))])]
- "")
-
-(define_insn "cmpqi_split_reg"
- [(set (cc0) (compare (match_operand:QI 0 "register_operand" "j,j,!j,q,q,!q")
- (match_operand:QI 1 "register_operand" "v,y,q,v,y,j")))
- (use (match_scratch:QI 2 "=k,k,k,u,u,u"))
- (use (match_scratch:QI 3 "=w,z,u,w,z,k"))]
- ""
- "@
- %0-%1
- %0-%1
- %0-%1
- %0-%1
- %0-%1
- %0-%1"
- [(set_attr "type" "malu,malu,malu,malu,malu,malu")])
-
-
-(define_insn "cmpqi_split_int"
- [(set (cc0) (compare (match_operand:QI 0 "register_operand" "j,q")
- (match_operand:QI 1 "const_int_operand" "i,i")))
- (use (match_scratch:QI 2 "=k,u"))]
- ""
- "@
- %b0-%H1
- %b0-%H1"
- [(set_attr "type" "f3_alu_i,f3_alu_i")])
-
-(define_insn ""
- [(set (cc0) (compare (match_operand:QI 0 "register_operand" "j,j,!j,j,q,q,!q,q")
- (match_operand:QI 1 "nonmemory_operand" "v,y,q,i,v,y,j,i")))
- (clobber (match_scratch:QI 2 "=k,k,k,k,u,u,u,u"))
- (clobber (match_scratch:QI 3 "=w,z,u,X,w,z,k,X"))]
- ""
- "@
- %2=0\;%3=0\;%0-%1
- %2=0\;%3=0\;%0-%1
- %2=0\;%3=0\;%0-%1
- %2=0\;%b0-%H1
- %2=0\;%3=0\;%0-%1
- %2=0\;%3=0\;%0-%1
- %2=0\;%3=0\;%0-%1
- %2=0\;%b0-%H1")
-
-
-(define_expand "cmphf"
- [(set (cc0)
- (compare (match_operand:HF 0 "register_operand" "")
- (match_operand:HF 1 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_cmphf3_libcall)
- dsp16xx_cmphf3_libcall = gen_rtx_SYMBOL_REF (Pmode, CMPHF3_LIBCALL);
-
- dsp16xx_compare_gen = true;
- dsp16xx_compare_op0 = operands[0];
- dsp16xx_compare_op1 = operands[1];
- emit_library_call (dsp16xx_cmphf3_libcall, 1, HImode, 2,
- operands[0], HFmode,
- operands[1], HFmode);
- emit_insn (gen_tsthi_1 (copy_to_reg(hard_libcall_value (HImode))));
- DONE;
-}")
-
-\f
-;; ....................
-;;
-;; Add instructions
-;;
-;; ....................
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (plus:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !ADD_LOW_16(INTVAL(operands[2])) &&
- !ADD_HIGH_16(INTVAL(operands[2]))"
- [(parallel [(set (match_dup 3)
- (plus:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_dup 6))])
-
- (parallel [(set (match_dup 6)
- (plus:QI (match_dup 7)
- (match_dup 8)))
- (clobber (match_scratch:QI 9 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[6] = gen_highpart(QImode, operands[0]);
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-
-(define_insn "addhi3"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A,A,A")
- (plus:HI (match_operand:HI 1 "register_operand" "%A,A,A,A,A")
- (match_operand:HI 2 "nonmemory_operand" "Z,d,L,M,?i")))]
- ""
- "@
- %0=%1+%2
- %0=%1+%2
- %0=%w1+%H2
- %0=%b1+%U2
- %0=%w1+%H2\;%0=%b0+%U2"
- [(set_attr "type" "malu,malu,f3_alu_i,f3_alu_i,f3_alu_i")])
-
-(define_insn ""
- [(set (match_operand:QI 0 "register_operand" "=k,u,!k,!u")
- (plus:QI (plus:QI (match_operand:QI 1 "register_operand" "uk,uk,uk,uk")
- (match_operand:QI 2 "register_operand" "wz,wz,uk,uk"))
- (match_operand:QI 3 "immediate_operand" "i,i,i,i")))
- (clobber (match_scratch:QI 4 "=j,q,j,q"))]
- ""
- "@
- %m0=%m1+%m2\;%m0=%0+%H3
- %m0=%m1+%m2\;%m0=%0+%H3
- %m0=%m1+%m2\;%m0=%0+%H3
- %m0=%m1+%m2\;%m0=%0+%H3")
-
-(define_expand "addqi3"
- [(parallel [(set (match_operand:QI 0 "register_operand" "")
- (plus:QI (match_operand:QI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))
- (clobber (match_scratch:QI 3 ""))])]
- ""
- "
-{
- if (reload_in_progress)
- {
- if (REG_P (operands[1]) &&
- (REGNO(operands[1]) == STACK_POINTER_REGNUM ||
- REGNO(operands[1]) == FRAME_POINTER_REGNUM) &&
- GET_CODE (operands[2]) == CONST_INT)
- {
- if (REG_P (operands[0]) && IS_ACCUM_REG(REGNO(operands[0])))
- emit_move_insn (operands[0], operands[1]);
-
- operands[1] = operands[0];
- }
- }
-}")
-
-
-(define_insn "match_addqi3"
- [(set (match_operand:QI 0 "register_operand" "=a,a,k,u,k,u,!k,!u,j,j,q,q")
- (plus:QI (match_operand:QI 1 "register_operand" "0,0,uk,uk,uk,uk,uk,uk,0,q,0,j")
- (match_operand:QI 2 "nonmemory_operand" "W,N,i,i,wz,wz,uk,uk,i,i,i,i")))
- (clobber (match_scratch:QI 3 "=X,X,j,q,j,q,j,q,X,k,X,u"))]
- ""
- "*
-{
- switch (which_alternative)
- {
- case 0:
- return \"*%0++%2\";
-
- case 1:
- switch (INTVAL (operands[2]))
- {
- case -1:
- return \"*%0--\";
-
- case 1:
- return \"*%0++\";
-
- case -2:
- return \"*%0--\;*%0--\";
-
- case 2:
- return \"*%0++\;*%0++\";
- default:
- abort();
- }
-
- case 2:
- case 3:
- return \"%m0=%1+%H2\";
-
- case 4:
- case 5:
- return \"%m0=%m1+%m2\";
-
-
- case 6:
- case 7:
- return \"%m0=%m1+%m2\";
-
- case 8:
- case 9:
- case 10:
- case 11:
- return \"%0=%b1+%H2\";
- default:
- abort();
- }
-}"
-[(set_attr "type" "data_move_memory,data_move_multiple,f3_alu_i,f3_alu_i,f3_alu,f3_alu,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i")])
-
-
-(define_expand "addhf3"
- [(set (match_operand:HF 0 "register_operand" "")
- (plus:HF (match_operand:HF 1 "register_operand" "")
- (match_operand:HF 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_addhf3_libcall)
- dsp16xx_addhf3_libcall = gen_rtx_SYMBOL_REF (Pmode, ADDHF3_LIBCALL);
-
- emit_library_call (dsp16xx_addhf3_libcall, 1, HFmode, 2,
- operands[1], HFmode,
- operands[2], HFmode);
- emit_move_insn (operands[0], hard_libcall_value(HFmode));
- DONE;
-}")
-
-\f
-;;
-;; ....................
-;;
-;; Subtract instructions
-;;
-;; ....................
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (minus:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !ADD_LOW_16(INTVAL(operands[2])) &&
- !ADD_HIGH_16(INTVAL(operands[2]))"
- [(parallel [(set (match_dup 3)
- (minus:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_dup 6))])
-
- (parallel [(set (match_dup 6)
- (minus:QI (match_dup 7)
- (match_dup 8)))
- (clobber (match_scratch:QI 9 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[6] = gen_highpart(QImode, operands[0]);
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-
-(define_insn "subhi3"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A,A,A")
- (minus:HI (match_operand:HI 1 "register_operand" "A,A,A,A,A")
- (match_operand:HI 2 "nonmemory_operand" "Z,d,L,M,?i")))]
- ""
- "@
- %0=%1-%2
- %0=%1-%2
- %0=%w1-%H2
- %0=%b1-%U2
- %0=%w1-%H2\;%0=%b0-%U2"
- [(set_attr "type" "malu,malu,f3_alu_i,f3_alu_i,f3_alu_i")])
-
-(define_insn "subqi3"
- [(set (match_operand:QI 0 "register_operand" "=a,k,u,k,u,!k,!u,j,j,q,q")
- (minus:QI (match_operand:QI 1 "register_operand" "0,uk,uk,uk,uk,uk,uk,0,q,0,j")
- (match_operand:QI 2 "nonmemory_operand" "N,i,i,wz,wz,uk,uk,i,i,i,i")))
- (clobber (match_scratch:QI 3 "=X,j,q,j,q,j,q,X,k,X,u"))]
- ""
- "*
-{
- switch (which_alternative)
- {
- case 0:
- switch (INTVAL (operands[2]))
- {
- case 1:
- return \"*%0--\";
-
- case -1:
- return \"*%0++\";
-
- default:
- operands[2] = GEN_INT (-INTVAL (operands[2]));
-
- if (SHORT_IMMEDIATE(operands[2]))
- return \"set %3=%H2\;*%0++%3\";
- else
- return \"%3=%H2\;*%0++%3\";
- }
-
- case 1:
- case 2:
- return \"%m0=%1-%H2\";
-
- case 3:
- case 4:
- return \"%m0=%m1-%m2\";
-
- case 5:
- case 6:
- return \"%m0=%m1-%m2\";
-
- case 7: case 8:
- case 9: case 10:
- return \"%0=%b1-%H2\";
- default:
- abort();
- }
-}"
-[(set_attr "type" "data_move_multiple,f3_alu_i,f3_alu_i,f3_alu,f3_alu,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i")])
-
-(define_expand "subhf3"
- [(set (match_operand:HF 0 "register_operand" "")
- (minus:HF (match_operand:HF 1 "register_operand" "")
- (match_operand:HF 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_subhf3_libcall)
- dsp16xx_subhf3_libcall = gen_rtx_SYMBOL_REF (Pmode, SUBHF3_LIBCALL);
-
- emit_library_call (dsp16xx_subhf3_libcall, 1, HFmode, 2,
- operands[1], HFmode,
- operands[2], HFmode);
- emit_move_insn (operands[0], hard_libcall_value(HFmode));
- DONE;
-}")
-
-(define_insn "neghi2"
- [(set (match_operand:HI 0 "register_operand" "=A")
- (neg:HI (match_operand:HI 1 "register_operand" "A")))]
- ""
- "%0=-%1"
- [(set_attr "type" "special")])
-
-(define_expand "neghf2"
- [(set (match_operand:HF 0 "register_operand" "")
- (neg:HF (match_operand:HF 1 "register_operand" "")))]
- ""
- "
-{
- rtx result;
- rtx target;
-
- {
- target = gen_lowpart(HImode, operands[0]);
- result = expand_binop (HImode, xor_optab,
- gen_lowpart(HImode, operands[1]),
- GEN_INT(0x80000000), target, 0, OPTAB_WIDEN);
- if (result == 0)
- abort ();
-
- if (result != target)
- emit_move_insn (result, target);
-
- /* Make a place for REG_EQUAL. */
- emit_move_insn (operands[0], operands[0]);
- DONE;
- }
-}")
-
-;;
-;; ....................
-;;
-;; Multiply instructions
-;;
-
-(define_expand "mulhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (mult:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_mulhi3_libcall)
- dsp16xx_mulhi3_libcall = gen_rtx_SYMBOL_REF (Pmode, MULHI3_LIBCALL);
-
- emit_library_call (dsp16xx_mulhi3_libcall, 1, HImode, 2,
- operands[1], HImode,
- operands[2], HImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-}")
-
-(define_insn "mulqi3"
- [(set (match_operand:QI 0 "register_operand" "=w")
- (mult:QI (match_operand:QI 1 "register_operand" "%x")
- (match_operand:QI 2 "register_operand" "y")))
- (clobber (match_scratch:QI 3 "=v"))]
- ""
- "%m0=%1*%2"
- [(set_attr "type" "malu_mul")])
-
-(define_insn "mulqihi3"
- [(set (match_operand:HI 0 "register_operand" "=t")
- (mult:HI (sign_extend:HI (match_operand:QI 1 "register_operand" "%x"))
- (sign_extend:HI (match_operand:QI 2 "register_operand" "y"))))]
- ""
- "%0=%1*%2"
- [(set_attr "type" "malu_mul")])
-
-(define_expand "mulhf3"
- [(set (match_operand:HF 0 "register_operand" "")
- (mult:HF (match_operand:HF 1 "register_operand" "")
- (match_operand:HF 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_mulhf3_libcall)
- dsp16xx_mulhf3_libcall = gen_rtx_SYMBOL_REF (Pmode, MULHF3_LIBCALL);
-
- emit_library_call (dsp16xx_mulhf3_libcall, 1, HFmode, 2,
- operands[1], HFmode,
- operands[2], HFmode);
- emit_move_insn (operands[0], hard_libcall_value(HFmode));
- DONE;
-}")
-
-\f
-
-;;
-;; *******************
-;;
-;; Divide Instructions
-;;
-
-(define_expand "divhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (div:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_divhi3_libcall)
- dsp16xx_divhi3_libcall = gen_rtx_SYMBOL_REF (Pmode, DIVHI3_LIBCALL);
-
- emit_library_call (dsp16xx_divhi3_libcall, 1, HImode, 2,
- operands[1], HImode,
- operands[2], HImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-}")
-
-(define_expand "udivhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (udiv:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_udivhi3_libcall)
- dsp16xx_udivhi3_libcall = gen_rtx_SYMBOL_REF (Pmode, UDIVHI3_LIBCALL);
-
- emit_library_call (dsp16xx_udivhi3_libcall, 1, HImode, 2,
- operands[1], HImode,
- operands[2], HImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-}")
-
-(define_expand "divqi3"
- [(set (match_operand:QI 0 "register_operand" "")
- (div:QI (match_operand:QI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_divqi3_libcall)
- dsp16xx_divqi3_libcall = gen_rtx_SYMBOL_REF (Pmode, DIVQI3_LIBCALL);
-
- emit_library_call (dsp16xx_divqi3_libcall, 1, QImode, 2,
- operands[1], QImode,
- operands[2], QImode);
- emit_move_insn (operands[0], hard_libcall_value(QImode));
- DONE;
-}")
-
-(define_expand "udivqi3"
- [(set (match_operand:QI 0 "register_operand" "")
- (udiv:QI (match_operand:QI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_udivqi3_libcall)
- dsp16xx_udivqi3_libcall = gen_rtx_SYMBOL_REF (Pmode, UDIVQI3_LIBCALL);
-
- emit_library_call (dsp16xx_udivqi3_libcall, 1, QImode, 2,
- operands[1], QImode,
- operands[2], QImode);
- emit_move_insn (operands[0], hard_libcall_value(QImode));
- DONE;
-}")
-\f
-;;
-;; ....................
-;;
-;; Modulo instructions
-;;
-;; ....................
-
-(define_expand "modhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (mod:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_modhi3_libcall)
- dsp16xx_modhi3_libcall = gen_rtx_SYMBOL_REF (Pmode, MODHI3_LIBCALL);
-
- emit_library_call (dsp16xx_modhi3_libcall, 1, HImode, 2,
- operands[1], HImode,
- operands[2], HImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-}")
-
-(define_expand "umodhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (umod:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_umodhi3_libcall)
- dsp16xx_umodhi3_libcall = gen_rtx_SYMBOL_REF (Pmode, UMODHI3_LIBCALL);
-
- emit_library_call (dsp16xx_umodhi3_libcall, 1, HImode, 2,
- operands[1], HImode,
- operands[2], HImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-}")
-
-(define_expand "modqi3"
- [(set (match_operand:QI 0 "register_operand" "")
- (mod:QI (match_operand:QI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_modqi3_libcall)
- dsp16xx_modqi3_libcall = gen_rtx_SYMBOL_REF (Pmode, MODQI3_LIBCALL);
-
- emit_library_call (dsp16xx_modqi3_libcall, 1, QImode, 2,
- operands[1], QImode,
- operands[2], QImode);
- emit_move_insn (operands[0], hard_libcall_value(QImode));
- DONE;
-}")
-
-(define_expand "umodqi3"
- [(set (match_operand:QI 0 "register_operand" "")
- (umod:QI (match_operand:QI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_umodqi3_libcall)
- dsp16xx_umodqi3_libcall = gen_rtx_SYMBOL_REF (Pmode, UMODQI3_LIBCALL);
-
- emit_library_call (dsp16xx_umodqi3_libcall, 1, QImode, 2,
- operands[1], QImode,
- operands[2], QImode);
- emit_move_insn (operands[0], hard_libcall_value(QImode));
- DONE;
-}")
-
-(define_expand "divhf3"
- [(set (match_operand:HF 0 "register_operand" "")
- (div:HF (match_operand:HF 1 "register_operand" "")
- (match_operand:HF 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_divhf3_libcall)
- dsp16xx_divhf3_libcall = gen_rtx_SYMBOL_REF (Pmode, DIVHF3_LIBCALL);
-
- emit_library_call (dsp16xx_divhf3_libcall, 1, HFmode, 2,
- operands[1], HFmode,
- operands[2], HFmode);
- emit_move_insn (operands[0], hard_libcall_value(HFmode));
- DONE;
-}")
-
-\f
-
-;;
-;; ********************
-;;
-;; Logical Instructions
-;;
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (and:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !AND_LOW_16(INTVAL(operands[2])) &&
- !AND_HIGH_16(INTVAL(operands[2]))
- && (REGNO (operands[0]) == REGNO (operands[1]))"
- [(parallel [(set (match_dup 3)
- (and:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_scratch:QI 6 ""))])
- (parallel [(set (match_dup 7)
- (and:QI (match_dup 8)
- (match_dup 9)))
- (clobber (match_scratch:QI 10 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_highpart(QImode, operands[0]);
- operands[9] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (and:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !AND_LOW_16(INTVAL(operands[2])) &&
- !AND_HIGH_16(INTVAL(operands[2]))
- && (REGNO (operands[0]) != REGNO (operands[1]))"
- [(parallel [(set (match_dup 3)
- (and:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_dup 6))])
- (parallel [(set (match_dup 6)
- (and:QI (match_dup 7)
- (match_dup 8)))
- (clobber (match_scratch:QI 9 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[6] = gen_highpart(QImode, operands[0]);
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-(define_insn "andhi3"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A,A,?A")
- (and:HI (match_operand:HI 1 "register_operand" "%A,!A,A,A,A")
- (match_operand:HI 2 "nonmemory_operand" "Z,A,O,P,i")))]
- ""
- "@
- %0=%1&%2
- %0=%1&%2
- %0=%w1&%H2
- %0=%b1&%U2
- %0=%w1&%H2\;%0=%b0&%U2"
- [(set_attr "type" "f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i_mult")])
-
-(define_insn "andqi3"
- [(set (match_operand:QI 0 "register_operand" "=k,u,!k,!u,k,u,k,u,j,q,j,q,j,q,!j,!q")
- (and:QI (match_operand:QI 1 "register_operand" "%uk,uk,uk,uk,0,0,u,k,jq,jq,0,0,q,j,jq,jq")
- (match_operand:QI 2 "nonmemory_operand" "wz,wz,uk,uk,i,i,i,i,yv,yv,i,i,i,i,jq,jq")))
- (clobber (match_scratch:QI 3 "=j,q,j,q,X,X,j,q,k,u,X,X,k,u,k,u"))]
- ""
- "@
- %m0=%m1&%m2
- %m0=%m1&%m2
- %m0=%m1&%m2
- %m0=%m1&%m2
- %m0=%1&%H2
- %m0=%1&%H2
- %m0=%1&%H2
- %m0=%1&%H2
- %m0=%m1&%m2
- %m0=%m1&%m2
- %m0=%b1&%H2
- %m0=%b1&%H2
- %m0=%b1&%H2
- %m0=%b1&%H2
- %m0=%m1&%m2
- %m0=%m1&%m2"
- [(set_attr "type" "f3_alu,f3_alu,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu,f3_alu")])
-
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (ior:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !SMALL_INTVAL(INTVAL(operands[2])) &&
- !ADD_HIGH_16(INTVAL(operands[2]))
- && (REGNO (operands[0]) == REGNO (operands[1]))"
- [(parallel [(set (match_dup 3)
- (ior:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_scratch:QI 6 ""))])
- (parallel [(set (match_dup 7)
- (ior:QI (match_dup 8)
- (match_dup 9)))
- (clobber (match_scratch:QI 10 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_highpart(QImode, operands[0]);
- operands[9] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (ior:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !SMALL_INTVAL(INTVAL(operands[2])) &&
- !ADD_HIGH_16(INTVAL(operands[2]))
- && (REGNO (operands[0]) != REGNO (operands[1]))"
- [(parallel [(set (match_dup 3)
- (ior:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_dup 6))])
- (parallel [(set (match_dup 6)
- (ior:QI (match_dup 7)
- (match_dup 8)))
- (clobber (match_scratch:QI 9 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[6] = gen_highpart(QImode, operands[0]);
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-
-(define_insn "iorhi3"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A,A,?A")
- (ior:HI (match_operand:HI 1 "register_operand" "%A,!A,A,A,A")
- (match_operand:HI 2 "nonmemory_operand" "Z,A,I,M,i")))]
- ""
- "@
- %0=%u1|%u2
- %0=%u1|%u2
- %0=%w1|%H2
- %0=%b1|%U2
- %0=%w1|%H2\;%0=%b0|%U2"
- [(set_attr "type" "f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i_mult")])
-
-(define_insn "iorqi3"
- [(set (match_operand:QI 0 "register_operand" "=k,u,!k,!u,k,u,k,u,j,q,j,q,j,q,!j,!q")
- (ior:QI (match_operand:QI 1 "register_operand" "%uk,uk,uk,uk,0,0,u,k,jq,jq,0,0,q,j,jq,jq")
- (match_operand:QI 2 "nonmemory_operand" "wz,wz,uk,uk,i,i,i,i,yv,yv,i,i,i,i,jq,jq")))
- (clobber (match_scratch:QI 3 "=j,q,j,q,X,X,j,q,k,u,X,X,k,u,k,u"))]
- ""
- "@
- %m0=%m1|%m2
- %m0=%m1|%m2
- %m0=%m1|%m2
- %m0=%m1|%m2
- %m0=%1|%H2
- %m0=%1|%H2
- %m0=%1|%H2
- %m0=%1|%H2
- %m0=%m1|%m2
- %m0=%m1|%m2
- %m0=%b1|%H2
- %m0=%b1|%H2
- %m0=%b1|%H2
- %m0=%b1|%H2
- %m0=%m1|%m2
- %m0=%m1|%m2"
- [(set_attr "type" "f3_alu,f3_alu,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu,f3_alu")])
-
-
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (xor:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !SMALL_INTVAL(INTVAL(operands[2])) &&
- !ADD_HIGH_16(INTVAL(operands[2]))
- && (REGNO (operands[0]) == REGNO (operands[1]))"
- [(parallel [(set (match_dup 3)
- (xor:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_scratch:QI 6 ""))])
- (parallel [(set (match_dup 7)
- (xor:QI (match_dup 8)
- (match_dup 9)))
- (clobber (match_scratch:QI 10 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_highpart(QImode, operands[0]);
- operands[9] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (xor:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:HI 2 "const_int_operand" "")))]
- "reload_completed && !SMALL_INTVAL(INTVAL(operands[2])) &&
- !ADD_HIGH_16(INTVAL(operands[2]))
- && (REGNO (operands[0]) != REGNO (operands[1]))"
- [(parallel [(set (match_dup 3)
- (xor:QI (match_dup 4)
- (match_dup 5)))
- (clobber (match_dup 6))])
- (parallel [(set (match_dup 6)
- (xor:QI (match_dup 7)
- (match_dup 8)))
- (clobber (match_scratch:QI 9 ""))])]
- "
-{
- operands[3] = gen_lowpart(QImode, operands[0]);
- operands[4] = gen_lowpart(QImode, operands[1]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[2]) & 0xffff);
-
- operands[6] = gen_highpart(QImode, operands[0]);
- operands[7] = gen_highpart(QImode, operands[0]);
- operands[8] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[2]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-(define_insn "xorhi3"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A,A,?A")
- (xor:HI (match_operand:HI 1 "register_operand" "%A,!A,A,A,A")
- (match_operand:HI 2 "nonmemory_operand" "Z,A,I,M,i")))]
- ""
- "@
- %0=%1^%2
- %0=%1^%2
- %0=%w1^%H2
- %0=%b1^%U2
- %0=%w1^%H2\;%0=%b0^%U2"
- [(set_attr "type" "f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i_mult")])
-
-(define_insn "xorqi3"
- [(set (match_operand:QI 0 "register_operand" "=k,u,!k,!u,k,u,k,u,j,q,j,q,j,q,!j,!q")
- (xor:QI (match_operand:QI 1 "register_operand" "%uk,uk,uk,uk,0,0,u,k,jq,jq,0,0,q,j,jq,jq")
- (match_operand:QI 2 "nonmemory_operand" "wz,wz,uk,uk,i,i,i,i,yv,yv,i,i,i,i,jq,jq")))
- (clobber (match_scratch:QI 3 "=j,q,j,q,X,X,j,q,k,u,X,X,k,u,k,u"))]
- ""
- "@
- %m0=%m1^%m2
- %m0=%m1^%m2
- %m0=%m1^%m2
- %m0=%m1^%m2
- %m0=%1^%H2
- %m0=%1^%H2
- %m0=%1^%H2
- %m0=%1^%H2
- %m0=%m1^%m2
- %m0=%m1^%m2
- %m0=%b1^%H2
- %m0=%b1^%H2
- %m0=%b1^%H2
- %m0=%b1^%H2
- %m0=%m1^%m2
- %m0=%m1^%m2"
- [(set_attr "type" "f3_alu,f3_alu,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu,f3_alu,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu,f3_alu")])
-
-(define_insn "one_cmplhi2"
- [(set (match_operand:HI 0 "register_operand" "=A")
- (not:HI (match_operand:HI 1 "register_operand" "A")))]
- ""
- "%0= ~%1"
- [(set_attr "type" "special")])
-
-
-(define_insn "one_cmplqi2"
- [(set (match_operand:QI 0 "register_operand" "=k,k,u,u,j,j,q,q")
- (not:QI (match_operand:QI 1 "register_operand" "0,u,0,q,0,q,0,j")))
- (clobber (match_scratch:QI 2 "=X,j,X,q,X,k,X,u"))]
- ""
- "@
- %m0= %1 ^ 0xffff
- %m0= %1 ^ 0xffff
- %m0= %1 ^ 0xffff
- %m0= %1 ^ 0xffff
- %m0= %b1 ^ 0xffff
- %m0= %b1 ^ 0xffff
- %m0= %b1 ^ 0xffff
- %m0= %b1 ^ 0xffff"
- [(set_attr "type" "f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i,f3_alu_i")])
-
-\f
-;;
-;; MOVE INSTRUCTIONS
-;;
-
-(define_split
- [(set (mem:HI (match_operand:QI 0 "register_operand" ""))
- (match_operand:HI 1 "register_operand" ""))]
- "reload_completed && (operands[0] != stack_pointer_rtx)"
- [(set (mem:QI (post_inc:QI (match_dup 0)))
- (match_dup 2))
- (set (mem:QI (post_dec:QI (match_dup 0)))
- (match_dup 3))]
- "
-{
- operands[2] = gen_highpart(QImode, operands[1]);
- operands[3] = gen_lowpart(QImode, operands[1]);
-}")
-
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (mem:HI (match_operand:QI 1 "register_operand" "")))]
- "reload_completed && (operands[1] != stack_pointer_rtx)"
- [(set (match_dup 2)
- (mem:QI (post_inc:QI (match_dup 1))))
- (set (match_dup 3)
- (mem:QI (post_dec:QI (match_dup 1))))]
- "
-{
- operands[2] = gen_highpart(QImode, operands[0]);
- operands[3] = gen_lowpart(QImode, operands[0]);
-}")
-
-(define_split
- [(set (mem:HI (post_inc:HI (match_operand:QI 0 "register_operand" "")))
- (match_operand:HI 1 "register_operand" ""))]
- "reload_completed"
- [(set (mem:QI (post_inc:QI (match_dup 0)))
- (match_dup 2))
- (set (mem:QI (post_inc:QI (match_dup 0)))
- (match_dup 3))]
- "
-{
- operands[2] = gen_highpart(QImode, operands[1]);
- operands[3] = gen_lowpart(QImode, operands[1]);
-}")
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (mem:HI (post_inc:HI (match_operand:QI 1 "register_operand" ""))))]
- "reload_completed"
- [(set (match_dup 2)
- (mem:QI (post_inc:QI (match_dup 1))))
- (set (match_dup 3)
- (mem:QI (post_inc:QI (match_dup 1))))]
- "
-{
- operands[2] = gen_highpart(QImode, operands[0]);
- operands[3] = gen_lowpart(QImode, operands[0]);
-}")
-
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (match_operand:HI 1 "register_operand" ""))]
- "reload_completed &&
- !(IS_ACCUM_REG (REGNO(operands[0])) &&
- (REGNO(operands[1]) == REG_PROD || REGNO(operands[1]) == REG_Y))"
- [(set (match_dup 2)
- (match_dup 3))
- (set (match_dup 4)
- (match_dup 5))]
- "
-{
- operands[2] = gen_highpart(QImode, operands[0]);
- operands[3] = gen_highpart(QImode, operands[1]);
- operands[4] = gen_lowpart(QImode, operands[0]);
- operands[5] = gen_lowpart(QImode, operands[1]);
-}")
-
-(define_split
- [(set (match_operand:HI 0 "register_operand" "")
- (match_operand:HI 1 "const_int_operand" ""))]
- "reload_completed"
- [(set (match_dup 2)
- (match_dup 3))
- (set (match_dup 4)
- (match_dup 5))]
- "
-{
- operands[2] = gen_lowpart(QImode, operands[0]);
- operands[3] = gen_rtx (CONST_INT, VOIDmode, INTVAL (operands[1]) & 0xffff);
-
- operands[4] = gen_highpart(QImode, operands[0]);
- operands[5] = gen_rtx (CONST_INT, VOIDmode, (((INTVAL (operands[1]) & 0xffff0000) >> 16) & 0xffff));
-}")
-
-(define_expand "movhi"
- [(set (match_operand:HI 0 "general_operand" "")
- (match_operand:HI 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, HImode))
- DONE;
-}")
-
-
-(define_insn "match_movhi1"
- [(set (match_operand:HI 0 "nonimmediate_operand" "=A,Z,A,d,d,m,?d,*Y,t,f")
- (match_operand:HI 1 "general_operand" "d,A,K,i,m,d,*Y,?d,t,f"))]
- "register_operand(operands[0], HImode)
- || register_operand(operands[1], HImode)"
- "*
-{
- switch (which_alternative)
- {
- /* register to accumulator */
- case 0:
- return \"%0=%1\";
- case 1:
- return \"%u0=%u1\;%w0=%w1\";
- case 2:
- return \"%0=%0^%0\";
- case 3:
- return \"%u0=%U1\;%w0=%H1\";
- case 4:
- double_reg_from_memory(operands);
- return \"\";
- case 5:
- double_reg_to_memory(operands);
- return \"\";
- case 6:
- case 7:
- return \"%u0=%u1\;%w0=%w1\";
- case 8:
- case 9:
- return \"\";
- default:
- abort();
- }
-}"
-[(set_attr "type" "special,data_move_multiple,f3_alu,data_move_multiple,data_move_multiple,data_move_multiple,data_move_multiple,data_move_multiple,nothing,nothing")])
-
-
-;; NOTE: It is cheaper to do 'y = *r0', than 'r0 = *r0'.
-
-(define_expand "movqi"
- [(set (match_operand:QI 0 "nonimmediate_operand" "")
- (match_operand:QI 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, QImode))
- DONE;
-}")
-
-;; The movqi pattern with the parallel is used for addqi insns (which have a parallel)
-;; that are turned into moveqi insns by the flow phase. This happens when an auto-increment
-;; is detected.
-
-(define_insn "match_movqi1"
- [(parallel [(set (match_operand:QI 0 "nonimmediate_operand" "=A,r,aW,c,?D,m<>,e,Y,r,xyz,m<>")
- (match_operand:QI 1 "general_operand" "r,A,J,i,m<>,D,Y,e,0,m<>,xyz"))
- (clobber (match_scratch:QI 2 "=X,X,X,X,X,X,X,X,X,X,X"))])]
- "register_operand(operands[0], QImode)
- || register_operand(operands[1], QImode)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- /* We have to use the move mneumonic otherwise the 1610 will
- attempt to transfer all 32-bits of 'y', 'p' or an accumulator
- , which we don't want */
- if (REGNO(operands[1]) == REG_Y || REGNO(operands[1]) == REG_PROD
- || IS_ACCUM_REG(REGNO(operands[1])))
- return \"move %0=%1\";
- else
- return \"%0=%1\";
-
- case 1:
- return \"%0=%1\";
-
- case 2:
- return \"set %0=%H1\";
-
- case 3:
- return \"%0=%H1\";
-
- case 4:
- return \"%0=%1\";
-
- case 5:
- case 6:
- return \"%0=%1\";
-
- case 7:
- return \"%0=%1\";
-
- case 8:
- return \"\";
-
- case 9: case 10:
- return \"%0=%1\";
- default:
- abort();
- }
-}"
-[(set_attr "type" "data_move,data_move,data_move_short_i,data_move_i,data_move_memory,data_move_memory,data_move_memory,data_move_memory,nothing,malu,malu")])
-
-(define_insn "match_movqi2"
- [(set (match_operand:QI 0 "nonimmediate_operand" "=A,r,aW,c,?D,m<>,e,Y,r,xyz,m<>")
- (match_operand:QI 1 "general_operand" "r,A,J,i,m<>,D,Y,e,0,m<>,xyz"))]
- "register_operand(operands[0], QImode)
- || register_operand(operands[1], QImode)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- /* We have to use the move mneumonic otherwise the 1610 will
- attempt to transfer all 32-bits of 'y', 'p' or an accumulator
- , which we don't want */
- if (REGNO(operands[1]) == REG_Y || REGNO(operands[1]) == REG_PROD
- || IS_ACCUM_REG(REGNO(operands[1])))
- return \"move %0=%1\";
- else
- return \"%0=%1\";
-
- case 1:
- return \"%0=%1\";
-
- case 2:
- return \"set %0=%H1\";
-
- case 3:
- return \"%0=%H1\";
-
- case 4:
- return \"%0=%1\";
-
- case 5:
- case 6:
- return \"%0=%1\";
-
- case 7:
- return \"%0=%1\";
-
- case 8:
- return \"\";
-
- case 9: case 10:
- return \"%0=%1\";
- default:
- abort();
- }
-}"
-[(set_attr "type" "data_move,data_move,data_move_short_i,data_move_i,data_move_memory,data_move_memory,data_move_memory,data_move_memory,nothing,malu,malu")])
-
-(define_expand "reload_inqi"
- [(set (match_operand:QI 0 "register_operand" "=u")
- (match_operand:QI 1 "sp_operand" ""))
- (clobber (match_operand:QI 2 "register_operand" "=&q"))]
- ""
- "
-{
- rtx addr_reg = XEXP (operands[1], 0);
- rtx offset = XEXP (operands[1], 1);
-
- /* First, move the frame or stack pointer to the accumulator */
- emit_move_insn (operands[0], addr_reg);
-
- /* Then generate the add insn */
- emit_insn (gen_rtx_PARALLEL
- (VOIDmode,
- gen_rtvec (2,
- gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_PLUS (QImode, operands[0],
- offset)),
- gen_rtx_CLOBBER (VOIDmode, operands[2]))));
- DONE;
-}")
-
-(define_expand "reload_inhi"
- [(set (match_operand:HI 0 "register_operand" "=r")
- (match_operand:HI 1 "register_operand" "r"))
- (clobber (match_operand:QI 2 "register_operand" "=&h"))]
- ""
- "
-{
- /* Check for an overlap of operand 2 (an accumulator) with
- the msw of operand 0. If we have an overlap we must reverse
- the order of the moves. */
-
- if (REGNO(operands[2]) == REGNO(operands[0]))
- {
- emit_move_insn (operands[2], operand_subword (operands[1], 1, 0, HImode));
- emit_move_insn (operand_subword (operands[0], 1, 0, HImode), operands[2]);
- emit_move_insn (operands[2], operand_subword (operands[1], 0, 0, HImode));
- emit_move_insn (operand_subword (operands[0], 0, 0, HImode), operands[2]);
- }
- else
- {
- emit_move_insn (operands[2], operand_subword (operands[1], 0, 0, HImode));
- emit_move_insn (operand_subword (operands[0], 0, 0, HImode), operands[2]);
- emit_move_insn (operands[2], operand_subword (operands[1], 1, 0, HImode));
- emit_move_insn (operand_subword (operands[0], 1, 0, HImode), operands[2]);
- }
-
- DONE;
-}")
-
-
-(define_expand "reload_outhi"
- [(set (match_operand:HI 0 "register_operand" "=r")
- (match_operand:HI 1 "register_operand" "r"))
- (clobber (match_operand:QI 2 "register_operand" "=&h"))]
- ""
- "
-{
- emit_move_insn (operands[2], operand_subword (operands[1], 0, 0, HImode));
- emit_move_insn (operand_subword (operands[0], 0, 0, HImode), operands[2]);
- emit_move_insn (operands[2], operand_subword (operands[1], 1, 0, HImode));
- emit_move_insn (operand_subword (operands[0], 1, 0, HImode), operands[2]);
- DONE;
-}")
-
-(define_expand "movstrqi"
- [(parallel [(set (match_operand:BLK 0 "memory_operand" "")
- (match_operand:BLK 1 "memory_operand" ""))
- (use (match_operand:QI 2 "const_int_operand" ""))
- (use (match_operand:QI 3 "const_int_operand" ""))
- (clobber (match_scratch:QI 4 ""))
- (clobber (match_dup 5))
- (clobber (match_dup 6))])]
- ""
- "
-{
- rtx addr0, addr1;
-
- if (GET_CODE (operands[2]) != CONST_INT)
- FAIL;
-
- if (INTVAL(operands[2]) > 127)
- FAIL;
-
- addr0 = copy_to_mode_reg (Pmode, XEXP (operands[0], 0));
- addr1 = copy_to_mode_reg (Pmode, XEXP (operands[1], 0));
-
- operands[5] = addr0;
- operands[6] = addr1;
-
- operands[0] = change_address (operands[0], VOIDmode, addr0);
- operands[1] = change_address (operands[1], VOIDmode, addr1);
-}")
-
-(define_insn ""
- [(set (mem:BLK (match_operand:QI 0 "register_operand" "a"))
- (mem:BLK (match_operand:QI 1 "register_operand" "a")))
- (use (match_operand:QI 2 "const_int_operand" "n"))
- (use (match_operand:QI 3 "immediate_operand" "i"))
- (clobber (match_scratch:QI 4 "=x"))
- (clobber (match_dup 0))
- (clobber (match_dup 1))]
- ""
- "*
-{ return output_block_move (operands); }")
-
-\f
-;; Floating point move insns
-
-
-(define_expand "movhf"
- [(set (match_operand:HF 0 "general_operand" "")
- (match_operand:HF 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, HFmode))
- DONE;
-}")
-
-(define_insn "match_movhf"
- [(set (match_operand:HF 0 "nonimmediate_operand" "=A,Z,d,d,m,d,Y")
- (match_operand:HF 1 "general_operand" "d,A,F,m,d,Y,d"))]
- ""
- "*
-{
- /* NOTE: When loading the register 16 bits at a time we
- MUST load the high half FIRST (because the 1610 zeros
- the low half) and then load the low half */
-
- switch (which_alternative)
- {
- /* register to accumulator */
- case 0:
- return \"%0=%1\";
- case 1:
- return \"%u0=%u1\;%w0=%w1\";
- case 2:
- output_dsp16xx_float_const(operands);
- return \"\";
- case 3:
- double_reg_from_memory(operands);
- return \"\";
- case 4:
- double_reg_to_memory(operands);
- return \"\";
- case 5:
- case 6:
- return \"%u0=%u1\;%w0=%w1\";
- default:
- abort();
- }
-}"
-[(set_attr "type" "move,move,load_i,load,store,load,store")])
-
-
-
-(define_expand "reload_inhf"
- [(set (match_operand:HF 0 "register_operand" "=r")
- (match_operand:HF 1 "register_operand" "r"))
- (clobber (match_operand:QI 2 "register_operand" "=&h"))]
- ""
- "
-{
- /* Check for an overlap of operand 2 (an accumulator) with
- the msw of operand 0. If we have an overlap we must reverse
- the order of the moves. */
-
- if (REGNO(operands[2]) == REGNO(operands[0]))
- {
- emit_move_insn (operands[2], operand_subword (operands[1], 1, 0, HFmode));
- emit_move_insn (operand_subword (operands[0], 1, 0, HFmode), operands[2]);
- emit_move_insn (operands[2], operand_subword (operands[1], 0, 0, HFmode));
- emit_move_insn (operand_subword (operands[0], 0, 0, HFmode), operands[2]);
- }
- else
- {
- emit_move_insn (operands[2], operand_subword (operands[1], 0, 0, HFmode));
- emit_move_insn (operand_subword (operands[0], 0, 0, HFmode), operands[2]);
- emit_move_insn (operands[2], operand_subword (operands[1], 1, 0, HFmode));
- emit_move_insn (operand_subword (operands[0], 1, 0, HFmode), operands[2]);
- }
-
- DONE;
-}")
-
-(define_expand "reload_outhf"
- [(set (match_operand:HF 0 "register_operand" "=r")
- (match_operand:HF 1 "register_operand" "r"))
- (clobber (match_operand:QI 2 "register_operand" "=&h"))]
- ""
- "
-{
- emit_move_insn (operands[2], operand_subword (operands[1], 0, 0, HFmode));
- emit_move_insn (operand_subword (operands[0], 0, 0, HFmode), operands[2]);
- emit_move_insn (operands[2], operand_subword (operands[1], 1, 0, HFmode));
- emit_move_insn (operand_subword (operands[0], 1, 0, HFmode), operands[2]);
- DONE;
-}")
-
-\f
-;;
-;; CONVERSION INSTRUCTIONS
-;;
-
-(define_expand "extendqihi2"
- [(clobber (match_dup 2))
- (set (match_dup 3) (match_operand:QI 1 "register_operand" ""))
- (set (match_operand:HI 0 "register_operand" "")
- (ashift:HI (match_dup 2)
- (const_int 16)))
- (set (match_dup 0)
- (ashiftrt:HI (match_dup 0) (const_int 16)))]
- ""
- "
-{
- operands[2] = gen_reg_rtx (HImode);
- operands[3] = gen_rtx_SUBREG (QImode, operands[2], 1);
-}")
-
-(define_insn "internal_extendqihi2"
- [(set (match_operand:HI 0 "register_operand" "=A")
- (sign_extend:HI (match_operand:QI 1 "register_operand" "ku")))]
- "TARGET_BMU"
- "%0 = extracts(%m1, 0x1000)"
-[(set_attr "type" "shift_i")])
-
-;;(define_insn "extendqihi2"
-;; [(set (match_operand:HI 0 "register_operand" "=A")
-;; (sign_extend:HI (match_operand:QI 1 "register_operand" "h")))]
-;; ""
-;; "%0 = %1 >> 16")
-
-;;(define_insn "zero_extendqihi2"
-;; [(set (match_operand:HI 0 "register_operand" "=t,f,A,?d,?A")
-;; (zero_extend:HI (match_operand:QI 1 "register_operand" "w,z,ku,A,r")))]
-;; ""
-;; "*
-;; {
-;; switch (which_alternative)
-;; {
-;; case 0:
-;; case 1:
-;; return \"%0=0\";
-;;
-;; case 2:
-;; if (REGNO(operands[1]) == (REGNO(operands[0]) + 1))
-;; return \"%0=0\";
-;; else
-;; return \"%w0=%1\;%0=0\";
-;; case 3:
-;; return \"%w0=%1\;%0=0\";
-;;
-;; case 4:
-;; if (REGNO(operands[1]) == REG_Y || REGNO(operands[1]) == REG_PROD
-;; || IS_ACCUM_REG(REGNO(operands[1])))
-;; return \"move %w0=%1\;%0=0\";
-;; else
-;; return \"%w0=%1\;%0=0\";
-;; default:
-;; abort();
-;; }
-;; }")
-
-;;(define_expand "zero_extendqihi2"
-;; [(clobber (match_dup 2))
-;; (set (match_dup 3) (match_operand:QI 1 "register_operand" ""))
-;; (set (match_operand:HI 0 "register_operand" "")
-;; (ashift:HI (match_dup 2)
-;; (const_int 16)))
-;; (set (match_dup 0)
-;; (lshiftrt:HI (match_dup 0) (const_int 16)))]
-;; ""
-;; "
-;;{
-;; operands[2] = gen_reg_rtx (HImode);
-;; operands[3] = gen_rtx (SUBREG, QImode, operands[2], 1);
-;;}")
-
-(define_expand "zero_extendqihi2"
- [(set (match_operand:HI 0 "register_operand" "")
- (zero_extend:HI (match_operand:QI 1 "register_operand" "")))]
- ""
- "")
-
-
-(define_insn "match_zero_extendqihi_bmu"
- [(set (match_operand:HI 0 "register_operand" "=?*Z,?*Z,?A,A")
- (zero_extend:HI (match_operand:QI 1 "register_operand" "?A,?*Y,*Z*x*a*W*Y,ku")))]
- "TARGET_BMU"
- "*
- {
- switch (which_alternative)
- {
- case 0:
- return \"%w0=%1\;%0=0\";
-
- case 1:
- return \"%w0=%1\;%0=0\";
-
- case 2:
- if (REGNO(operands[1]) == (REGNO(operands[0]) + 1))
- return \"%0=0\";
- else if (REGNO(operands[1]) == REG_Y || REGNO(operands[1]) == REG_PROD
- || IS_ACCUM_REG(REGNO(operands[1])))
- {
- return \"move %w0=%1\;%0=0\";
- }
- else
- return \"%w0=%1\;%0=0\";
-
- case 3:
- return \"%0 = extractz(%m1, 0x1000)\";
- default:
- abort();
- }
- }"
- [(set_attr "type" "data_move_2,data_move_2,data_move_2,shift_i")])
-
-(define_insn "match_zero_extendqihi2_nobmu"
- [(set (match_operand:HI 0 "register_operand" "=?Z,?Z,A")
- (zero_extend:HI (match_operand:QI 1 "register_operand" "A,Y,r")))]
- ""
- "*
- {
- switch (which_alternative)
- {
- case 0:
- return \"%w0=%1\;%0=0\";
-
- case 1:
- return \"%w0=%1\;%0=0\";
-
- case 2:
- if (REGNO(operands[1]) + 1 == (REGNO(operands[0]) + 1))
- return \"%0=0\";
- else if (REGNO(operands[1]) == REG_Y || REGNO(operands[1]) == REG_PROD
- || IS_ACCUM_REG(REGNO(operands[1])))
- {
- return \"move %w0=%1\;%0=0\";
- }
- else
- return \"%w0=%1\;%0=0\";
- default:
- abort();
- }
- }"
- [(set_attr "type" "data_move_2,data_move_2,data_move_2")])
-
-;;
-;; Floating point conversions
-;;
-(define_expand "floathihf2"
- [(set (match_operand:HF 0 "register_operand" "")
- (float:HF (match_operand:HI 1 "register_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_floathihf2_libcall)
- dsp16xx_floathihf2_libcall = gen_rtx_SYMBOL_REF (Pmode, FLOATHIHF2_LIBCALL);
-
- emit_library_call (dsp16xx_floathihf2_libcall, 1, HFmode, 1,
- operands[1], HImode);
- emit_move_insn (operands[0], hard_libcall_value(HFmode));
- DONE;
-}")
-
-(define_expand "fix_trunchfhi2"
- [(set (match_operand:HI 0 "register_operand" "")
- (fix:HI (match_operand:HF 1 "register_operand" "")))]
- ""
- "
-{
- if (!dsp16xx_fixhfhi2_libcall)
- dsp16xx_fixhfhi2_libcall = gen_rtx_SYMBOL_REF (Pmode, FIXHFHI2_LIBCALL);
-
- emit_library_call (dsp16xx_fixhfhi2_libcall, 1, HImode, 1,
- operands[1], HFmode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-}")
-
-(define_expand "fixuns_trunchfhi2"
- [(set (match_operand:HI 0 "register_operand" "")
- (unsigned_fix:HI (match_operand:HF 1 "register_operand" "")))]
- ""
- "
-{
- rtx reg1 = gen_reg_rtx (HFmode);
- rtx reg2 = gen_reg_rtx (HFmode);
- rtx reg3 = gen_reg_rtx (HImode);
- rtx label1 = gen_label_rtx ();
- rtx label2 = gen_label_rtx ();
- REAL_VALUE_TYPE offset;
-
- real_2expN (&offset, 31);
-
- if (reg1) /* turn off complaints about unreached code */
- {
- emit_move_insn (reg1, CONST_DOUBLE_FROM_REAL_VALUE (offset, HFmode));
- do_pending_stack_adjust ();
-
- emit_insn (gen_cmphf (operands[1], reg1));
- emit_jump_insn (gen_bge (label1));
-
- emit_insn (gen_fix_trunchfhi2 (operands[0], operands[1]));
- emit_jump_insn (gen_rtx_SET (VOIDmode, pc_rtx,
- gen_rtx_LABEL_REF (VOIDmode, label2)));
- emit_barrier ();
-
- emit_label (label1);
- emit_insn (gen_subhf3 (reg2, operands[1], reg1));
- emit_move_insn (reg3, GEN_INT (0x80000000));;
-
- emit_insn (gen_fix_trunchfhi2 (operands[0], reg2));
- emit_insn (gen_iorhi3 (operands[0], operands[0], reg3));
-
- emit_label (label2);
-
- /* allow REG_NOTES to be set on last insn (labels don't have enough
- fields, and can't be used for REG_NOTES anyway). */
- emit_insn (gen_rtx_USE (VOIDmode, stack_pointer_rtx));
- DONE;
- }
-}")
-
-;;
-;; SHIFT INSTRUCTIONS
-;;
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 1)))]
- ""
- "%0=%1>>1"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 4)))]
- ""
- "%0=%1>>4"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 8)))]
- ""
- "%0=%1>>8"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 16)))]
- ""
- "%0=%1>>16"
- [(set_attr "type" "special")])
-\f
-;;
-;; Arithmetic Right shift
-
-(define_expand "ashrhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (ashiftrt:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!TARGET_BMU)
- {
- /* If we are shifting by a constant we can do it in 1 or more
- 1600 core shift instructions. The core instructions can
- shift by 1, 4, 8, or 16. */
-
- if (GET_CODE(operands[2]) == CONST_INT)
- ;
- else
- {
- rtx label1 = gen_label_rtx ();
- rtx label2 = gen_label_rtx ();
-
-#if 0
- if (!dsp16xx_ashrhi3_libcall)
- dsp16xx_ashrhi3_libcall
- = gen_rtx_SYMBOL_REF (Pmode, ASHRHI3_LIBCALL);
-
- emit_library_call (dsp16xx_ashrhi3_libcall, 1, HImode, 2,
- operands[1], HImode,
- operands[2], QImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-#else
- do_pending_stack_adjust ();
- emit_insn (gen_tstqi (operands[2]));
- emit_jump_insn (gen_bne (label1));
- emit_move_insn (operands[0], operands[1]);
- emit_jump_insn (gen_jump (label2));
- emit_barrier ();
- emit_label (label1);
-
- if (GET_CODE(operands[2]) != MEM)
- {
- rtx stack_slot;
-
- stack_slot = assign_stack_temp (QImode, GET_MODE_SIZE(QImode), 0);
- stack_slot = change_address (stack_slot, VOIDmode, XEXP (stack_slot, 0));
- emit_move_insn (stack_slot, operands[2]);
- operands[2] = stack_slot;
- }
-
- emit_insn (gen_match_ashrhi3_nobmu (operands[0], operands[1], operands[2]));
- emit_label (label2);
- DONE;
-#endif
- }
- }
-}")
-
-(define_insn "match_ashrhi3_bmu"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A")
- (ashiftrt:HI (match_operand:HI 1 "register_operand" "A,A,!A")
- (match_operand:QI 2 "nonmemory_operand" "B,I,h")))]
- "TARGET_BMU"
- "@
- %0=%1>>%2
- %0=%1>>%H2
- %0=%1>>%2"
- [(set_attr "type" "shift,shift_i,shift")])
-
-(define_insn "match_ashrhi3_nobmu"
- [(set (match_operand:HI 0 "register_operand" "=A,A")
- (ashiftrt:HI (match_operand:HI 1 "register_operand" "A,0")
- (match_operand:QI 2 "general_operand" "n,m")))]
- "!TARGET_BMU"
- "*
-{
- if (which_alternative == 0)
- {
- emit_1600_core_shift (ASHIFTRT, operands, INTVAL(operands[2]));
- return \"\";
- }
- else
- {
- output_asm_insn (\"cloop=%2\", operands);
- output_asm_insn (\"do 0 {\", operands);
- output_asm_insn (\"%0=%0>>1\", operands);
- return \"}\";
- }
-}")
-
-
-\f
-;;
-;; Logical Right Shift
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (lshiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 1)))]
- "!TARGET_BMU"
- "%0=%1>>1\;%0=%b0&0x7fff"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (lshiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 4)))]
- "!TARGET_BMU"
- "%0=%1>>4\;%0=%b0&0x0fff"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (lshiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 8)))]
- "!TARGET_BMU"
- "%0=%1>>8\;%0=%b0&0x00ff"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (lshiftrt:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 16)))]
- "!TARGET_BMU"
- "%0=%1>>16\;%0=%b0&0x0000"
- [(set_attr "type" "special")])
-
-(define_expand "lshrhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (lshiftrt:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!TARGET_BMU)
- {
- /* If we are shifting by a constant we can do it in 1 or more
- 1600 core shift instructions. The core instructions can
- shift by 1, 4, 8, or 16. */
-
- if (GET_CODE(operands[2]) == CONST_INT)
- emit_insn (gen_match_lshrhi3_nobmu (operands[0], operands[1], operands[2]));
- else
- {
- rtx label1 = gen_label_rtx ();
- rtx label2 = gen_label_rtx ();
-#if 0
- if (!dsp16xx_lshrhi3_libcall)
- dsp16xx_lshrhi3_libcall
- = gen_rtx_SYMBOL_REF (Pmode, LSHRHI3_LIBCALL);
-
- emit_library_call (dsp16xx_lshrhi3_libcall, 1, HImode, 2,
- operands[1], HImode,
- operands[2], QImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-#else
- do_pending_stack_adjust ();
- emit_insn (gen_tstqi (operands[2]));
- emit_jump_insn (gen_bne (label1));
- emit_move_insn (operands[0], operands[1]);
- emit_jump_insn (gen_jump (label2));
- emit_barrier ();
- emit_label (label1);
-
- if (GET_CODE(operands[2]) != MEM)
- {
- rtx stack_slot;
-
- stack_slot = assign_stack_temp (QImode, GET_MODE_SIZE(QImode), 0);
- stack_slot = change_address (stack_slot, VOIDmode, XEXP (stack_slot, 0));
- emit_move_insn (stack_slot, operands[2]);
- operands[2] = stack_slot;
- }
-
- emit_insn (gen_match_lshrhi3_nobmu (operands[0], operands[1], operands[2]));
- emit_label (label2);
- DONE;
-#endif
- }
- }
-}")
-
-(define_insn "match_lshrhi3"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A")
- (lshiftrt:HI (match_operand:HI 1 "register_operand" "A,A,!A")
- (match_operand:QI 2 "nonmemory_operand" "B,I,h")))]
- "TARGET_BMU"
- "@
- %0=%1>>>%2
- %0=%1>>>%H2
- %0=%1>>>%2"
- [(set_attr "type" "shift,shift_i,shift")])
-
-(define_insn "match_lshrhi3_nobmu"
- [(set (match_operand:HI 0 "register_operand" "=A,A")
- (lshiftrt:HI (match_operand:HI 1 "register_operand" "A,0")
- (match_operand:QI 2 "general_operand" "n,m")))
- (clobber (match_scratch:QI 3 "=X,Y"))]
- "!TARGET_BMU"
- "*
-{
- if (which_alternative == 0)
- {
- emit_1600_core_shift (LSHIFTRT, operands, INTVAL(operands[2]));
- return \"\";
- }
- else
- {
- output_asm_insn (\"%3=psw\;psw=0\",operands);
- output_asm_insn (\"cloop=%2\", operands);
- output_asm_insn (\"do 0 {\", operands);
- output_asm_insn (\"%0=%0>>1\", operands);
- output_asm_insn (\"}\", operands);
- return \"psw=%3\";
- }
-}")
-
-\f
-;;
-;; Arithmetic Left shift
-
-;; Start off with special case arithmetic left shift by 1,4,8 or 16.
-
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashift:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 1)))]
- ""
- "%0=%1<<1"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashift:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 4)))]
- ""
- "%0=%1<<4"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashift:HI (match_operand:HI 1 "register_operand" "A")
- (const_int 8)))]
- ""
- "%0=%1<<8"
- [(set_attr "type" "special")])
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=A")
- (ashift:HI (match_operand:HI 1 "general_operand" "A")
- (const_int 16)))]
- ""
- "%0=%1<<16"
- [(set_attr "type" "special")])
-
-
-\f
-;; Normal Arithmetic Shift Left
-
-
-(define_expand "ashlhi3"
- [(set (match_operand:HI 0 "register_operand" "")
- (ashift:HI (match_operand:HI 1 "register_operand" "")
- (match_operand:QI 2 "nonmemory_operand" "")))]
- ""
- "
-{
- if (!TARGET_BMU)
- {
- /* If we are shifting by a constant we can do it in 1 or more
- 1600 core shift instructions. The core instructions can
- shift by 1, 4, 8, or 16. */
-
- if (GET_CODE(operands[2]) == CONST_INT)
- ;
- else
- {
- rtx label1 = gen_label_rtx ();
- rtx label2 = gen_label_rtx ();
-#if 0
- if (!dsp16xx_ashlhi3_libcall)
- dsp16xx_ashlhi3_libcall
- = gen_rtx_SYMBOL_REF (Pmode, ASHLHI3_LIBCALL);
-
- emit_library_call (dsp16xx_ashlhi3_libcall, 1, HImode, 2,
- operands[1], HImode, operands[2], QImode);
- emit_move_insn (operands[0], hard_libcall_value(HImode));
- DONE;
-#else
- do_pending_stack_adjust ();
- emit_insn (gen_tstqi (operands[2]));
- emit_jump_insn (gen_bne (label1));
- emit_move_insn (operands[0], operands[1]);
- emit_jump_insn (gen_jump (label2));
- emit_barrier ();
- emit_label (label1);
-
- if (GET_CODE(operands[2]) != MEM)
- {
- rtx stack_slot;
-
- stack_slot = assign_stack_temp (QImode, GET_MODE_SIZE(QImode), 0);
- stack_slot = change_address (stack_slot, VOIDmode, XEXP (stack_slot, 0));
- emit_move_insn (stack_slot, operands[2]);
- operands[2] = stack_slot;
- }
- emit_insn (gen_match_ashlhi3_nobmu (operands[0], operands[1], operands[2]));
- emit_label (label2);
- DONE;
-#endif
- }
- }
-}")
-
-(define_insn "match_ashlhi3"
- [(set (match_operand:HI 0 "register_operand" "=A,A,A")
- (ashift:HI (match_operand:HI 1 "register_operand" "A,A,A")
- (match_operand:QI 2 "nonmemory_operand" "B,I,!h")))]
- "TARGET_BMU"
- "@
- %0=%1<<%2\;move %u0=%u0
- %0=%1<<%H2\;move %u0=%u0
- %0=%1<<%2\;move %u0=%u0"
- [(set_attr "type" "shift_multiple,shift_multiple,shift_multiple")])
-
-(define_insn "match_ashlhi3_nobmu"
- [(set (match_operand:HI 0 "register_operand" "=A,A")
- (ashift:HI (match_operand:HI 1 "register_operand" "A,0")
- (match_operand:QI 2 "general_operand" "n,m")))]
- "!TARGET_BMU"
- "*
-{
- if (which_alternative == 0)
- {
- emit_1600_core_shift (ASHIFT, operands, INTVAL(operands[2]));
- return \"\";
- }
- else
- {
- output_asm_insn (\"cloop=%2\", operands);
- output_asm_insn (\"do 0 {\", operands);
- output_asm_insn (\"%0=%0<<1\", operands);
- return \"}\";
- }
-}")
-
-\f
-
-
-(define_insn "extv"
- [(set (match_operand:QI 0 "register_operand" "=k,u")
- (sign_extract:QI (match_operand:QI 1 "register_operand" "ku,ku")
- (match_operand:QI 2 "const_int_operand" "n,n")
- (match_operand:QI 3 "const_int_operand" "n,n")))
- (clobber (match_scratch:QI 4 "=j,q"))]
- "TARGET_BMU"
- "*
-{
- operands[5]
- = GEN_INT ((INTVAL (operands[2]) << 8) + (INTVAL (operands[3]) & 0xff));
- return \"%m0 = extracts (%m1, %H5)\";
-}"
-[(set_attr "type" "shift_i")])
-
-(define_insn "extzv"
- [(set (match_operand:QI 0 "register_operand" "=k,u")
- (zero_extract:QI (match_operand:QI 1 "register_operand" "ku,ku")
- (match_operand:QI 2 "const_int_operand" "n,n")
- (match_operand:QI 3 "const_int_operand" "n,n")))
- (clobber (match_scratch:QI 4 "=j,q"))]
- "TARGET_BMU"
- "*
-{
- operands[5]
- = GEN_INT ((INTVAL (operands[2]) << 8) + (INTVAL (operands[3]) & 0xff));
- return \"%m0 = extractz (%m1, %H5)\";
-}"
-[(set_attr "type" "shift_i")])
-
-;;
-;; conditional instructions
-;;
-
-(define_expand "seq"
- [(set (match_operand:QI 0 "register_operand" "")
- (eq:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (EQ, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-(define_expand "sne"
- [(set (match_operand:QI 0 "register_operand" "")
- (ne:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (NE, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "sgt"
- [(set (match_operand:QI 0 "register_operand" "")
- (gt:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GT, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "slt"
- [(set (match_operand:QI 0 "register_operand" "")
- (lt:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LT, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-(define_expand "sge"
- [(set (match_operand:QI 0 "register_operand" "")
- (ge:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GE, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "sle"
- [(set (match_operand:QI 0 "register_operand" "")
- (le:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LE, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "sgtu"
- [(set (match_operand:QI 0 "register_operand" "")
- (gtu:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GTU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "sltu"
- [(set (match_operand:QI 0 "register_operand" "")
- (ltu:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LTU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "sgeu"
- [(set (match_operand:QI 0 "register_operand" "")
- (geu:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GEU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "sleu"
- [(set (match_operand:QI 0 "register_operand" "")
- (leu:QI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LEU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_insn "scc"
- [(set (match_operand:QI 0 "register_operand" "=jq")
- (match_operator:QI 1 "comparison_operator" [(cc0) (const_int 0)]))]
- ""
- "%0 = 0\;if %C1 %b0 = %b0 + 1"
- [(set_attr "type" "special_2")])
-
-;;
-;; Jump Instructions
-;;
-
-(define_expand "beq"
- [(set (pc)
- (if_then_else (eq (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (EQ, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-(define_expand "bne"
- [(set (pc)
- (if_then_else (ne (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (NE, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "bgt"
- [(set (pc)
- (if_then_else (gt (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GT, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "bge"
- [(set (pc)
- (if_then_else (ge (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GE, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "blt"
- [(set (pc)
- (if_then_else (lt (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LT, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "ble"
- [(set (pc)
- (if_then_else (le (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LE, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "bgtu"
- [(set (pc)
- (if_then_else (gtu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GTU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "bgeu"
- [(set (pc)
- (if_then_else (geu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (GEU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "bltu"
- [(set (pc)
- (if_then_else (ltu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LTU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_expand "bleu"
- [(set (pc)
- (if_then_else (leu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{
- if (dsp16xx_compare_gen)
- operands[1] = gen_compare_reg (LEU, dsp16xx_compare_op0, dsp16xx_compare_op1);
- else
- operands[1] = gen_tst_reg (dsp16xx_compare_op0);
-}")
-
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 1 "comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- "!TARGET_NEAR_JUMP"
- "pt=%l0\;if %C1 goto pt"
- [(set_attr "type" "cond_jump")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 1 "comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- "TARGET_NEAR_JUMP"
- "if %C1 goto %l0"
- [(set_attr "type" "cond_jump")])
-\f
-;;
-;; Negated conditional jump instructions.
-;; These are necessary because jump optimization can turn
-;; direct-conditional branches into reverse-conditional
-;; branches.
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 1 "comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 0 "" ""))))]
- "!TARGET_NEAR_JUMP"
- "pt=%l0\;if %I1 goto pt"
- [(set_attr "type" "cond_jump")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 1 "comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 0 "" ""))))]
- "TARGET_NEAR_JUMP"
- "if %I1 goto %l0"
- [(set_attr "type" "cond_jump")])
-
-
-;;
-;; JUMPS
-;;
-
-(define_insn "jump"
- [(set (pc)
- (label_ref (match_operand 0 "" "")))]
- ""
- "*
- {
- if (TARGET_NEAR_JUMP)
- return \"goto %l0\";
- else
- return \"pt=%l0\;goto pt\";
- }"
- [(set_attr "type" "jump")])
-
-
-(define_insn "indirect_jump"
- [(set (pc) (match_operand:QI 0 "register_operand" "A"))]
- ""
- "pt=%0\;goto pt"
- [(set_attr "type" "jump")])
-
-(define_insn "tablejump"
- [(set (pc) (match_operand:QI 0 "register_operand" "A"))
- (use (label_ref (match_operand 1 "" "")))]
- ""
- "pt=%0\;goto pt"
- [(set_attr "type" "jump")])
-\f
-;;
-;; FUNCTION CALLS
-;;
-
-;; Call subroutine with no return value.
-
-
-(define_expand "call"
- [(parallel [(call (match_operand:QI 0 "" "")
- (match_operand 1 "" ""))
- (clobber (reg:QI 24))])]
- ""
- "
-{
- if (GET_CODE (operands[0]) == MEM
- && ! call_address_operand (XEXP (operands[0], 0), QImode))
- operands[0] = gen_rtx_MEM (GET_MODE (operands[0]),
- force_reg (Pmode, XEXP (operands[0], 0)));
-}")
-
-(define_insn ""
- [(parallel [(call (mem:QI (match_operand:QI 0 "call_address_operand" "hR"))
- (match_operand 1 "" ""))
- (clobber (reg:QI 24))])]
- ""
- "*
-{
- if (GET_CODE (operands[0]) == REG ||
- (GET_CODE(operands[0]) == SYMBOL_REF && !TARGET_NEAR_CALL))
- return \"pt=%0\;call pt\";
- else
- return \"call %0\";
-}"
-[(set_attr "type" "call")])
-
-;; Call subroutine with return value.
-
-(define_expand "call_value"
- [(parallel [(set (match_operand 0 "register_operand" "=f")
- (call (match_operand:QI 1 "call_address_operand" "hR")
- (match_operand:QI 2 "" "")))
- (clobber (reg:QI 24))])]
- ""
- "
-{
- if (GET_CODE (operands[1]) == MEM
- && ! call_address_operand (XEXP (operands[1], 0), QImode))
- operands[1] = gen_rtx_MEM (GET_MODE (operands[1]),
- force_reg (Pmode, XEXP (operands[1], 0)));
-}")
-
-(define_insn ""
- [(parallel [(set (match_operand 0 "register_operand" "=f")
- (call (mem:QI (match_operand:QI 1 "call_address_operand" "hR"))
- (match_operand:QI 2 "" "")))
- (clobber (reg:QI 24))])]
- ""
- "*
-{
- if (GET_CODE (operands[1]) == REG ||
- (GET_CODE(operands[1]) == SYMBOL_REF && !TARGET_NEAR_CALL))
- return \"pt=%1\;call pt\";
- else
- return \"call %1\";
-}"
-[(set_attr "type" "call")])
-
-
-(define_expand "untyped_call"
- [(parallel [(call (match_operand 0 "" "")
- (const_int 0))
- (match_operand 1 "" "")
- (match_operand 2 "" "")])]
- ""
- "
-{
- int i;
-
- emit_call_insn (GEN_CALL (operands[0], const0_rtx, NULL, const0_rtx));
-
- for (i = 0; i < XVECLEN (operands[2], 0); i++)
- {
- rtx set = XVECEXP (operands[2], 0, i);
- emit_move_insn (SET_DEST (set), SET_SRC (set));
- }
-
- /* The optimizer does not know that the call sets the function value
- registers we stored in the result block. We avoid problems by
- claiming that all hard registers are used and clobbered at this
- point. */
- emit_insn (gen_blockage ());
-
- DONE;
-}")
-
-;; UNSPEC_VOLATILE is considered to use and clobber all hard registers and
-;; all of memory. This blocks insns from being moved across this point.
-
-(define_insn "blockage"
- [(unspec_volatile [(const_int 0)] 0)]
- ""
- "")
-
-(define_insn "nop"
- [(const_int 0)]
- ""
- "nop"
- [(set_attr "type" "nop")])
-\f
-;;
-;; PEEPHOLE PATTERNS
-;;
-
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "k,k,!k,u,u,!u")
- (match_operand:QI 1 "register_operand" "w,z,u,w,z,k")))
- (use (match_operand:QI 2 "register_operand" "=j,j,j,q,q,q"))
- (use (match_operand:QI 3 "register_operand" "=v,y,q,v,y,j"))])
- (set (pc)
- (if_then_else (match_operator 5 "uns_comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 4 "" ""))
- (pc)))]
- "!TARGET_NEAR_JUMP"
- "pt=%l4\;%2-%3\;if %C5 goto pt")
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "k,k,!k,u,u,!u")
- (match_operand:QI 1 "register_operand" "w,z,u,w,z,k")))
- (use (match_operand:QI 2 "register_operand" "=j,j,j,q,q,q"))
- (use (match_operand:QI 3 "register_operand" "=v,y,q,v,y,j"))])
- (set (pc)
- (if_then_else (match_operator 5 "uns_comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 4 "" ""))))]
- "!TARGET_NEAR_JUMP"
- "pt=%l4\;%2-%3\;if %I5 goto pt")
-
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "k,u")
- (match_operand:QI 1 "const_int_operand" "i,i")))
- (use (match_operand:QI 2 "register_operand" "=j,q"))])
- (set (pc)
- (if_then_else (match_operator 4 "uns_comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 3 "" ""))
- (pc)))]
- "!TARGET_NEAR_JUMP"
- "pt=%l3\;%0-%H1\;if %C4 goto pt")
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "k,u")
- (match_operand:QI 1 "const_int_operand" "i,i")))
- (use (match_operand:QI 2 "register_operand" "=j,q"))])
- (set (pc)
- (if_then_else (match_operator 4 "uns_comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 3 "" ""))))]
- "!TARGET_NEAR_JUMP"
- "pt=%l3\;%0-%H1\;if %I4 goto pt")
-
-;;
-;;; QImode SIGNED COMPARE PEEPHOLE OPTIMIZATIONS
-;;
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "j,j,h,q,q,q")
- (match_operand:QI 1 "register_operand" "v,y,q,v,y,j")))
- (use (match_operand:QI 2 "register_operand" "=k,k,k,u,u,u"))
- (use (match_operand:QI 3 "register_operand" "=w,z,u,w,z,k"))])
- (set (pc)
- (if_then_else (match_operator 5 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 4 "" ""))
- (pc)))]
- "!TARGET_NEAR_JUMP"
- "pt=%l4\;%0-%1\;if %C5 goto pt")
-
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "j,j,j,q,q,q")
- (match_operand:QI 1 "register_operand" "v,y,q,v,y,j")))
- (use (match_operand:QI 2 "register_operand" "=k,k,k,u,u,u"))
- (use (match_operand:QI 3 "register_operand" "=w,z,u,w,z,k"))])
- (set (pc)
- (if_then_else (match_operator 5 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 4 "" ""))))]
- "!TARGET_NEAR_JUMP"
- "pt=%l4\;%0-%1\;if %I5 goto pt")
-
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "j,q")
- (match_operand:QI 1 "const_int_operand" "i,i")))
- (use (match_operand:QI 2 "register_operand" "=k,u"))])
- (set (pc)
- (if_then_else (match_operator 4 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 3 "" ""))
- (pc)))]
- "!TARGET_NEAR_JUMP"
- "pt=%l3\;%b0-%H1\;if %C4 goto pt")
-
-(define_peephole
- [(parallel [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "j,q")
- (match_operand:QI 1 "const_int_operand" "i,i")))
- (use (match_operand:QI 2 "register_operand" "=k,u"))])
- (set (pc)
- (if_then_else (match_operator 4 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 3 "" ""))))]
- "!TARGET_NEAR_JUMP"
- "pt=%l3\;%b0-%H1\;if %I4 goto pt")
-
-;; TST PEEPHOLE PATTERNS
-
-(define_peephole
- [(parallel [(set (cc0)
- (match_operand:QI 0 "register_operand" "j,q"))
- (use (match_operand:QI 1 "register_operand" "=k,u"))])
- (set (pc)
- (if_then_else (match_operator 3 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 2 "" ""))))]
- "!TARGET_NEAR_JUMP"
- "pt=%l2\;%b0-0\;if %I3 goto pt")
-
-(define_peephole
- [(parallel [(set (cc0)
- (match_operand:QI 0 "register_operand" "j,q"))
- (use (match_operand:QI 1 "register_operand" "=k,u"))])
- (set (pc)
- (if_then_else (match_operator 3 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 2 "" ""))
- (pc)))]
- "!TARGET_NEAR_JUMP"
- "pt=%l2\;%b0-0\;if %C3 goto pt")
-
-;; HImode peephole patterns
-
-(define_peephole
- [(set (cc0)
- (compare (match_operand:HI 0 "register_operand" "A,A")
- (match_operand:HI 1 "register_operand" "Z,A")))
- (set (pc)
- (if_then_else (match_operator 3 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (label_ref (match_operand 2 "" ""))
- (pc)))]
- "!TARGET_NEAR_JUMP"
- "pt=%l2\;%0-%1\;if %C3 goto pt")
-
-(define_peephole
- [(set (cc0)
- (compare (match_operand:HI 0 "register_operand" "A,A")
- (match_operand:HI 1 "register_operand" "Z,A")))
- (set (pc)
- (if_then_else (match_operator 3 "signed_comparison_operator"
- [(cc0) (const_int 0)])
- (pc)
- (label_ref (match_operand 2 "" ""))))]
- "!TARGET_NEAR_JUMP"
- "pt=%l2\;%0-%1\;if %I3 goto pt")
+++ /dev/null
-
-This directory contains code for building a compiler for the
-32-bit ESA/390 architecture. It supports three different styles
-of assembly:
-
--- MVS for use with the HLASM assembler
--- Open Edition (USS Unix System Services)
--- ELF/Linux for use with the binutils/gas GNU assembler.
-
-
-Cross-compiling Hints
----------------------
-When building a cross-compiler on AIX, set the environment variable CC
-and be sure to set the -ma and -qcpluscmt flags; i.e.
-
- export CC="cc -ma -qcpluscmt"
-
-do this *before* running configure, e.g.
-
- configure --target=i370-ibm-linux --prefix=/where/to/install/usr
-
-The Objective-C and FORTRAN front ends don't build. To avoid looking at
-errors, do only
-
- make LANGUAGES=c
-
-
-OpenEdition Hints
------------------
-The shell script "install" is handy for users of OpenEdition.
-
-
-The ELF ABI
------------
-This compiler, in conjunction with the gas/binutils assembler, defines
-a defacto ELF-based ABI for the ESA/390 architecture. Be warned: this
-ABI has several major faults. It should be fixed. As it is fixed,
-it is subject to change without warning. You should not commit to major
-software systems without further exploring and fixing these problems.
-Here are some of the problems:
-
--- No support for shared libraries or dynamically loadable objects.
- This is because the compiler currently places address literals in
- the text section. Although the GAS assembler supports a syntax for
- USING that will place address literals in the data section, this forces
- the use of two base registers, one for branches and one for the literal
- pool. Work is needed to redesign the function prologue, epilogue and the
- base register reloads to minimize the currently excessive use of reserved
- registers.
-
- I beleive the best solution would be to add a toc or plt, and extending
- the meaning of the USING directive to encompass this. This would
- allow the continued use of the human-readable and familiar practice
- of using =A() and =F'' to denote address literals, as opposed to more
- difficult jump-table notation.
-
--- the stackframe is almost twice as big as it needs to be.
-
--- currently, r15 is used to return 32-bit values. Because this is the
- last register, it prevents 64-bit ints and small structures from being
- returned in registers, forcing return in memory. It would be more
- efficient to use r14 to return 32-bit values, and r14+r15 to return
- 64-bit values.
-
--- all arguments are currently passed in memory. It would be more efficient
- to pass arguments in registers.
-
-
-
-
-ChangeLog
----------
-Oct98-Dec98 -- add ELF back end; work on getting ABI more or less functional.
-98.12.05 -- fix numerous MVC bugs
-99.02.06 -- multiply insn sometimes not generated when needed.
- -- extendsidi bugs, bad literal values printed
- -- remove broken adddi subdi patterns
-99.02.15 -- add clrstrsi pattern
- -- fix -O2 divide bug
-99.03.04 -- base & index reg usage bugs
-99.03.15 -- fixes for returning long longs and structs (struct value return)
-99.03.29 -- fix handling & alignment of shorts
-99.03.31 -- clobbered register 14 is not always clobbered
-99.04.02 -- operand constraints for cmphi
-99.04.07 -- function pointer fixes for call, call_value patterns,
- function pointers derefed once too often.
-99.04.14 -- add pattern to print double-wide int
- -- check intval<4096 for misc operands
- -- add clrstrsi pattern
- -- movstrsi fixes
-99.04.16 -- use r2 to pass args into r11 in subroutine call.
- -- fixes to movsi; some operand combinations impossible;
- rework constraints
- -- start work on forward jump optimization
- -- char alignment bug
-99.04.25 -- add untyped_call pattern so that builtin_apply works
-99.04.27 -- fixes to compare logical under mask
-99.04.28 -- reg 2 is clobbered by calls
-99.04.30 -- fix rare mulsi bug
-99.04.30 -- add constraints so that all RS, SI, SS forms insns have valid
- addressing modes
-99.04.30 -- major condition code fixes. The old code was just way off
- w.r.t. which insns set condition code, and the codes that
- were set. The extent of this damage was unbeleivable.
-99.05.01 -- restructuring of operand constraints on many patterns,
- many lead to invalid instructions being genned.
-99.05.02 -- float pt fixes
- -- fix movdi issue bugs
-99.05.03 -- fix divide insn; was dividing incorrectly
-99.05.05 -- fix sign extension problems on andhi
- -- deprecate some constraints
-99.05.06 -- add set_attr insn lengths; fix misc litpool sizes
- -- add notes about how unsigned jumps work (i.e.
- arithmetic vs. logical vs. signed vs unsigned).
-99.05.11 -- use insn length to predict forward branch target;
- use relative branchining where possible,
- remove un-needed base register reload.
-99.05.15 -- fix movstrsi, clrstrsi, cmpstrsi patterns as per conversation
- w/ Richard Henderson
-
-
-
-
-
-
+++ /dev/null
-/* Subroutines for the C front end for System/370.
- Copyright (C) 1989, 1993, 1995, 1997, 1998, 1999, 2000
- Free Software Foundation, Inc.
- Contributed by Jan Stein (jan@cd.chalmers.se).
- Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
- Hacked for Linux-ELF/390 by Linas Vepstas (linas@linas.org)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "tree.h"
-#include "toplev.h"
-#include "cpplib.h"
-#include "c-pragma.h"
-#include "tm_p.h"
-
-#ifdef TARGET_HLASM
-
-/* #pragma map (name, alias) -
- In this implementation both name and alias are required to be
- identifiers. The older code seemed to be more permissive. Can
- anyone clarify? */
-
-void
-i370_pr_map (pfile)
- cpp_reader *pfile ATTRIBUTE_UNUSED;
-{
- tree name, alias, x;
-
- if (c_lex (&x) == CPP_OPEN_PAREN
- && c_lex (&name) == CPP_NAME
- && c_lex (&x) == CPP_COMMA
- && c_lex (&alias) == CPP_NAME
- && c_lex (&x) == CPP_CLOSE_PAREN)
- {
- if (c_lex (&x) != CPP_EOF)
- warning ("junk at end of #pragma map");
-
- mvs_add_alias (IDENTIFIER_POINTER (name), IDENTIFIER_POINTER (alias), 1);
- return;
- }
-
- warning ("malformed #pragma map, ignored");
-}
-
-#endif
+++ /dev/null
-/* Definitions of target machine for GNU compiler. System/370 version.
- Copyright (C) 2000 Free Software Foundation, Inc.
- Contributed by Jan Stein (jan@cd.chalmers.se).
- Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
- Hacked for Linux-ELF/390 by Linas Vepstas (linas@linas.org)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#ifndef GCC_I370_PROTOS_H
-#define GCC_I370_PROTOS_H
-
-extern void override_options (void);
-
-#ifdef RTX_CODE
-extern int i370_branch_dest (rtx);
-extern int i370_branch_length (rtx);
-extern int i370_short_branch (rtx);
-extern int s_operand (rtx, enum machine_mode);
-extern int r_or_s_operand (rtx, enum machine_mode);
-extern int unsigned_jump_follows_p (rtx);
-#endif /* RTX_CODE */
-
-#ifdef TREE_CODE
-extern int handle_pragma (int (*)(void), void (*)(int), const char *);
-#endif /* TREE_CODE */
-
-extern void mvs_add_label (int);
-extern int mvs_check_label (int);
-extern int mvs_check_page (FILE *, int, int);
-extern int mvs_function_check (const char *);
-extern void mvs_add_alias (const char *, const char *, int);
-extern int mvs_need_alias (const char *);
-extern int mvs_get_alias (const char *, char *);
-extern int mvs_check_alias (const char *, char *);
-extern void check_label_emit (void);
-extern void mvs_free_label_list (void);
-
-extern void i370_pr_map (struct cpp_reader *);
-
-#endif /* ! GCC_I370_PROTOS_H */
+++ /dev/null
-/* Subroutines for insn-output.c for System/370.
- Copyright (C) 1989, 1993, 1995, 1997, 1998, 1999, 2000, 2002
- Free Software Foundation, Inc.
- Contributed by Jan Stein (jan@cd.chalmers.se).
- Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
- Hacked for Linux-ELF/390 by Linas Vepstas (linas@linas.org)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "rtl.h"
-#include "tree.h"
-#include "regs.h"
-#include "hard-reg-set.h"
-#include "real.h"
-#include "insn-config.h"
-#include "conditions.h"
-#include "output.h"
-#include "insn-attr.h"
-#include "function.h"
-#include "expr.h"
-#include "flags.h"
-#include "recog.h"
-#include "toplev.h"
-#include "cpplib.h"
-#include "tm_p.h"
-#include "target.h"
-#include "target-def.h"
-
-extern FILE *asm_out_file;
-
-/* Label node. This structure is used to keep track of labels
- on the various pages in the current routine.
- The label_id is the numeric ID of the label,
- The label_page is the page on which it actually appears,
- The first_ref_page is the page on which the true first ref appears.
- The label_addr is an estimate of its location in the current routine,
- The label_first & last_ref are estimates of where the earliest and
- latest references to this label occur. */
-
-typedef struct label_node
- {
- struct label_node *label_next;
- int label_id;
- int label_page;
- int first_ref_page;
-
- int label_addr;
- int label_first_ref;
- int label_last_ref;
- }
-label_node_t;
-
-/* Is 1 when a label has been generated and the base register must be reloaded. */
-int mvs_need_base_reload = 0;
-
-/* Current function starting base page. */
-int function_base_page;
-
-/* Length of the current page code. */
-int mvs_page_code;
-
-/* Length of the current page literals. */
-int mvs_page_lit;
-
-/* Current function name. */
-char *mvs_function_name = 0;
-
-/* Current function name length. */
-size_t mvs_function_name_length = 0;
-
-/* Page number for multi-page functions. */
-int mvs_page_num = 0;
-
-/* Label node list anchor. */
-static label_node_t *label_anchor = 0;
-
-/* Label node free list anchor. */
-static label_node_t *free_anchor = 0;
-
-/* Assembler source file descriptor. */
-static FILE *assembler_source = 0;
-
-static label_node_t * mvs_get_label (int);
-static void i370_label_scan (void);
-#ifdef TARGET_HLASM
-static bool i370_hlasm_assemble_integer (rtx, unsigned int, int);
-static void i370_globalize_label (FILE *, const char *);
-#endif
-static void i370_output_function_prologue (FILE *, HOST_WIDE_INT);
-static void i370_output_function_epilogue (FILE *, HOST_WIDE_INT);
-static void i370_file_start (void);
-static void i370_file_end (void);
-
-#ifdef LONGEXTERNAL
-static int mvs_hash_alias (const char *);
-#endif
-static void i370_internal_label (FILE *, const char *, unsigned long);
-static bool i370_rtx_costs (rtx, int, int, int *);
-
-/* ===================================================== */
-/* defines and functions specific to the HLASM assembler */
-#ifdef TARGET_HLASM
-
-#define MVS_HASH_PRIME 999983
-#if HOST_CHARSET == HOST_CHARSET_EBCDIC
-#define MVS_SET_SIZE 256
-#else
-#define MVS_SET_SIZE 128
-#endif
-
-#ifndef MAX_MVS_LABEL_SIZE
-#define MAX_MVS_LABEL_SIZE 8
-#endif
-
-#define MAX_LONG_LABEL_SIZE 255
-
-/* Alias node, this structure is used to keep track of aliases to external
- variables. The IBM assembler allows an alias to an external name
- that is longer that 8 characters; but only once per assembly.
- Also, this structure stores the #pragma map info. */
-typedef struct alias_node
- {
- struct alias_node *alias_next;
- int alias_emitted;
- char alias_name [MAX_MVS_LABEL_SIZE + 1];
- char real_name [MAX_LONG_LABEL_SIZE + 1];
- }
-alias_node_t;
-
-/* Alias node list anchor. */
-static alias_node_t *alias_anchor = 0;
-
-/* Define the length of the internal MVS function table. */
-#define MVS_FUNCTION_TABLE_LENGTH 32
-
-/* C/370 internal function table. These functions use non-standard linkage
- and must handled in a special manner. */
-static const char *const mvs_function_table[MVS_FUNCTION_TABLE_LENGTH] =
-{
-#if HOST_CHARSET == HOST_CHARSET_EBCDIC /* Changed for EBCDIC collating sequence */
- "ceil", "edc_acos", "edc_asin", "edc_atan", "edc_ata2", "edc_cos",
- "edc_cosh", "edc_erf", "edc_erfc", "edc_exp", "edc_gamm", "edc_lg10",
- "edc_log", "edc_sin", "edc_sinh", "edc_sqrt", "edc_tan", "edc_tanh",
- "fabs", "floor", "fmod", "frexp", "hypot", "jn",
- "j0", "j1", "ldexp", "modf", "pow", "yn",
- "y0", "y1"
-#else
- "ceil", "edc_acos", "edc_asin", "edc_ata2", "edc_atan", "edc_cos",
- "edc_cosh", "edc_erf", "edc_erfc", "edc_exp", "edc_gamm", "edc_lg10",
- "edc_log", "edc_sin", "edc_sinh", "edc_sqrt", "edc_tan", "edc_tanh",
- "fabs", "floor", "fmod", "frexp", "hypot", "j0",
- "j1", "jn", "ldexp", "modf", "pow", "y0",
- "y1", "yn"
-#endif
-};
-
-#endif /* TARGET_HLASM */
-/* ===================================================== */
-
-\f
-/* Initialize the GCC target structure. */
-#ifdef TARGET_HLASM
-#undef TARGET_ASM_BYTE_OP
-#define TARGET_ASM_BYTE_OP NULL
-#undef TARGET_ASM_ALIGNED_HI_OP
-#define TARGET_ASM_ALIGNED_HI_OP NULL
-#undef TARGET_ASM_ALIGNED_SI_OP
-#define TARGET_ASM_ALIGNED_SI_OP NULL
-#undef TARGET_ASM_INTEGER
-#define TARGET_ASM_INTEGER i370_hlasm_assemble_integer
-#undef TARGET_ASM_GLOBALIZE_LABEL
-#define TARGET_ASM_GLOBALIZE_LABEL i370_globalize_label
-#endif
-
-#undef TARGET_ASM_FUNCTION_PROLOGUE
-#define TARGET_ASM_FUNCTION_PROLOGUE i370_output_function_prologue
-#undef TARGET_ASM_FUNCTION_EPILOGUE
-#define TARGET_ASM_FUNCTION_EPILOGUE i370_output_function_epilogue
-#undef TARGET_ASM_FILE_START
-#define TARGET_ASM_FILE_START i370_file_start
-#undef TARGET_ASM_FILE_END
-#define TARGET_ASM_FILE_END i370_file_end
-#undef TARGET_ASM_INTERNAL_LABEL
-#define TARGET_ASM_INTERNAL_LABEL i370_internal_label
-#undef TARGET_RTX_COSTS
-#define TARGET_RTX_COSTS i370_rtx_costs
-
-struct gcc_target targetm = TARGET_INITIALIZER;
-\f
-/* Set global variables as needed for the options enabled. */
-
-void
-override_options ()
-{
- /* We're 370 floating point, not IEEE floating point. */
- memset (real_format_for_mode, 0, sizeof real_format_for_mode);
- REAL_MODE_FORMAT (SFmode) = &i370_single_format;
- REAL_MODE_FORMAT (DFmode) = &i370_double_format;
-}
-
-/* ===================================================== */
-/* The following three routines are used to determine whther
- forward branch is on this page, or is a far jump. We use
- the "length" attr on an insn [(set_atter "length" "4")]
- to store the largest possible code length that insn
- could have. This gives us a hint of the address of a
- branch destination, and from that, we can work out
- the length of the jump, and whether its on page or not.
- */
-
-/* Return the destination address of a branch. */
-
-int
-i370_branch_dest (branch)
- rtx branch;
-{
- rtx dest = SET_SRC (PATTERN (branch));
- int dest_uid;
- int dest_addr;
-
- /* first, compute the estimated address of the branch target */
- if (GET_CODE (dest) == IF_THEN_ELSE)
- dest = XEXP (dest, 1);
- dest = XEXP (dest, 0);
- dest_uid = INSN_UID (dest);
- dest_addr = INSN_ADDRESSES (dest_uid);
-
- /* next, record the address of this insn as the true addr of first ref */
- {
- label_node_t *lp;
- rtx label = JUMP_LABEL (branch);
- int labelno = CODE_LABEL_NUMBER (label);
-
- if (!label || CODE_LABEL != GET_CODE (label)) abort ();
-
- lp = mvs_get_label (labelno);
- if (-1 == lp -> first_ref_page) lp->first_ref_page = mvs_page_num;
- }
- return dest_addr;
-}
-
-int
-i370_branch_length (insn)
- rtx insn;
-{
- int here, there;
- here = INSN_ADDRESSES (INSN_UID (insn));
- there = i370_branch_dest (insn);
- return (there - here);
-}
-
-
-int
-i370_short_branch (insn)
- rtx insn;
-{
- int base_offset;
-
- base_offset = i370_branch_length(insn);
- if (0 > base_offset)
- {
- base_offset += mvs_page_code;
- }
- else
- {
- /* avoid bumping into lit pool; use 2x to estimate max possible lits */
- base_offset *= 2;
- base_offset += mvs_page_code + mvs_page_lit;
- }
-
- /* make a conservative estimate of room left on page */
- if ((4060 >base_offset) && ( 0 < base_offset)) return 1;
- return 0;
-}
-
-/* The i370_label_scan() routine is supposed to loop over
- all labels and label references in a compilation unit,
- and determine whether all label refs appear on the same
- code page as the label. If they do, then we can avoid
- a reload of the base register for that label.
-
- Note that the instruction addresses used here are only
- approximate, and make the sizes of the jumps appear
- farther apart then they will actually be. This makes
- this code far more conservative than it needs to be.
- */
-
-#define I370_RECORD_LABEL_REF(label,addr) { \
- label_node_t *lp; \
- int labelno = CODE_LABEL_NUMBER (label); \
- lp = mvs_get_label (labelno); \
- if (addr < lp -> label_first_ref) lp->label_first_ref = addr; \
- if (addr > lp -> label_last_ref) lp->label_last_ref = addr; \
-}
-
-static void
-i370_label_scan ()
-{
- rtx insn;
- label_node_t *lp;
- int tablejump_offset = 0;
-
- for (insn = get_insns(); insn; insn = NEXT_INSN(insn))
- {
- int here = INSN_ADDRESSES (INSN_UID (insn));
- enum rtx_code code = GET_CODE(insn);
-
- /* ??? adjust for tables embedded in the .text section that
- * the compiler didn't take into account */
- here += tablejump_offset;
- INSN_ADDRESSES (INSN_UID (insn)) = here;
-
- /* check to see if this insn is a label ... */
- if (CODE_LABEL == code)
- {
- int labelno = CODE_LABEL_NUMBER (insn);
-
- lp = mvs_get_label (labelno);
- lp -> label_addr = here;
-#if 0
- /* Supposedly, labels are supposed to have circular
- lists of label-refs that reference them,
- setup in flow.c, but this does not appear to be the case. */
- rtx labelref = LABEL_REFS (insn);
- rtx ref = labelref;
- do
- {
- rtx linsn = CONTAINING_INSN(ref);
- ref = LABEL_NEXTREF(ref);
- } while (ref && (ref != labelref));
-#endif
- }
- else
- if (JUMP_INSN == code)
- {
- rtx label = JUMP_LABEL (insn);
-
- /* If there is no label for this jump, then this
- had better be a ADDR_VEC or an ADDR_DIFF_VEC
- and there had better be a vector of labels. */
- if (!label)
- {
- int j;
- rtx body = PATTERN (insn);
- if (ADDR_VEC == GET_CODE(body))
- {
- for (j=0; j < XVECLEN (body, 0); j++)
- {
- rtx lref = XVECEXP (body, 0, j);
- if (LABEL_REF != GET_CODE (lref)) abort ();
- label = XEXP (lref,0);
- if (CODE_LABEL != GET_CODE (label)) abort ();
- tablejump_offset += 4;
- here += 4;
- I370_RECORD_LABEL_REF(label,here);
- }
- /* finished with the vector go do next insn */
- continue;
- }
- else
- if (ADDR_DIFF_VEC == GET_CODE(body))
- {
-/* XXX hack alert.
- Right now, we leave this as a no-op, but strictly speaking,
- this is incorrect. It is possible that a table-jump
- driven off of a relative address could take us off-page,
- to a place where we need to reload the base reg. So really,
- we need to examing both labels, and compare thier values
- to the current basereg value.
-
- More generally, this brings up a troubling issue overall:
- what happens if a tablejump is split across two pages? I do
- not beleive that this case is handled correctly at all, and
- can only lead to horrible results if this were to occur.
-
- However, the current situation is not any worse than it was
- last week, and so we punt for now. */
-
- debug_rtx (insn);
- for (j=0; j < XVECLEN (body, 0); j++)
- {
- }
- /* finished with the vector go do next insn */
- continue;
- }
- else
- {
-/* XXX hack alert.
- Compiling the exception handling (L_eh) in libgcc2.a will trip
- up right here, with something that looks like
- (set (pc) (mem:SI (plus:SI (reg/v:SI 1 r1) (const_int 4))))
- {indirect_jump}
- I'm not sure of what leads up to this, but it looks like
- the makings of a long jump which will surely get us into trouble
- because the base & page registers don't get reloaded. For now
- I'm not sure of what to do ... again we punt ... we are not worse
- off than yesterday. */
-
- /* print_rtl_single (stdout, insn); */
- debug_rtx (insn);
- /* abort(); */
- continue;
- }
- }
- else
- {
- /* At this point, this jump_insn had better be a plain-old
- ordinary one, grap the label id and go */
- if (CODE_LABEL != GET_CODE (label)) abort ();
- I370_RECORD_LABEL_REF(label,here);
- }
- }
-
- /* Sometimes, we take addresses of labels and use them
- as instruction operands ... these show up as REG_NOTES */
- else
- if (INSN == code)
- {
- if ('i' == GET_RTX_CLASS (code))
- {
- rtx note;
- for (note = REG_NOTES (insn); note; note = XEXP(note,1))
- {
- if (REG_LABEL == REG_NOTE_KIND(note))
- {
- rtx label = XEXP (note,0);
- if (!label || CODE_LABEL != GET_CODE (label)) abort ();
-
- I370_RECORD_LABEL_REF(label,here);
- }
- }
- }
- }
- }
-}
-
-/* ===================================================== */
-
-/* Emit reload of base register if indicated. This is to eliminate multiple
- reloads when several labels are generated pointing to the same place
- in the code.
-
- The page table is written at the end of the function.
- The entries in the page table look like
- .LPGT0: // PGT0 EQU *
- .long .LPG0 // DC A(PG0)
- .long .LPG1 // DC A(PG1)
- while the prologue generates
- L r4,=A(.LPGT0)
-
- Note that this paging scheme breaks down if a single subroutine
- has more than about 10MB of code in it ... as long as humans write
- code, this shouldn't be a problem ...
- */
-
-void
-check_label_emit ()
-{
- if (mvs_need_base_reload)
- {
- mvs_need_base_reload = 0;
-
- mvs_page_code += 4;
- fprintf (assembler_source, "\tL\t%d,%d(,%d)\n",
- BASE_REGISTER, (mvs_page_num - function_base_page) * 4,
- PAGE_REGISTER);
- }
-}
-
-/* Add the label to the current page label list. If a free element is available
- it will be used for the new label. Otherwise, a label element will be
- allocated from memory.
- ID is the label number of the label being added to the list. */
-
-static label_node_t *
-mvs_get_label (id)
- int id;
-{
- label_node_t *lp;
-
- /* first, lets see if we already go one, if so, use that. */
- for (lp = label_anchor; lp; lp = lp->label_next)
- {
- if (lp->label_id == id) return lp;
- }
-
- /* not found, get a new one */
- if (free_anchor)
- {
- lp = free_anchor;
- free_anchor = lp->label_next;
- }
- else
- {
- lp = (label_node_t *) xmalloc (sizeof (label_node_t));
- }
-
- /* initialize for new label */
- lp->label_id = id;
- lp->label_page = -1;
- lp->label_next = label_anchor;
- lp->label_first_ref = 2000123123;
- lp->label_last_ref = -1;
- lp->label_addr = -1;
- lp->first_ref_page = -1;
- label_anchor = lp;
-
- return lp;
-}
-
-void
-mvs_add_label (id)
- int id;
-{
- label_node_t *lp;
- int fwd_distance;
-
- lp = mvs_get_label (id);
- lp->label_page = mvs_page_num;
-
- /* OK, we just saw the label. Determine if this label
- * needs a reload of the base register */
- if ((-1 != lp->first_ref_page) &&
- (lp->first_ref_page != mvs_page_num))
- {
- /* Yep; the first label_ref was on a different page. */
- mvs_need_base_reload ++;
- return;
- }
-
- /* Hmm. Try to see if the estimated address of the last
- label_ref is on the current page. If it is, then we
- don't need a base reg reload. Note that this estimate
- is very conservatively handled; we'll tend to have
- a good bit more reloads than actually needed. Someday,
- we should tighten the estimates (which are driven by
- the (set_att "length") insn attibute.
-
- Currently, we estimate that number of page literals
- same as number of insns, which is a vast overestimate,
- esp that the estimate of each insn size is its max size. */
-
- /* if latest ref comes before label, we are clear */
- if (lp->label_last_ref < lp->label_addr) return;
-
- fwd_distance = lp->label_last_ref - lp->label_addr;
-
- if (mvs_page_code + 2 * fwd_distance + mvs_page_lit < 4060) return;
-
- mvs_need_base_reload ++;
-}
-
-/* Check to see if the label is in the list and in the current
- page. If not found, we have to make worst case assumption
- that label will be on a different page, and thus will have to
- generate a load and branch on register. This is rather
- ugly for forward-jumps, but what can we do? For backward
- jumps on the same page we can branch directly to address.
- ID is the label number of the label being checked. */
-
-int
-mvs_check_label (id)
- int id;
-{
- label_node_t *lp;
-
- for (lp = label_anchor; lp; lp = lp->label_next)
- {
- if (lp->label_id == id)
- {
- if (lp->label_page == mvs_page_num)
- {
- return 1;
- }
- else
- {
- return 0;
- }
- }
- }
- return 0;
-}
-
-/* Get the page on which the label sits. This will be used to
- determine is a register reload is really needed. */
-
-#if 0
-int
-mvs_get_label_page(int id)
-{
- label_node_t *lp;
-
- for (lp = label_anchor; lp; lp = lp->label_next)
- {
- if (lp->label_id == id)
- return lp->label_page;
- }
- return -1;
-}
-#endif
-
-/* The label list for the current page freed by linking the list onto the free
- label element chain. */
-
-void
-mvs_free_label_list ()
-{
-
- if (label_anchor)
- {
- label_node_t *last_lp = label_anchor;
- while (last_lp->label_next) last_lp = last_lp->label_next;
- last_lp->label_next = free_anchor;
- free_anchor = label_anchor;
- }
- label_anchor = 0;
-}
-
-/* ====================================================================== */
-/* If the page size limit is reached a new code page is started, and the base
- register is set to it. This page break point is counted conservatively,
- most literals that have the same value are collapsed by the assembler.
- True is returned when a new page is started.
- FILE is the assembler output file descriptor.
- CODE is the length, in bytes, of the instruction to be emitted.
- LIT is the length of the literal to be emitted. */
-
-#ifdef TARGET_HLASM
-int
-mvs_check_page (file, code, lit)
- FILE *file;
- int code, lit;
-{
- if (file)
- assembler_source = file;
-
- if (mvs_page_code + code + mvs_page_lit + lit > MAX_MVS_PAGE_LENGTH)
- {
- fprintf (assembler_source, "\tB\tPGE%d\n", mvs_page_num);
- fprintf (assembler_source, "\tDS\t0F\n");
- fprintf (assembler_source, "\tLTORG\n");
- fprintf (assembler_source, "\tDS\t0F\n");
- fprintf (assembler_source, "PGE%d\tEQU\t*\n", mvs_page_num);
- fprintf (assembler_source, "\tDROP\t%d\n", BASE_REGISTER);
- mvs_page_num++;
- /* Safe to use BASR not BALR, since we are
- * not switching addressing mode here ... */
- fprintf (assembler_source, "\tBASR\t%d,0\n", BASE_REGISTER);
- fprintf (assembler_source, "PG%d\tEQU\t*\n", mvs_page_num);
- fprintf (assembler_source, "\tUSING\t*,%d\n", BASE_REGISTER);
- mvs_page_code = code;
- mvs_page_lit = lit;
- return 1;
- }
- mvs_page_code += code;
- mvs_page_lit += lit;
- return 0;
-}
-#endif /* TARGET_HLASM */
-
-
-#ifdef TARGET_ELF_ABI
-int
-mvs_check_page (file, code, lit)
- FILE *file;
- int code, lit;
-{
- if (file)
- assembler_source = file;
-
- if (mvs_page_code + code + mvs_page_lit + lit > MAX_MVS_PAGE_LENGTH)
- {
- /* hop past the literal pool */
- fprintf (assembler_source, "\tB\t.LPGE%d\n", mvs_page_num);
-
- /* dump the literal pool. The .baligns are optional, since
- * ltorg will align to the size of the largest literal
- * (which is possibly 8 bytes) */
- fprintf (assembler_source, "\t.balign\t4\n");
- fprintf (assembler_source, "\t.LTORG\n");
- fprintf (assembler_source, "\t.balign\t4\n");
-
- /* we continue execution here ... */
- fprintf (assembler_source, ".LPGE%d:\n", mvs_page_num);
- fprintf (assembler_source, "\t.DROP\t%d\n", BASE_REGISTER);
- mvs_page_num++;
-
- /* BASR puts the contents of the PSW into r3
- * that is, r3 will be loaded with the address of "." */
- fprintf (assembler_source, "\tBASR\tr%d,0\n", BASE_REGISTER);
- fprintf (assembler_source, ".LPG%d:\n", mvs_page_num);
- fprintf (assembler_source, "\t.USING\t.,r%d\n", BASE_REGISTER);
- mvs_page_code = code;
- mvs_page_lit = lit;
- return 1;
- }
- mvs_page_code += code;
- mvs_page_lit += lit;
- return 0;
-}
-#endif /* TARGET_ELF_ABI */
-
-/* ===================================================== */
-/* defines and functions specific to the HLASM assembler */
-#ifdef TARGET_HLASM
-
-/* Check for C/370 runtime function, they don't use standard calling
- conventions. True is returned if the function is in the table.
- NAME is the name of the current function. */
-
-int
-mvs_function_check (name)
- const char *name;
-{
- int lower, middle, upper;
- int i;
-
- lower = 0;
- upper = MVS_FUNCTION_TABLE_LENGTH - 1;
- while (lower <= upper)
- {
- middle = (lower + upper) / 2;
- i = strcmp (name, mvs_function_table[middle]);
- if (i == 0)
- return 1;
- if (i < 0)
- upper = middle - 1;
- else
- lower = middle + 1;
- }
- return 0;
-}
-
-/* Generate a hash for a given key. */
-
-#ifdef LONGEXTERNAL
-static int
-mvs_hash_alias (key)
- const char *key;
-{
- int h;
- int i;
- int l = strlen (key);
-
- h = key[0];
- for (i = 1; i < l; i++)
- h = ((h * MVS_SET_SIZE) + key[i]) % MVS_HASH_PRIME;
- return (h);
-}
-#endif
-
-/* Add the alias to the current alias list. */
-
-void
-mvs_add_alias (realname, aliasname, emitted)
- const char *realname;
- const char *aliasname;
- int emitted;
-{
- alias_node_t *ap;
-
- ap = (alias_node_t *) xmalloc (sizeof (alias_node_t));
- if (strlen (realname) > MAX_LONG_LABEL_SIZE)
- {
- warning ("real name is too long - alias ignored");
- return;
- }
- if (strlen (aliasname) > MAX_MVS_LABEL_SIZE)
- {
- warning ("alias name is too long - alias ignored");
- return;
- }
-
- strcpy (ap->real_name, realname);
- strcpy (ap->alias_name, aliasname);
- ap->alias_emitted = emitted;
- ap->alias_next = alias_anchor;
- alias_anchor = ap;
-}
-
-/* Check to see if the name needs aliasing. ie. the name is either:
- 1. Longer than 8 characters
- 2. Contains an underscore
- 3. Is mixed case */
-
-int
-mvs_need_alias (realname)
- const char *realname;
-{
- int i, j = strlen (realname);
-
- if (mvs_function_check (realname))
- return 0;
-#if 0
- if (!strcmp (realname, "gccmain"))
- return 0;
- if (!strcmp (realname, "main"))
- return 0;
-#endif
- if (j > MAX_MVS_LABEL_SIZE)
- return 1;
- if (strchr (realname, '_') != 0)
- return 1;
- if (ISUPPER (realname[0]))
- {
- for (i = 1; i < j; i++)
- {
- if (ISLOWER (realname[i]))
- return 1;
- }
- }
- else
- {
- for (i = 1; i < j; i++)
- {
- if (ISUPPER (realname[i]))
- return 1;
- }
- }
-
- return 0;
-}
-
-/* Get the alias from the list.
- If 1 is returned then it's in the alias list, 0 if it was not */
-
-int
-mvs_get_alias (realname, aliasname)
- const char *realname;
- char *aliasname;
-{
-#ifdef LONGEXTERNAL
- alias_node_t *ap;
-
- for (ap = alias_anchor; ap; ap = ap->alias_next)
- {
- if (!strcmp (ap->real_name, realname))
- {
- strcpy (aliasname, ap->alias_name);
- return 1;
- }
- }
- if (mvs_need_alias (realname))
- {
- char c1, c2;
-
- c1 = realname[0];
- c2 = realname[1];
- if (ISLOWER (c1)) c1 = TOUPPER (c1);
- else if (c1 == '_') c1 = 'A';
- if (ISLOWER (c2)) c2 = TOUPPER (c2);
- else if (c2 == '_' || c2 == '\0') c2 = '#';
-
- sprintf (aliasname, "%c%c%06d", c1, c2, mvs_hash_alias (realname));
- mvs_add_alias (realname, aliasname, 0);
- return 1;
- }
-#else
- if (strlen (realname) > MAX_MVS_LABEL_SIZE)
- {
- strncpy (aliasname, realname, MAX_MVS_LABEL_SIZE);
- aliasname[MAX_MVS_LABEL_SIZE] = '\0';
- return 1;
- }
-#endif
- return 0;
-}
-
-/* Check to see if the alias is in the list.
- If 1 is returned then it's in the alias list, 2 it was emitted */
-
-int
-mvs_check_alias (realname, aliasname)
- const char *realname;
- char *aliasname;
-{
-#ifdef LONGEXTERNAL
- alias_node_t *ap;
-
- for (ap = alias_anchor; ap; ap = ap->alias_next)
- {
- if (!strcmp (ap->real_name, realname))
- {
- int rc = (ap->alias_emitted == 1) ? 1 : 2;
- strcpy (aliasname, ap->alias_name);
- ap->alias_emitted = 1;
- return rc;
- }
- }
- if (mvs_need_alias (realname))
- {
- char c1, c2;
-
- c1 = realname[0];
- c2 = realname[1];
- if (ISLOWER (c1)) c1 = TOUPPER (c1);
- else if (c1 == '_') c1 = 'A';
- if (ISLOWER (c2)) c2 = TOUPPER (c2);
- else if (c2 == '_' || c2 == '\0') c2 = '#';
-
- sprintf (aliasname, "%c%c%06d", c1, c2, mvs_hash_alias (realname));
- mvs_add_alias (realname, aliasname, 0);
- alias_anchor->alias_emitted = 1;
- return 2;
- }
-#else
- if (strlen (realname) > MAX_MVS_LABEL_SIZE)
- {
- strncpy (aliasname, realname, MAX_MVS_LABEL_SIZE);
- aliasname[MAX_MVS_LABEL_SIZE] = '\0';
- return 1;
- }
-#endif
- return 0;
-}
-
-/* defines and functions specific to the HLASM assembler */
-#endif /* TARGET_HLASM */
-/* ===================================================== */
-/* ===================================================== */
-/* defines and functions specific to the gas assembler */
-#ifdef TARGET_ELF_ABI
-
-/* Check for C/370 runtime function, they don't use standard calling
- conventions. True is returned if the function is in the table.
- NAME is the name of the current function. */
-/* no special calling conventions (yet ??) */
-
-int
-mvs_function_check (name)
- const char *name ATTRIBUTE_UNUSED;
-{
- return 0;
-}
-
-#endif /* TARGET_ELF_ABI */
-/* ===================================================== */
-
-
-/* Return 1 if OP is a valid S operand for an RS, SI or SS type instruction.
- OP is the current operation.
- MODE is the current operation mode. */
-
-int
-s_operand (op, mode)
- register rtx op;
- enum machine_mode mode;
-{
- extern int volatile_ok;
- register enum rtx_code code = GET_CODE (op);
-
- if (CONSTANT_ADDRESS_P (op))
- return 1;
- if (mode == VOIDmode || GET_MODE (op) != mode)
- return 0;
- if (code == MEM)
- {
- register rtx x = XEXP (op, 0);
-
- if (!volatile_ok && op->volatil)
- return 0;
- if (REG_P (x) && REG_OK_FOR_BASE_P (x))
- return 1;
- if (GET_CODE (x) == PLUS
- && REG_P (XEXP (x, 0)) && REG_OK_FOR_BASE_P (XEXP (x, 0))
- && GET_CODE (XEXP (x, 1)) == CONST_INT
- && (unsigned) INTVAL (XEXP (x, 1)) < 4096)
- return 1;
- }
- return 0;
-}
-
-
-/* Return 1 if OP is a valid R or S operand for an RS, SI or SS type
- instruction.
- OP is the current operation.
- MODE is the current operation mode. */
-
-int
-r_or_s_operand (op, mode)
- register rtx op;
- enum machine_mode mode;
-{
- extern int volatile_ok;
- register enum rtx_code code = GET_CODE (op);
-
- if (CONSTANT_ADDRESS_P (op))
- return 1;
- if (mode == VOIDmode || GET_MODE (op) != mode)
- return 0;
- if (code == REG)
- return 1;
- else if (code == MEM)
- {
- register rtx x = XEXP (op, 0);
-
- if (!volatile_ok && op->volatil)
- return 0;
- if (REG_P (x) && REG_OK_FOR_BASE_P (x))
- return 1;
- if (GET_CODE (x) == PLUS
- && REG_P (XEXP (x, 0)) && REG_OK_FOR_BASE_P (XEXP (x, 0))
- && GET_CODE (XEXP (x, 1)) == CONST_INT
- && (unsigned) INTVAL (XEXP (x, 1)) < 4096)
- return 1;
- }
- return 0;
-}
-
-
-/* Some remarks about unsigned_jump_follows_p():
- gcc is built around the assumption that branches are signed
- or unsigned, whereas the 370 doesn't care; its the compares that
- are signed or unsigned. Thus, we need to somehow know if we
- need to do a signed or an unsigned compare, and we do this by
- looking ahead in the instruction sequence until we find a jump.
- We then note whether this jump is signed or unsigned, and do the
- compare appropriately. Note that we have to scan ahead indefinitley,
- as the gcc optimizer may insert any number of instructions between
- the compare and the jump.
-
- Note that using conditional branch expanders seems to be be a more
- elegant/correct way of doing this. See, for instance, the Alpha
- cmpdi and bgt patterns. Note also that for the i370, various
- arithmetic insn's set the condition code as well.
-
- The unsigned_jump_follows_p() routine returns a 1 if the next jump
- is unsigned. INSN is the current instruction. */
-
-int
-unsigned_jump_follows_p (insn)
- register rtx insn;
-{
- rtx orig_insn = insn;
- while (1)
- {
- register rtx tmp_insn;
- enum rtx_code coda;
-
- insn = NEXT_INSN (insn);
- if (!insn) fatal_insn ("internal error--no jump follows compare:", orig_insn);
-
- if (GET_CODE (insn) != JUMP_INSN) continue;
-
- tmp_insn = XEXP (insn, 3);
- if (GET_CODE (tmp_insn) != SET) continue;
-
- if (GET_CODE (XEXP (tmp_insn, 0)) != PC) continue;
-
- tmp_insn = XEXP (tmp_insn, 1);
- if (GET_CODE (tmp_insn) != IF_THEN_ELSE) continue;
-
- /* if we got to here, this instruction is a jump. Is it signed? */
- tmp_insn = XEXP (tmp_insn, 0);
- coda = GET_CODE (tmp_insn);
-
- return coda != GE && coda != GT && coda != LE && coda != LT;
- }
-}
-
-#ifdef TARGET_HLASM
-
-/* Target hook for assembling integer objects. This version handles all
- objects when TARGET_HLASM is defined. */
-
-static bool
-i370_hlasm_assemble_integer (x, size, aligned_p)
- rtx x;
- unsigned int size;
- int aligned_p;
-{
- const char *int_format = NULL;
-
- if (aligned_p)
- switch (size)
- {
- case 1:
- int_format = "\tDC\tX'%02X'\n";
- break;
-
- case 2:
- int_format = "\tDC\tX'%04X'\n";
- break;
-
- case 4:
- if (GET_CODE (x) == CONST_INT)
- {
- fputs ("\tDC\tF'", asm_out_file);
- output_addr_const (asm_out_file, x);
- fputs ("'\n", asm_out_file);
- }
- else
- {
- fputs ("\tDC\tA(", asm_out_file);
- output_addr_const (asm_out_file, x);
- fputs (")\n", asm_out_file);
- }
- return true;
- }
-
- if (int_format && GET_CODE (x) == CONST_INT)
- {
- fprintf (asm_out_file, int_format, INTVAL (x));
- return true;
- }
- return default_assemble_integer (x, size, aligned_p);
-}
-
-/* Generate the assembly code for function entry. FILE is a stdio
- stream to output the code to. SIZE is an int: how many units of
- temporary storage to allocate.
-
- Refer to the array `regs_ever_live' to determine which registers to
- save; `regs_ever_live[I]' is nonzero if register number I is ever
- used in the function. This function is responsible for knowing
- which registers should not be saved even if used. */
-
-static void
-i370_output_function_prologue (f, l)
- FILE *f;
- HOST_WIDE_INT l;
-{
-#if MACROPROLOGUE == 1
- fprintf (f, "* Function %s prologue\n", mvs_function_name);
- fprintf (f, "\tEDCPRLG USRDSAL=%d,BASEREG=%d\n",
- STACK_POINTER_OFFSET + l - 120 +
- current_function_outgoing_args_size, BASE_REGISTER);
-#else /* MACROPROLOGUE != 1 */
- static int function_label_index = 1;
- static int function_first = 0;
- static int function_year, function_month, function_day;
- static int function_hour, function_minute, function_second;
-#if defined(LE370)
- if (!function_first)
- {
- struct tm *function_time;
- time_t lcltime;
- time (&lcltime);
- function_time = localtime (&lcltime);
- function_year = function_time->tm_year + 1900;
- function_month = function_time->tm_mon + 1;
- function_day = function_time->tm_mday;
- function_hour = function_time->tm_hour;
- function_minute = function_time->tm_min;
- function_second = function_time->tm_sec;
- }
- fprintf (f, "* Function %s prologue\n", mvs_function_name);
- fprintf (f, "FDSE%03d\tDSECT\n", function_label_index);
- fprintf (f, "\tDS\tD\n");
- fprintf (f, "\tDS\tCL(" HOST_WIDE_INT_PRINT_DEC ")\n",
- STACK_POINTER_OFFSET + l
- + current_function_outgoing_args_size);
- fprintf (f, "\tORG\tFDSE%03d\n", function_label_index);
- fprintf (f, "\tDS\tCL(120+8)\n");
- fprintf (f, "\tORG\n");
- fprintf (f, "\tDS\t0D\n");
- fprintf (f, "FDSL%03d\tEQU\t*-FDSE%03d-8\n", function_label_index,
- function_label_index);
- fprintf (f, "\tDS\t0H\n");
- assemble_name (f, mvs_function_name);
- fprintf (f, "\tCSECT\n");
- fprintf (f, "\tUSING\t*,15\n");
- fprintf (f, "\tB\tFENT%03d\n", function_label_index);
- fprintf (f, "\tDC\tAL1(FNAM%03d+4-*)\n", function_label_index);
- fprintf (f, "\tDC\tX'CE',X'A0',AL1(16)\n");
- fprintf (f, "\tDC\tAL4(FPPA%03d)\n", function_label_index);
- fprintf (f, "\tDC\tAL4(0)\n");
- fprintf (f, "\tDC\tAL4(FDSL%03d)\n", function_label_index);
- fprintf (f, "FNAM%03d\tEQU\t*\n", function_label_index);
- fprintf (f, "\tDC\tAL2(%d),C'%s'\n", strlen (mvs_function_name),
- mvs_function_name);
- fprintf (f, "FPPA%03d\tDS\t0F\n", function_label_index);
- fprintf (f, "\tDC\tX'03',X'00',X'33',X'00'\n");
- fprintf (f, "\tDC\tV(CEESTART)\n");
- fprintf (f, "\tDC\tAL4(0)\n");
- fprintf (f, "\tDC\tAL4(FTIM%03d)\n", function_label_index);
- fprintf (f, "FTIM%03d\tDS\t0F\n", function_label_index);
- fprintf (f, "\tDC\tCL4'%d',CL4'%02d%02d',CL6'%02d%02d00'\n",
- function_year, function_month, function_day,
- function_hour, function_minute);
- fprintf (f, "\tDC\tCL2'01',CL4'0100'\n");
- fprintf (f, "FENT%03d\tDS\t0H\n", function_label_index);
- fprintf (f, "\tSTM\t14,12,12(13)\n");
- fprintf (f, "\tL\t2,76(,13)\n");
- fprintf (f, "\tL\t0,16(,15)\n");
- fprintf (f, "\tALR\t0,2\n");
- fprintf (f, "\tCL\t0,12(,12)\n");
- fprintf (f, "\tBNH\t*+10\n");
- fprintf (f, "\tL\t15,116(,12)\n");
- fprintf (f, "\tBALR\t14,15\n");
- fprintf (f, "\tL\t15,72(,13)\n");
- fprintf (f, "\tSTM\t15,0,72(2)\n");
- fprintf (f, "\tMVI\t0(2),X'10'\n");
- fprintf (f, "\tST\t2,8(,13)\n ");
- fprintf (f, "\tST\t13,4(,2)\n ");
- fprintf (f, "\tLR\t13,2\n");
- fprintf (f, "\tDROP\t15\n");
- fprintf (f, "\tBALR\t%d,0\n", BASE_REGISTER);
- fprintf (f, "\tUSING\t*,%d\n", BASE_REGISTER);
- function_first = 1;
- function_label_index ++;
-#else /* !LE370 */
- if (!function_first)
- {
- struct tm *function_time;
- time_t lcltime;
- time (&lcltime);
- function_time = localtime (&lcltime);
- function_year = function_time->tm_year + 1900;
- function_month = function_time->tm_mon + 1;
- function_day = function_time->tm_mday;
- function_hour = function_time->tm_hour;
- function_minute = function_time->tm_min;
- function_second = function_time->tm_sec;
- fprintf (f, "PPA2\tDS\t0F\n");
- fprintf (f, "\tDC\tX'03',X'00',X'33',X'00'\n");
- fprintf (f, "\tDC\tV(CEESTART),A(0)\n");
- fprintf (f, "\tDC\tA(CEETIMES)\n");
- fprintf (f, "CEETIMES\tDS\t0F\n");
- fprintf (f, "\tDC\tCL4'%d',CL4'%02d%02d',CL6'%02d%02d00'\n",
- function_year, function_month, function_day,
- function_hour, function_minute, function_second);
- fprintf (f, "\tDC\tCL2'01',CL4'0100'\n");
- }
- fprintf (f, "* Function %s prologue\n", mvs_function_name);
- fprintf (f, "FDSD%03d\tDSECT\n", function_label_index);
- fprintf (f, "\tDS\tD\n");
- fprintf (f, "\tDS\tCL(%d)\n", STACK_POINTER_OFFSET + l
- + current_function_outgoing_args_size);
- fprintf (f, "\tORG\tFDSD%03d\n", function_label_index);
- fprintf (f, "\tDS\tCL(120+8)\n");
- fprintf (f, "\tORG\n");
- fprintf (f, "\tDS\t0D\n");
- fprintf (f, "FDSL%03d\tEQU\t*-FDSD%03d-8\n", function_label_index,
- function_label_index);
- fprintf (f, "\tDS\t0H\n");
- assemble_name (f, mvs_function_name);
- fprintf (f, "\tCSECT\n");
- fprintf (f, "\tUSING\t*,15\n");
- fprintf (f, "\tB\tFPL%03d\n", function_label_index);
- fprintf (f, "\tDC\tAL1(FPL%03d+4-*)\n", function_label_index + 1);
- fprintf (f, "\tDC\tX'CE',X'A0',AL1(16)\n");
- fprintf (f, "\tDC\tAL4(PPA2)\n");
- fprintf (f, "\tDC\tAL4(0)\n");
- fprintf (f, "\tDC\tAL4(FDSL%03d)\n", function_label_index);
- fprintf (f, "FPL%03d\tEQU\t*\n", function_label_index + 1);
- fprintf (f, "\tDC\tAL2(%d),C'%s'\n", strlen (mvs_function_name),
- mvs_function_name);
- fprintf (f, "FPL%03d\tDS\t0H\n", function_label_index);
- fprintf (f, "\tSTM\t14,12,12(13)\n");
- fprintf (f, "\tL\t2,76(,13)\n");
- fprintf (f, "\tL\t0,16(,15)\n");
- fprintf (f, "\tALR\t0,2\n");
- fprintf (f, "\tCL\t0,12(,12)\n");
- fprintf (f, "\tBNH\t*+10\n");
- fprintf (f, "\tL\t15,116(,12)\n");
- fprintf (f, "\tBALR\t14,15\n");
- fprintf (f, "\tL\t15,72(,13)\n");
- fprintf (f, "\tSTM\t15,0,72(2)\n");
- fprintf (f, "\tMVI\t0(2),X'10'\n");
- fprintf (f, "\tST\t2,8(,13)\n ");
- fprintf (f, "\tST\t13,4(,2)\n ");
- fprintf (f, "\tLR\t13,2\n");
- fprintf (f, "\tDROP\t15\n");
- fprintf (f, "\tBALR\t%d,0\n", BASE_REGISTER);
- fprintf (f, "\tUSING\t*,%d\n", BASE_REGISTER);
- function_first = 1;
- function_label_index += 2;
-#endif /* !LE370 */
-#endif /* MACROPROLOGUE */
- fprintf (f, "PG%d\tEQU\t*\n", mvs_page_num );
- fprintf (f, "\tLR\t11,1\n");
- fprintf (f, "\tL\t%d,=A(PGT%d)\n", PAGE_REGISTER, mvs_page_num);
- fprintf (f, "* Function %s code\n", mvs_function_name);
-
- mvs_free_label_list ();
- mvs_page_code = 6;
- mvs_page_lit = 4;
- mvs_check_page (f, 0, 0);
- function_base_page = mvs_page_num;
-
- /* find all labels in this routine */
- i370_label_scan ();
-}
-
-static void
-i370_globalize_label (stream, name)
- FILE *stream;
- const char *name;
-{
- char temp[MAX_MVS_LABEL_SIZE + 1];
- if (mvs_check_alias (name, temp) == 2)
- fprintf (stream, "%s\tALIAS\tC'%s'\n", temp, name);
- fputs ("\tENTRY\t", stream);
- assemble_name (stream, name);
- putc ('\n', stream);
-}
-#endif /* TARGET_HLASM */
-
-
-#ifdef TARGET_ELF_ABI
-/*
- The 370_function_prolog() routine generates the current ELF ABI ES/390 prolog.
- It implements a stack that grows downward.
- It performs the following steps:
- -- saves the callers non-volatile registers on the callers stack.
- -- subtracts stackframe size from the stack pointer.
- -- stores backpointer to old caller stack.
-
- XXX hack alert -- if the global var int leaf_function is nonzero,
- then this is a leaf, and it might be possible to optimize the prologue
- into doing even less, e.g. not grabbing a new stackframe or maybe just a
- partial stack frame.
-
- XXX hack alert -- the current stack frame is bloated into twice the
- needed size by unused entries. These entries make it marginally
- compatible with MVS/OE/USS C environment, but really they're not used
- and could probably chopped out. Modifications to i370.md would be needed
- also, to quite using addresses 136, 140, etc.
- */
-
-static void
-i370_output_function_prologue (f, frame_size)
- FILE *f;
- HOST_WIDE_INT frame_size;
-{
- static int function_label_index = 1;
- static int function_first = 0;
- int stackframe_size, aligned_size;
-
- fprintf (f, "# Function prologue\n");
- /* define the stack, put it into its own data segment
- FDSE == Function Stack Entry
- FDSL == Function Stack Length */
- stackframe_size =
- STACK_POINTER_OFFSET + current_function_outgoing_args_size + frame_size;
- aligned_size = (stackframe_size + 7) >> 3;
- aligned_size <<= 3;
-
- fprintf (f, "# arg_size=0x%x frame_size=" HOST_WIDE_INT_PRINT_HEX
- " aligned size=0x%x\n",
- current_function_outgoing_args_size, frame_size, aligned_size);
-
- fprintf (f, "\t.using\t.,r15\n");
-
- /* Branch to exectuable part of prologue. */
- fprintf (f, "\tB\t.LFENT%03d\n", function_label_index);
-
- /* write the length of the stackframe */
- fprintf (f, "\t.long\t%d\n", aligned_size);
-
- /* FENT == function prologue entry */
- fprintf (f, "\t.balign 2\n.LFENT%03d:\n",
- function_label_index);
-
- /* store multiple registers 14,15,0,...12 at 12 bytes from sp */
- fprintf (f, "\tSTM\tr14,r12,12(sp)\n");
-
- /* r3 == saved callee stack pointer */
- fprintf (f, "\tLR\tr3,sp\n");
-
- /* 4(r15) == stackframe size */
- fprintf (f, "\tSL\tsp,4(,r15)\n");
-
- /* r11 points to arg list in callers stackframe; was passed in r2 */
- fprintf (f, "\tLR\tr11,r2\n");
-
- /* store callee stack pointer at 8(sp) */
- /* fprintf (f, "\tST\tsp,8(,r3)\n "); wasted cycles, no one uses this ... */
-
- /* backchain -- store caller sp at 4(callee_sp) */
- fprintf (f, "\tST\tr3,4(,sp)\n ");
-
- fprintf (f, "\t.drop\tr15\n");
- /* Place contents of the PSW into r3
- that is, place the address of "." into r3 */
- fprintf (f, "\tBASR\tr%d,0\n", BASE_REGISTER);
- fprintf (f, "\t.using\t.,r%d\n", BASE_REGISTER);
- function_first = 1;
- function_label_index ++;
-
- fprintf (f, ".LPG%d:\n", mvs_page_num );
- fprintf (f, "\tL\tr%d,=A(.LPGT%d)\n", PAGE_REGISTER, mvs_page_num);
- fprintf (f, "# Function code\n");
-
- mvs_free_label_list ();
- mvs_page_code = 6;
- mvs_page_lit = 4;
- mvs_check_page (f, 0, 0);
- function_base_page = mvs_page_num;
-
- /* find all labels in this routine */
- i370_label_scan ();
-}
-#endif /* TARGET_ELF_ABI */
-
-/* This function generates the assembly code for function exit.
- Args are as for output_function_prologue ().
-
- The function epilogue should not depend on the current stack
- pointer! It should use the frame pointer only. This is mandatory
- because of alloca; we also take advantage of it to omit stack
- adjustments before returning. */
-
-static void
-i370_output_function_epilogue (file, l)
- FILE *file;
- HOST_WIDE_INT l ATTRIBUTE_UNUSED;
-{
- int i;
-
- check_label_emit ();
- mvs_check_page (file, 14, 0);
- fprintf (file, "* Function %s epilogue\n", mvs_function_name);
- mvs_page_num++;
-
-#if MACROEPILOGUE == 1
- fprintf (file, "\tEDCEPIL\n");
-#else /* MACROEPILOGUE != 1 */
- fprintf (file, "\tL\t13,4(,13)\n");
- fprintf (file, "\tL\t14,12(,13)\n");
- fprintf (file, "\tLM\t2,12,28(13)\n");
- fprintf (file, "\tBALR\t1,14\n");
- fprintf (file, "\tDC\tA(");
- assemble_name (file, mvs_function_name);
- fprintf (file, ")\n" );
-#endif /* MACROEPILOGUE */
-
- fprintf (file, "* Function %s literal pool\n", mvs_function_name);
- fprintf (file, "\tDS\t0F\n" );
- fprintf (file, "\tLTORG\n");
- fprintf (file, "* Function %s page table\n", mvs_function_name);
- fprintf (file, "\tDS\t0F\n");
- fprintf (file, "PGT%d\tEQU\t*\n", function_base_page);
-
- mvs_free_label_list();
- for (i = function_base_page; i < mvs_page_num; i++)
- fprintf (file, "\tDC\tA(PG%d)\n", i);
-}
-
-static void
-i370_file_start ()
-{
- fputs ("\tRMODE\tANY\n\tCSECT\n", asm_out_file);
-}
-
-static void
-i370_file_end ()
-{
- fputs ("\tEND\n", asm_out_file);
-}
-
-static void
-i370_internal_label (stream, prefix, labelno)
- FILE *stream;
- const char *prefix;
- unsigned long labelno;
-{
- if (!strcmp (prefix, "L"))
- mvs_add_label(labelno);
-
- default_internal_label (stream, prefix, labelno);
-}
-
-static bool
-i370_rtx_costs (x, code, outer_code, total)
- rtx x;
- int code;
- int outer_code ATTRIBUTE_UNUSED;
- int *total;
-{
- switch (code)
- {
- case CONST_INT:
- if ((unsigned HOST_WIDE_INT) INTVAL (x) < 0xfff)
- {
- *total = 1;
- return true;
- }
- /* FALLTHRU */
-
- case CONST:
- case LABEL_REF:
- case SYMBOL_REF:
- *total = 2;
- return true;
-
- case CONST_DOUBLE:
- *total = 4;
- return true;
-
- default:
- return false;
- }
-}
+++ /dev/null
-/* Definitions of target machine for GNU compiler. System/370 version.
- Copyright (C) 1989, 1993, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
- 2003 Free Software Foundation, Inc.
- Contributed by Jan Stein (jan@cd.chalmers.se).
- Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
- Hacked for Linux-ELF/390 by Linas Vepstas (linas@linas.org)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#ifndef GCC_I370_H
-#define GCC_I370_H
-
-/* Target CPU builtins. */
-#define TARGET_CPU_CPP_BUILTINS() \
- do \
- { \
- builtin_define_std ("GCC"); \
- builtin_define_std ("gcc"); \
- builtin_assert ("machine=i370"); \
- builtin_assert ("cpu=i370"); \
- } \
- while (0)
-
-/* Run-time compilation parameters selecting different hardware subsets. */
-
-extern int target_flags;
-
-/* The sizes of the code and literals on the current page. */
-
-extern int mvs_page_code, mvs_page_lit;
-
-/* The current page number and the base page number for the function. */
-
-extern int mvs_page_num, function_base_page;
-
-/* The name of the current function. */
-
-extern char *mvs_function_name;
-
-/* The length of the function name malloc'd area. */
-
-extern size_t mvs_function_name_length;
-
-/* Compile using char instructions (mvc, nc, oc, xc). On 4341 use this since
- these are more than twice as fast as load-op-store.
- On 3090 don't use this since load-op-store is much faster. */
-
-#define TARGET_CHAR_INSTRUCTIONS (target_flags & 1)
-
-/* Default target switches */
-
-#define TARGET_DEFAULT 1
-
-/* Macro to define tables used to set the flags. This is a list in braces
- of pairs in braces, each pair being { "NAME", VALUE }
- where VALUE is the bits to set or minus the bits to clear.
- An empty string NAME is used to identify the default VALUE. */
-
-#define TARGET_SWITCHES \
-{ { "char-instructions", 1, N_("Generate char instructions")}, \
- { "no-char-instructions", -1, N_("Do not generate char instructions")}, \
- { "", TARGET_DEFAULT, 0} }
-
-#define OVERRIDE_OPTIONS override_options ()
-
-/* To use IBM supplied macro function prologue and epilogue, define the
- following to 1. Should only be needed if IBM changes the definition
- of their prologue and epilogue. */
-
-#define MACROPROLOGUE 0
-#define MACROEPILOGUE 0
-
-/* Target machine storage layout */
-
-/* Define this if most significant bit is lowest numbered in instructions
- that operate on numbered bit-fields. */
-
-#define BITS_BIG_ENDIAN 1
-
-/* Define this if most significant byte of a word is the lowest numbered. */
-
-#define BYTES_BIG_ENDIAN 1
-
-/* Define this if MS word of a multiword is the lowest numbered. */
-
-#define WORDS_BIG_ENDIAN 1
-
-/* Width of a word, in units (bytes). */
-
-#define UNITS_PER_WORD 4
-
-/* Allocation boundary (in *bits*) for storing pointers in memory. */
-
-#define POINTER_BOUNDARY 32
-
-/* Allocation boundary (in *bits*) for storing arguments in argument list. */
-
-#define PARM_BOUNDARY 32
-
-/* Boundary (in *bits*) on which stack pointer should be aligned. */
-
-#define STACK_BOUNDARY 32
-
-/* Allocation boundary (in *bits*) for the code of a function. */
-
-#define FUNCTION_BOUNDARY 32
-
-/* There is no point aligning anything to a rounder boundary than this. */
-
-#define BIGGEST_ALIGNMENT 64
-
-/* Alignment of field after `int : 0' in a structure. */
-
-#define EMPTY_FIELD_BOUNDARY 32
-
-/* Define this if move instructions will actually fail to work when given
- unaligned data. */
-
-#define STRICT_ALIGNMENT 0
-
-/* Define target floating point format. */
-
-#define TARGET_FLOAT_FORMAT IBM_FLOAT_FORMAT
-
-#ifdef TARGET_HLASM
-/* HLASM requires #pragma map. */
-#define REGISTER_TARGET_PRAGMAS() c_register_pragma (0, "map", i370_pr_map)
-#endif /* TARGET_HLASM */
-
-/* Define maximum length of page minus page escape overhead. */
-
-#define MAX_MVS_PAGE_LENGTH 4080
-
-/* Define special register allocation order desired.
- Don't fiddle with this. I did, and I got all sorts of register
- spill errors when compiling even relatively simple programs...
- I have no clue why ...
- E.g. this one is bad:
- { 0, 1, 2, 9, 8, 7, 6, 5, 10, 15, 14, 12, 3, 4, 16, 17, 18, 19, 11, 13 }
- */
-
-#define REG_ALLOC_ORDER \
-{ 0, 1, 2, 3, 14, 15, 12, 10, 9, 8, 7, 6, 5, 4, 16, 17, 18, 19, 11, 13 }
-
-/* Standard register usage. */
-
-/* Number of actual hardware registers. The hardware registers are
- assigned numbers for the compiler from 0 to just below
- FIRST_PSEUDO_REGISTER.
- All registers that the compiler knows about must be given numbers,
- even those that are not normally considered general registers.
- For the 370, we give the data registers numbers 0-15,
- and the floating point registers numbers 16-19. */
-
-#define FIRST_PSEUDO_REGISTER 20
-
-/* Define base and page registers. */
-
-#define BASE_REGISTER 3
-#define PAGE_REGISTER 4
-
-#ifdef TARGET_HLASM
-/* 1 for registers that have pervasive standard uses and are not available
- for the register allocator. These are registers that must have fixed,
- valid values stored in them for the entire length of the subroutine call,
- and must not in any way be moved around, jiggered with, etc. That is,
- they must never be clobbered, and, if clobbered, the register allocator
- will never restore them back.
-
- We use five registers in this special way:
- -- R3 which is used as the base register
- -- R4 the page origin table pointer used to load R3,
- -- R11 the arg pointer.
- -- R12 the TCA pointer
- -- R13 the stack (DSA) pointer
-
- A fifth register is also exceptional: R14 is used in many branch
- instructions to hold the target of the branch. Technically, this
- does not qualify R14 as a register with a long-term meaning; it should
- be enough, theoretically, to note that these instructions clobber
- R14, and let the compiler deal with that. In practice, however,
- the "clobber" directive acts as a barrier to optimization, and the
- optimizer appears to be unable to perform optimizations around branches.
- Thus, a much better strategy appears to give R14 a pervasive use;
- this eliminates it from the register pool witout hurting optimization.
-
- There are other registers which have special meanings, but its OK
- for them to get clobbered, since other allocator config below will
- make sure that they always have the right value. These are for
- example:
- -- R1 the returned structure pointer.
- -- R10 the static chain reg.
- -- R15 holds the value a subroutine returns.
-
- Notice that it is *almost* safe to mark R11 as available to the allocator.
- By marking it as a call_used_register, in most cases, the compiler
- can handle it being clobbered. However, there are a few rare
- circumstances where the register allocator will allocate r11 and
- also try to use it as the arg pointer ... thus it must be marked fixed.
- I think this is a bug, but I can't track it down...
- */
-
-#define FIXED_REGISTERS \
-{ 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0 }
-/*0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19*/
-
-/* 1 for registers not available across function calls. These must include
- the FIXED_REGISTERS and also any registers that can be used without being
- saved.
- The latter must include the registers where values are returned
- and the register where structure-value addresses are passed.
- NOTE: all floating registers are undefined across calls.
-*/
-
-#define CALL_USED_REGISTERS \
-{ 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1 }
-/*0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19*/
-
-/* Return number of consecutive hard regs needed starting at reg REGNO
- to hold something of mode MODE.
- This is ordinarily the length in words of a value of mode MODE
- but can be less for certain modes in special long registers.
- Note that DCmode (complex double) needs two regs.
-*/
-#endif /* TARGET_HLASM */
-
-/* ================= */
-#ifdef TARGET_ELF_ABI
-/* The Linux/ELF ABI uses the same register layout as the
- * the MVS/OE version, with the following exceptions:
- * -- r12 (rtca) is not used.
- */
-
-#define FIXED_REGISTERS \
-{ 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0 }
-/*0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19*/
-
-#define CALL_USED_REGISTERS \
-{ 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1 }
-/*0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19*/
-
-#endif /* TARGET_ELF_ABI */
-/* ================= */
-
-
-#define HARD_REGNO_NREGS(REGNO, MODE) \
- ((REGNO) > 15 ? \
- ((GET_MODE_SIZE (MODE) + 2*UNITS_PER_WORD - 1) / (2*UNITS_PER_WORD)) : \
- (GET_MODE_SIZE(MODE)+UNITS_PER_WORD-1) / UNITS_PER_WORD)
-
-/* Value is 1 if hard register REGNO can hold a value of machine-mode MODE.
- On the 370, the cpu registers can hold QI, HI, SI, SF and DF. The
- even registers can hold DI. The floating point registers can hold
- either SF, DF, SC or DC. */
-
-#define HARD_REGNO_MODE_OK(REGNO, MODE) \
- ((REGNO) < 16 ? (((REGNO) & 1) == 0 || \
- (((MODE) != DImode) && ((MODE) != DFmode))) \
- : ((MODE) == SFmode || (MODE) == DFmode) || \
- (MODE) == SCmode || (MODE) == DCmode)
-
-/* Value is 1 if it is a good idea to tie two pseudo registers when one has
- mode MODE1 and one has mode MODE2.
- If HARD_REGNO_MODE_OK could produce different values for MODE1 and MODE2,
- for any hard reg, then this must be 0 for correct output. */
-
-#define MODES_TIEABLE_P(MODE1, MODE2) \
- (((MODE1) == SFmode || (MODE1) == DFmode) \
- == ((MODE2) == SFmode || (MODE2) == DFmode))
-
-/* Specify the registers used for certain standard purposes.
- The values of these macros are register numbers. */
-
-/* 370 PC isn't overloaded on a register. */
-
-/* #define PC_REGNUM */
-
-/* Register to use for pushing function arguments. */
-
-#define STACK_POINTER_REGNUM 13
-
-/* Base register for access to local variables of the function. */
-
-#define FRAME_POINTER_REGNUM 13
-
-/* Value should be nonzero if functions must have frame pointers.
- Zero means the frame pointer need not be set up (and parms may be
- accessed via the stack pointer) in functions that seem suitable.
- This is computed in `reload', in reload1.c. */
-
-#define FRAME_POINTER_REQUIRED 1
-
-/* Base register for access to arguments of the function. */
-
-#define ARG_POINTER_REGNUM 11
-
-/* R10 is register in which static-chain is passed to a function.
- Static-chaining is done when a nested function references as a global
- a stack variable of its parent: e.g.
- int parent_func (int arg) {
- int x; // x is in parents stack
- void child_func (void) { x++: } // child references x as global var
- ...
- }
- */
-
-#define STATIC_CHAIN_REGNUM 10
-
-/* R1 is register in which address to store a structure value is passed to
- a function. This is used only when returning 64-bit long-long in a 32-bit arch
- and when calling functions that return structs by value. e.g.
- typedef struct A_s { int a,b,c; } A_t;
- A_t fun_returns_value (void) {
- A_t a; a.a=1; a.b=2 a.c=3;
- return a;
- }
- In the above, the storage for the return value is in the callers stack, and
- the R1 points at that mem location.
- */
-
-#define STRUCT_VALUE_REGNUM 1
-
-/* Define the classes of registers for register constraints in the
- machine description. Also define ranges of constants.
-
- One of the classes must always be named ALL_REGS and include all hard regs.
- If there is more than one class, another class must be named NO_REGS
- and contain no registers.
-
- The name GENERAL_REGS must be the name of a class (or an alias for
- another name such as ALL_REGS). This is the class of registers
- that is allowed by "g" or "r" in a register constraint.
- Also, registers outside this class are allocated only when
- instructions express preferences for them.
-
- The classes must be numbered in nondecreasing order; that is,
- a larger-numbered class must never be contained completely
- in a smaller-numbered class.
-
- For any two classes, it is very desirable that there be another
- class that represents their union. */
-
-enum reg_class
- {
- NO_REGS, ADDR_REGS, DATA_REGS,
- FP_REGS, ALL_REGS, LIM_REG_CLASSES
- };
-
-#define GENERAL_REGS DATA_REGS
-#define N_REG_CLASSES (int) LIM_REG_CLASSES
-
-/* Give names of register classes as strings for dump file. */
-
-#define REG_CLASS_NAMES \
-{ "NO_REGS", "ADDR_REGS", "DATA_REGS", "FP_REGS", "ALL_REGS" }
-
-/* Define which registers fit in which classes. This is an initializer for
- a vector of HARD_REG_SET of length N_REG_CLASSES. */
-
-#define REG_CLASS_CONTENTS {{0}, {0x0fffe}, {0x0ffff}, {0xf0000}, {0xfffff}}
-
-/* The same information, inverted:
- Return the class number of the smallest class containing
- reg number REGNO. This could be a conditional expression
- or could index an array. */
-
-#define REGNO_REG_CLASS(REGNO) \
- ((REGNO) >= 16 ? FP_REGS : (REGNO) != 0 ? ADDR_REGS : DATA_REGS)
-
-/* The class value for index registers, and the one for base regs. */
-
-#define INDEX_REG_CLASS ADDR_REGS
-#define BASE_REG_CLASS ADDR_REGS
-
-/* Get reg_class from a letter such as appears in the machine description. */
-
-#define REG_CLASS_FROM_LETTER(C) \
- ((C) == 'a' ? ADDR_REGS : \
- ((C) == 'd' ? DATA_REGS : \
- ((C) == 'f' ? FP_REGS : NO_REGS)))
-
-/* The letters I, J, K, L and M in a register constraint string can be used
- to stand for particular ranges of immediate operands.
- This macro defines what the ranges are.
- C is the letter, and VALUE is a constant value.
- Return 1 if VALUE is in the range specified by C. */
-
-#define CONST_OK_FOR_LETTER_P(VALUE, C) \
- ((C) == 'I' ? (unsigned) (VALUE) < 256 : \
- (C) == 'J' ? (unsigned) (VALUE) < 4096 : \
- (C) == 'K' ? (VALUE) >= -32768 && (VALUE) < 32768 : 0)
-
-/* Similar, but for floating constants, and defining letters G and H.
- Here VALUE is the CONST_DOUBLE rtx itself. */
-
-#define CONST_DOUBLE_OK_FOR_LETTER_P(VALUE, C) 1
-
-/* see recog.c for details */
-#define EXTRA_CONSTRAINT(OP,C) \
- ((C) == 'R' ? r_or_s_operand (OP, GET_MODE(OP)) : \
- (C) == 'S' ? s_operand (OP, GET_MODE(OP)) : 0) \
-
-/* Given an rtx X being reloaded into a reg required to be in class CLASS,
- return the class of reg to actually use. In general this is just CLASS;
- but on some machines in some cases it is preferable to use a more
- restrictive class.
-
- XXX We reload CONST_INT's into ADDR not DATA regs because on certain
- rare occasions when lots of egisters are spilled, reload() will try
- to put a const int into r0 and then use r0 as an index register.
-*/
-
-#define PREFERRED_RELOAD_CLASS(X, CLASS) \
- (GET_CODE(X) == CONST_DOUBLE ? FP_REGS : \
- GET_CODE(X) == CONST_INT ? (reload_in_progress ? ADDR_REGS : DATA_REGS) : \
- GET_CODE(X) == LABEL_REF || \
- GET_CODE(X) == SYMBOL_REF || \
- GET_CODE(X) == CONST ? ADDR_REGS : (CLASS))
-
-/* Return the maximum number of consecutive registers needed to represent
- mode MODE in a register of class CLASS.
- Note that DCmode (complex double) needs two regs.
-*/
-
-#define CLASS_MAX_NREGS(CLASS, MODE) \
- ((CLASS) == FP_REGS ? \
- ((GET_MODE_SIZE (MODE) + 2*UNITS_PER_WORD - 1) / (2*UNITS_PER_WORD)) : \
- (GET_MODE_SIZE (MODE) + UNITS_PER_WORD - 1) / UNITS_PER_WORD)
-
-/* Stack layout; function entry, exit and calling. */
-
-/* Define this if pushing a word on the stack makes the stack pointer a
- smaller address. */
-/* ------------------------------------------------------------------- */
-
-/* ================= */
-#ifdef TARGET_HLASM
-/* #define STACK_GROWS_DOWNWARD */
-
-/* Define this if the nominal address of the stack frame is at the
- high-address end of the local variables; that is, each additional local
- variable allocated goes at a more negative offset in the frame. */
-
-/* #define FRAME_GROWS_DOWNWARD */
-
-/* Offset within stack frame to start allocating local variables at.
- If FRAME_GROWS_DOWNWARD, this is the offset to the END of the
- first local allocated. Otherwise, it is the offset to the BEGINNING
- of the first local allocated. */
-
-#define STARTING_FRAME_OFFSET \
- (STACK_POINTER_OFFSET + current_function_outgoing_args_size)
-
-#define INITIAL_FRAME_POINTER_OFFSET(DEPTH) (DEPTH) = STARTING_FRAME_OFFSET
-
-/* If we generate an insn to push BYTES bytes, this says how many the stack
- pointer really advances by. On the 370, we have no push instruction. */
-
-#endif /* TARGET_HLASM */
-
-/* ================= */
-#ifdef TARGET_ELF_ABI
-
-/* With ELF/Linux, stack is placed at large virtual addrs and grows down.
- But we want the compiler to generate posistive displacements from the
- stack pointer, and so we make the frame lie above the stack. */
-
-#define STACK_GROWS_DOWNWARD
-/* #define FRAME_GROWS_DOWNWARD */
-
-/* Offset within stack frame to start allocating local variables at.
- This is the offset to the BEGINNING of the first local allocated. */
-
-#define STARTING_FRAME_OFFSET \
- (STACK_POINTER_OFFSET + current_function_outgoing_args_size)
-
-#define INITIAL_FRAME_POINTER_OFFSET(DEPTH) (DEPTH) = STARTING_FRAME_OFFSET
-
-#endif /* TARGET_ELF_ABI */
-/* ================= */
-
-/* #define PUSH_ROUNDING(BYTES) */
-
-/* Accumulate the outgoing argument count so we can request the right
- DSA size and determine stack offset. */
-
-#define ACCUMULATE_OUTGOING_ARGS 1
-
-/* Define offset from stack pointer, to location where a parm can be
- pushed. */
-
-#define STACK_POINTER_OFFSET 148
-
-/* Offset of first parameter from the argument pointer register value. */
-
-#define FIRST_PARM_OFFSET(FNDECL) 0
-
-/* 1 if N is a possible register number for function argument passing.
- On the 370, no registers are used in this way. */
-
-#define FUNCTION_ARG_REGNO_P(N) 0
-
-/* Define a data type for recording info about an argument list during
- the scan of that argument list. This data type should hold all
- necessary information about the function itself and about the args
- processed so far, enough to enable macros such as FUNCTION_ARG to
- determine where the next arg should go. */
-
-#define CUMULATIVE_ARGS int
-
-/* Initialize a variable CUM of type CUMULATIVE_ARGS for a call to
- a function whose data type is FNTYPE.
- For a library call, FNTYPE is 0. */
-
-#define INIT_CUMULATIVE_ARGS(CUM, FNTYPE, LIBNAME, INDIRECT, N_NAMED_ARGS) \
- ((CUM) = 0)
-
-/* Update the data in CUM to advance over an argument of mode MODE and
- data type TYPE. (TYPE is null for libcalls where that information
- may not be available.) */
-
-#define FUNCTION_ARG_ADVANCE(CUM, MODE, TYPE, NAMED) \
- ((CUM) += ((MODE) == DFmode || (MODE) == SFmode \
- ? 256 \
- : (MODE) != BLKmode \
- ? (GET_MODE_SIZE (MODE) + 3) / 4 \
- : (int_size_in_bytes (TYPE) + 3) / 4))
-
-/* Define where to put the arguments to a function. Value is zero to push
- the argument on the stack, or a hard register in which to store the
- argument. */
-
-#define FUNCTION_ARG(CUM, MODE, TYPE, NAMED) 0
-
-/* For an arg passed partly in registers and partly in memory, this is the
- number of registers used. For args passed entirely in registers or
- entirely in memory, zero. */
-
-#define FUNCTION_ARG_PARTIAL_NREGS(CUM, MODE, TYPE, NAMED) 0
-
-/* Define if returning from a function call automatically pops the
- arguments described by the number-of-args field in the call. */
-
-#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0
-
-/* The FUNCTION_VALUE macro defines how to find the value returned by a
- function. VALTYPE is the data type of the value (as a tree).
- If the precise function being called is known, FUNC is its FUNCTION_DECL;
- otherwise, FUNC is NULL.
-
- On the 370 the return value is in R15 or R16. However,
- DImode (64-bit ints) scalars need to get returned on the stack,
- with r15 pointing to the location. To accomplish this, we define
- the RETURN_IN_MEMORY macro to be true for both blockmode (structures)
- and the DImode scalars.
- */
-
-#define RET_REG(MODE) \
- (((MODE) == DCmode || (MODE) == SCmode \
- || (MODE) == DFmode || (MODE) == SFmode) ? 16 : 15)
-
-#define FUNCTION_VALUE(VALTYPE, FUNC) \
- gen_rtx_REG (TYPE_MODE (VALTYPE), RET_REG (TYPE_MODE (VALTYPE)))
-
-#define RETURN_IN_MEMORY(VALTYPE) \
- ((DImode == TYPE_MODE (VALTYPE)) || (BLKmode == TYPE_MODE (VALTYPE)))
-
-/* Define how to find the value returned by a library function assuming
- the value has mode MODE. */
-
-#define LIBCALL_VALUE(MODE) gen_rtx_REG (MODE, RET_REG (MODE))
-
-/* 1 if N is a possible register number for a function value.
- On the 370 under C/370, R15 and R16 are thus used. */
-
-#define FUNCTION_VALUE_REGNO_P(N) ((N) == 15 || (N) == 16)
-
-/* This macro definition sets up a default value for `main' to return. */
-
-#define DEFAULT_MAIN_RETURN c_expand_return (integer_zero_node)
-
-
-/* Output assembler code for a block containing the constant parts of a
- trampoline, leaving space for the variable parts.
-
- On the 370, the trampoline contains these instructions:
-
- BALR 14,0
- USING *,14
- L STATIC_CHAIN_REGISTER,X
- L 15,Y
- BR 15
- X DS 0F
- Y DS 0F */
-/*
- I am confused as to why this emitting raw binary, instead of instructions ...
- see for example, rs6000/rs000.c for an example of a different way to
- do this ... especially since BASR should probably be substituted for BALR.
- */
-
-#define TRAMPOLINE_TEMPLATE(FILE) \
-{ \
- assemble_aligned_integer (2, GEN_INT (0x05E0)); \
- assemble_aligned_integer (2, GEN_INT (0x5800 | STATIC_CHAIN_REGNUM << 4)); \
- assemble_aligned_integer (2, GEN_INT (0xE00A)); \
- assemble_aligned_integer (2, GEN_INT (0x58F0)); \
- assemble_aligned_integer (2, GEN_INT (0xE00E)); \
- assemble_aligned_integer (2, GEN_INT (0x07FF)); \
- assemble_aligned_integer (2, const0_rtx); \
- assemble_aligned_integer (2, const0_rtx); \
- assemble_aligned_integer (2, const0_rtx); \
- assemble_aligned_integer (2, const0_rtx); \
-}
-
-/* Length in units of the trampoline for entering a nested function. */
-
-#define TRAMPOLINE_SIZE 20
-
-/* Emit RTL insns to initialize the variable parts of a trampoline. */
-
-#define INITIALIZE_TRAMPOLINE(TRAMP, FNADDR, CXT) \
-{ \
- emit_move_insn (gen_rtx_MEM (SImode, plus_constant (TRAMP, 12)), CXT); \
- emit_move_insn (gen_rtx_MEM (SImode, plus_constant (TRAMP, 16)), FNADDR); \
-}
-
-/* Define EXIT_IGNORE_STACK if, when returning from a function, the stack
- pointer does not matter (provided there is a frame pointer). */
-
-#define EXIT_IGNORE_STACK 1
-
-/* Addressing modes, and classification of registers for them. */
-
-/* These assume that REGNO is a hard or pseudo reg number. They give
- nonzero only if REGNO is a hard reg of the suitable class or a pseudo
- reg currently allocated to a suitable hard reg.
- These definitions are NOT overridden anywhere. */
-
-#define REGNO_OK_FOR_INDEX_P(REGNO) \
- (((REGNO) > 0 && (REGNO) < 16) \
- || (reg_renumber[REGNO] > 0 && reg_renumber[REGNO] < 16))
-
-#define REGNO_OK_FOR_BASE_P(REGNO) REGNO_OK_FOR_INDEX_P(REGNO)
-
-#define REGNO_OK_FOR_DATA_P(REGNO) \
- ((REGNO) < 16 || (unsigned) reg_renumber[REGNO] < 16)
-
-#define REGNO_OK_FOR_FP_P(REGNO) \
- ((unsigned) ((REGNO) - 16) < 4 || (unsigned) (reg_renumber[REGNO] - 16) < 4)
-
-/* Now macros that check whether X is a register and also,
- strictly, whether it is in a specified class. */
-
-/* 1 if X is a data register. */
-
-#define DATA_REG_P(X) (REG_P (X) && REGNO_OK_FOR_DATA_P (REGNO (X)))
-
-/* 1 if X is an fp register. */
-
-#define FP_REG_P(X) (REG_P (X) && REGNO_OK_FOR_FP_P (REGNO (X)))
-
-/* 1 if X is an address register. */
-
-#define ADDRESS_REG_P(X) (REG_P (X) && REGNO_OK_FOR_BASE_P (REGNO (X)))
-
-/* Maximum number of registers that can appear in a valid memory address. */
-
-#define MAX_REGS_PER_ADDRESS 2
-
-/* Recognize any constant value that is a valid address. */
-
-#define CONSTANT_ADDRESS_P(X) \
- (GET_CODE (X) == LABEL_REF || GET_CODE (X) == SYMBOL_REF \
- || GET_CODE (X) == CONST_INT || GET_CODE (X) == CONST_DOUBLE \
- || (GET_CODE (X) == CONST \
- && GET_CODE (XEXP (XEXP (X, 0), 0)) == LABEL_REF) \
- || (GET_CODE (X) == CONST \
- && GET_CODE (XEXP (XEXP (X, 0), 0)) == SYMBOL_REF \
- && !SYMBOL_REF_EXTERNAL_P (XEXP (XEXP (X, 0), 0))))
-
-/* Nonzero if the constant value X is a legitimate general operand.
- It is given that X satisfies CONSTANT_P or is a CONST_DOUBLE. */
-
-#define LEGITIMATE_CONSTANT_P(X) 1
-
-/* The macros REG_OK_FOR..._P assume that the arg is a REG rtx and check
- its validity for a certain class. We have two alternate definitions
- for each of them. The usual definition accepts all pseudo regs; the
- other rejects them all. The symbol REG_OK_STRICT causes the latter
- definition to be used.
-
- Most source files want to accept pseudo regs in the hope that they will
- get allocated to the class that the insn wants them to be in.
- Some source files that are used after register allocation
- need to be strict. */
-
-#ifndef REG_OK_STRICT
-
-/* Nonzero if X is a hard reg that can be used as an index or if it is
- a pseudo reg. */
-
-#define REG_OK_FOR_INDEX_P(X) \
- ((REGNO(X) > 0 && REGNO(X) < 16) || REGNO(X) >= 20)
-
-/* Nonzero if X is a hard reg that can be used as a base reg or if it is
- a pseudo reg. */
-
-#define REG_OK_FOR_BASE_P(X) REG_OK_FOR_INDEX_P(X)
-
-#else /* REG_OK_STRICT */
-
-/* Nonzero if X is a hard reg that can be used as an index. */
-
-#define REG_OK_FOR_INDEX_P(X) REGNO_OK_FOR_INDEX_P(REGNO(X))
-
-/* Nonzero if X is a hard reg that can be used as a base reg. */
-
-#define REG_OK_FOR_BASE_P(X) REGNO_OK_FOR_BASE_P(REGNO(X))
-
-#endif /* REG_OK_STRICT */
-
-/* GO_IF_LEGITIMATE_ADDRESS recognizes an RTL expression that is a
- valid memory address for an instruction.
- The MODE argument is the machine mode for the MEM expression
- that wants to use this address.
-
- The other macros defined here are used only in GO_IF_LEGITIMATE_ADDRESS,
- except for CONSTANT_ADDRESS_P which is actually machine-independent.
-*/
-
-#define COUNT_REGS(X, REGS, FAIL) \
- if (REG_P (X)) { \
- if (REG_OK_FOR_BASE_P (X)) REGS += 1; \
- else goto FAIL; \
- } \
- else if (GET_CODE (X) != CONST_INT || (unsigned) INTVAL (X) >= 4096) \
- goto FAIL;
-
-#define GO_IF_LEGITIMATE_ADDRESS(MODE, X, ADDR) \
-{ \
- if (REG_P (X) && REG_OK_FOR_BASE_P (X)) \
- goto ADDR; \
- if (GET_CODE (X) == PLUS) \
- { \
- int regs = 0; \
- rtx x0 = XEXP (X, 0); \
- rtx x1 = XEXP (X, 1); \
- if (GET_CODE (x0) == PLUS) \
- { \
- COUNT_REGS (XEXP (x0, 0), regs, FAIL); \
- COUNT_REGS (XEXP (x0, 1), regs, FAIL); \
- COUNT_REGS (x1, regs, FAIL); \
- if (regs == 2) \
- goto ADDR; \
- } \
- else if (GET_CODE (x1) == PLUS) \
- { \
- COUNT_REGS (x0, regs, FAIL); \
- COUNT_REGS (XEXP (x1, 0), regs, FAIL); \
- COUNT_REGS (XEXP (x1, 1), regs, FAIL); \
- if (regs == 2) \
- goto ADDR; \
- } \
- else \
- { \
- COUNT_REGS (x0, regs, FAIL); \
- COUNT_REGS (x1, regs, FAIL); \
- if (regs != 0) \
- goto ADDR; \
- } \
- } \
- FAIL: ; \
-}
-
-/* The 370 has no mode dependent addresses. */
-
-#define GO_IF_MODE_DEPENDENT_ADDRESS(ADDR, LABEL)
-
-/* Macro: LEGITIMIZE_ADDRESS(X, OLDX, MODE, WIN)
- Try machine-dependent ways of modifying an illegitimate address
- to be legitimate. If we find one, return the new, valid address.
- This macro is used in only one place: `memory_address' in explow.c.
-
- Several comments:
- (1) It's not obvious that this macro results in better code
- than its omission does. For historical reasons we leave it in.
-
- (2) This macro may be (???) implicated in the accidental promotion
- or RS operand to RX operands, which bombs out any RS, SI, SS
- instruction that was expecting a simple address. Note that
- this occurs fairly rarely ...
-
- (3) There is a bug somewhere that causes either r4 to be spilled,
- or causes r0 to be used as a base register. Changeing the macro
- below will make the bug move around, but will not make it go away
- ... Note that this is a rare bug ...
-
- */
-
-#define LEGITIMIZE_ADDRESS(X, OLDX, MODE, WIN) \
-{ \
- if (GET_CODE (X) == PLUS && CONSTANT_ADDRESS_P (XEXP (X, 1))) \
- (X) = gen_rtx_PLUS (SImode, XEXP (X, 0), \
- copy_to_mode_reg (SImode, XEXP (X, 1))); \
- if (GET_CODE (X) == PLUS && CONSTANT_ADDRESS_P (XEXP (X, 0))) \
- (X) = gen_rtx_PLUS (SImode, XEXP (X, 1), \
- copy_to_mode_reg (SImode, XEXP (X, 0))); \
- if (GET_CODE (X) == PLUS && GET_CODE (XEXP (X, 0)) == MULT) \
- (X) = gen_rtx_PLUS (SImode, XEXP (X, 1), \
- force_operand (XEXP (X, 0), 0)); \
- if (GET_CODE (X) == PLUS && GET_CODE (XEXP (X, 1)) == MULT) \
- (X) = gen_rtx_PLUS (SImode, XEXP (X, 0), \
- force_operand (XEXP (X, 1), 0)); \
- if (memory_address_p (MODE, X)) \
- goto WIN; \
-}
-
-/* Specify the machine mode that this machine uses for the index in the
- tablejump instruction. */
-
-#define CASE_VECTOR_MODE SImode
-
-/* Define this if the tablejump instruction expects the table to contain
- offsets from the address of the table.
- Do not define this if the table should contain absolute addresses. */
-
-/* #define CASE_VECTOR_PC_RELATIVE */
-
-/* Define this if fixuns_trunc is the same as fix_trunc. */
-
-#define FIXUNS_TRUNC_LIKE_FIX_TRUNC
-
-/* We use "unsigned char" as default. */
-
-#define DEFAULT_SIGNED_CHAR 0
-
-/* Max number of bytes we can move from memory to memory in one reasonably
- fast instruction. */
-
-#define MOVE_MAX 256
-
-/* Nonzero if access to memory by bytes is slow and undesirable. */
-
-#define SLOW_BYTE_ACCESS 1
-
-/* Define if shifts truncate the shift count which implies one can omit
- a sign-extension or zero-extension of a shift count. */
-
-/* #define SHIFT_COUNT_TRUNCATED */
-
-/* Value is 1 if truncating an integer of INPREC bits to OUTPREC bits
- is done just by pretending it is already truncated. */
-
-#define TRULY_NOOP_TRUNCATION(OUTPREC, INPREC) (OUTPREC != 16)
-
-/* ??? Investigate defining STORE_FLAG_VALUE to (-1). */
-
-/* When a prototype says `char' or `short', really pass an `int'. */
-
-#define PROMOTE_PROTOTYPES 1
-
-/* Don't perform CSE on function addresses. */
-
-#define NO_FUNCTION_CSE
-
-/* Specify the machine mode that pointers have.
- After generation of rtl, the compiler makes no further distinction
- between pointers and any other objects of this machine mode. */
-
-#define Pmode SImode
-
-/* A function address in a call instruction is a byte address (for
- indexing purposes) so give the MEM rtx a byte's mode. */
-
-#define FUNCTION_MODE QImode
-
-/* A C statement (sans semicolon) to update the integer variable COST
- based on the relationship between INSN that is dependent on
- DEP_INSN through the dependence LINK. The default is to make no
- adjustment to COST. This can be used for example to specify to
- the scheduler that an output- or anti-dependence does not incur
- the same cost as a data-dependence.
-
- We will want to use this to indicate that there is a cost associated
- with the loading, followed by use of base registers ...
-#define ADJUST_COST (INSN, LINK, DEP_INSN, COST)
- */
-
-/* Tell final.c how to eliminate redundant test instructions. */
-
-/* Here we define machine-dependent flags and fields in cc_status
- (see `conditions.h'). */
-
-/* Store in cc_status the expressions that the condition codes will
- describe after execution of an instruction whose pattern is EXP.
- Do not alter them if the instruction would not alter the cc's.
-
- On the 370, load insns do not alter the cc's. However, in some
- cases these instructions can make it possibly invalid to use the
- saved cc's. In those cases we clear out some or all of the saved
- cc's so they won't be used.
-
- Note that only some arith instructions set the CC. These include
- add, subtract, complement, various shifts. Note that multiply
- and divide do *not* set set the CC. Therefore, in the code below,
- don't set the status for MUL, DIV, etc.
-
- Note that the bitwise ops set the condition code, but not in a
- way that we can make use of it. So we treat these as clobbering,
- rather than setting the CC. These are clobbered in the individual
- instruction patterns that use them. Use CC_STATUS_INIT to clobber.
-*/
-
-#define NOTICE_UPDATE_CC(EXP, INSN) \
-{ \
- rtx exp = (EXP); \
- if (GET_CODE (exp) == PARALLEL) /* Check this */ \
- exp = XVECEXP (exp, 0, 0); \
- if (GET_CODE (exp) != SET) \
- CC_STATUS_INIT; \
- else \
- { \
- if (XEXP (exp, 0) == cc0_rtx) \
- { \
- cc_status.value1 = XEXP (exp, 0); \
- cc_status.value2 = XEXP (exp, 1); \
- cc_status.flags = 0; \
- } \
- else \
- { \
- if (cc_status.value1 \
- && reg_mentioned_p (XEXP (exp, 0), cc_status.value1)) \
- cc_status.value1 = 0; \
- if (cc_status.value2 \
- && reg_mentioned_p (XEXP (exp, 0), cc_status.value2)) \
- cc_status.value2 = 0; \
- switch (GET_CODE (XEXP (exp, 1))) \
- { \
- case PLUS: case MINUS: case NEG: \
- case NOT: case ABS: \
- CC_STATUS_SET (XEXP (exp, 0), XEXP (exp, 1)); \
- \
- /* mult and div don't set any cc codes !! */ \
- case MULT: /* case UMULT: */ case DIV: case UDIV: \
- /* and, or and xor set the cc's the wrong way !! */ \
- case AND: case IOR: case XOR: \
- /* some shifts set the CC some don't. */ \
- case ASHIFT: case ASHIFTRT: \
- do {} while (0); \
- default: \
- break; \
- } \
- } \
- } \
-}
-
-
-#define CC_STATUS_SET(V1, V2) \
-{ \
- cc_status.flags = 0; \
- cc_status.value1 = (V1); \
- cc_status.value2 = (V2); \
- if (cc_status.value1 \
- && reg_mentioned_p (cc_status.value1, cc_status.value2)) \
- cc_status.value2 = 0; \
-}
-
-#define OUTPUT_JUMP(NORMAL, FLOAT, NO_OV) \
-{ if (cc_status.flags & CC_NO_OVERFLOW) return NO_OV; return NORMAL; }
-
-/* ------------------------------------------ */
-/* Control the assembler format that we output. */
-
-/* Define standard character escape sequences for non-ASCII targets
- only. */
-
-#ifdef TARGET_EBCDIC
-#define TARGET_ESC 39
-#define TARGET_BELL 47
-#define TARGET_BS 22
-#define TARGET_TAB 5
-#define TARGET_NEWLINE 21
-#define TARGET_VT 11
-#define TARGET_FF 12
-#define TARGET_CR 13
-#endif
-
-/* ======================================================== */
-
-#ifdef TARGET_HLASM
-#define TEXT_SECTION_ASM_OP "* Program text area"
-#define DATA_SECTION_ASM_OP "* Program data area"
-#define INIT_SECTION_ASM_OP "* Program initialization area"
-#define SHARED_SECTION_ASM_OP "* Program shared data"
-#define CTOR_LIST_BEGIN /* NO OP */
-#define CTOR_LIST_END /* NO OP */
-#define MAX_MVS_LABEL_SIZE 8
-
-/* How to refer to registers in assembler output. This sequence is
- indexed by compiler's hard-register-number (see above). */
-
-#define REGISTER_NAMES \
-{ "0", "1", "2", "3", "4", "5", "6", "7", \
- "8", "9", "10", "11", "12", "13", "14", "15", \
- "0", "2", "4", "6" \
-}
-
-#define ASM_COMMENT_START "*"
-#define ASM_APP_OFF ""
-#define ASM_APP_ON ""
-
-#define ASM_OUTPUT_LABEL(FILE, NAME) \
-{ assemble_name (FILE, NAME); fputs ("\tEQU\t*\n", FILE); }
-
-#define ASM_OUTPUT_EXTERNAL(FILE, DECL, NAME) \
-{ \
- char temp[MAX_MVS_LABEL_SIZE + 1]; \
- if (mvs_check_alias (NAME, temp) == 2) \
- { \
- fprintf (FILE, "%s\tALIAS\tC'%s'\n", temp, NAME); \
- } \
-}
-
-/* MVS externals are limited to 8 characters, upper case only.
- The '_' is mapped to '@', except for MVS functions, then '#'. */
-
-
-#define ASM_OUTPUT_LABELREF(FILE, NAME) \
-{ \
- char *bp, ch, temp[MAX_MVS_LABEL_SIZE + 1]; \
- if (!mvs_get_alias (NAME, temp)) \
- strcpy (temp, NAME); \
- if (!strcmp (temp,"main")) \
- strcpy (temp,"gccmain"); \
- if (mvs_function_check (temp)) \
- ch = '#'; \
- else \
- ch = '@'; \
- for (bp = temp; *bp; bp++) \
- *bp = (*bp == '_' ? ch : TOUPPER (*bp)); \
- fprintf (FILE, "%s", temp); \
-}
-
-#define ASM_GENERATE_INTERNAL_LABEL(LABEL, PREFIX, NUM) \
- sprintf (LABEL, "*%s%lu", PREFIX, (unsigned long)(NUM))
-
-/* Generate case label. For HLASM we can change to the data CSECT
- and put the vectors out of the code body. The assembler just
- concatenates CSECTs with the same name. */
-
-#define ASM_OUTPUT_CASE_LABEL(FILE, PREFIX, NUM, TABLE) \
- fprintf (FILE, "\tDS\t0F\n"); \
- fprintf (FILE,"\tCSECT\n"); \
- fprintf (FILE, "%s%d\tEQU\t*\n", PREFIX, NUM)
-
-/* Put the CSECT back to the code body */
-
-#define ASM_OUTPUT_CASE_END(FILE, NUM, TABLE) \
- assemble_name (FILE, mvs_function_name); \
- fputs ("\tCSECT\n", FILE);
-
-/* This is how to output an element of a case-vector that is absolute. */
-
-#define ASM_OUTPUT_ADDR_VEC_ELT(FILE, VALUE) \
- fprintf (FILE, "\tDC\tA(L%d)\n", VALUE)
-
-/* This is how to output an element of a case-vector that is relative. */
-
-#define ASM_OUTPUT_ADDR_DIFF_ELT(FILE, BODY, VALUE, REL) \
- fprintf (FILE, "\tDC\tA(L%d-L%d)\n", VALUE, REL)
-
-/* This is how to output an insn to push a register on the stack.
- It need not be very fast code.
- Right now, PUSH & POP are used only when profiling is enabled,
- and then, only to push the static chain reg and the function struct
- value reg, and only if those are used. Since profiling is not
- supported anyway, punt on this. */
-
-#define ASM_OUTPUT_REG_PUSH(FILE, REGNO) \
- mvs_check_page (FILE, 8, 4); \
- fprintf (FILE, "\tS\t13,=F'4'\n\tST\t%s,%d(13)\n", \
- reg_names[REGNO], STACK_POINTER_OFFSET)
-
-/* This is how to output an insn to pop a register from the stack.
- It need not be very fast code. */
-
-#define ASM_OUTPUT_REG_POP(FILE, REGNO) \
- mvs_check_page (FILE, 8, 0); \
- fprintf (FILE, "\tL\t%s,%d(13)\n\tLA\t13,4(13)\n", \
- reg_names[REGNO], STACK_POINTER_OFFSET)
-
-/* This outputs a text string. The string are chopped up to fit into
- an 80 byte record. Also, control and special characters, interpreted
- by the IBM assembler, are output numerically. */
-
-#define MVS_ASCII_TEXT_LENGTH 48
-
-#define ASM_OUTPUT_ASCII(FILE, PTR, LEN) \
-{ \
- size_t i, limit = (LEN); \
- int j; \
- for (j = 0, i = 0; i < limit; j++, i++) \
- { \
- int c = (PTR)[i]; \
- if (ISCNTRL (c) || c == '&') \
- { \
- if (j % MVS_ASCII_TEXT_LENGTH != 0 ) \
- fprintf (FILE, "'\n"); \
- j = -1; \
- fprintf (FILE, "\tDC\tX'%X'\n", c ); \
- } \
- else \
- { \
- if (j % MVS_ASCII_TEXT_LENGTH == 0) \
- fprintf (FILE, "\tDC\tC'"); \
- if ( c == '\'' ) \
- fprintf (FILE, "%c%c", c, c); \
- else \
- fprintf (FILE, "%c", c); \
- if (j % MVS_ASCII_TEXT_LENGTH == MVS_ASCII_TEXT_LENGTH - 1) \
- fprintf (FILE, "'\n" ); \
- } \
- } \
- if (j % MVS_ASCII_TEXT_LENGTH != 0) \
- fprintf (FILE, "'\n"); \
-}
-
-/* This is how to output an assembler line that says to advance the
- location counter to a multiple of 2**LOG bytes. */
-
-#define ASM_OUTPUT_ALIGN(FILE, LOG) \
- if (LOG) \
- { \
- if ((LOG) == 1) \
- fprintf (FILE, "\tDS\t0H\n" ); \
- else \
- fprintf (FILE, "\tDS\t0F\n" ); \
- } \
-
-/* The maximum length of memory that the IBM assembler will allow in one
- DS operation. */
-
-#define MAX_CHUNK 32767
-
-/* A C statement to output to the stdio stream FILE an assembler
- instruction to advance the location counter by SIZE bytes. Those
- bytes should be zero when loaded. */
-
-#define ASM_OUTPUT_SKIP(FILE, SIZE) \
-{ \
- unsigned HOST_WIDE_INT s; \
- int k; \
- for (s = (SIZE); s > 0; s -= MAX_CHUNK) \
- { \
- if (s > MAX_CHUNK) \
- k = MAX_CHUNK; \
- else \
- k = s; \
- fprintf (FILE, "\tDS\tXL%d\n", k); \
- } \
-}
-
-/* A C statement (sans semicolon) to output to the stdio stream
- FILE the assembler definition of a common-label named NAME whose
- size is SIZE bytes. The variable ROUNDED is the size rounded up
- to whatever alignment the caller wants. */
-
-#define ASM_OUTPUT_COMMON(FILE, NAME, SIZE, ROUNDED) \
-{ \
- char temp[MAX_MVS_LABEL_SIZE + 1]; \
- if (mvs_check_alias(NAME, temp) == 2) \
- { \
- fprintf (FILE, "%s\tALIAS\tC'%s'\n", temp, NAME); \
- } \
- fputs ("\tENTRY\t", FILE); \
- assemble_name (FILE, NAME); \
- fputs ("\n", FILE); \
- fprintf (FILE, "\tDS\t0F\n"); \
- ASM_OUTPUT_LABEL (FILE,NAME); \
- ASM_OUTPUT_SKIP (FILE,SIZE); \
-}
-
-/* A C statement (sans semicolon) to output to the stdio stream
- FILE the assembler definition of a local-common-label named NAME
- whose size is SIZE bytes. The variable ROUNDED is the size
- rounded up to whatever alignment the caller wants. */
-
-#define ASM_OUTPUT_LOCAL(FILE, NAME, SIZE, ROUNDED) \
-{ \
- fprintf (FILE, "\tDS\t0F\n"); \
- ASM_OUTPUT_LABEL (FILE,NAME); \
- ASM_OUTPUT_SKIP (FILE,SIZE); \
-}
-
-#define ASM_PN_FORMAT "%s%lu"
-
-/* Print operand XV (an rtx) in assembler syntax to file FILE.
- CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified.
- For `%' followed by punctuation, CODE is the punctuation and XV is null. */
-
-#define PRINT_OPERAND(FILE, XV, CODE) \
-{ \
- switch (GET_CODE (XV)) \
- { \
- static char curreg[4]; \
- case REG: \
- if (CODE == 'N') \
- strcpy (curreg, reg_names[REGNO (XV) + 1]); \
- else \
- strcpy (curreg, reg_names[REGNO (XV)]); \
- fprintf (FILE, "%s", curreg); \
- break; \
- case MEM: \
- { \
- rtx addr = XEXP (XV, 0); \
- if (CODE == 'O') \
- { \
- if (GET_CODE (addr) == PLUS) \
- fprintf (FILE, HOST_WIDE_INT_PRINT_DEC, INTVAL (XEXP (addr, 1))); \
- else \
- fprintf (FILE, "0"); \
- } \
- else if (CODE == 'R') \
- { \
- if (GET_CODE (addr) == PLUS) \
- fprintf (FILE, "%s", reg_names[REGNO (XEXP (addr, 0))]);\
- else \
- fprintf (FILE, "%s", reg_names[REGNO (addr)]); \
- } \
- else \
- output_address (XEXP (XV, 0)); \
- } \
- break; \
- case SYMBOL_REF: \
- case LABEL_REF: \
- mvs_page_lit += 4; \
- if (SYMBOL_REF_EXTERNAL_P (XV)) fprintf (FILE, "=V("); \
- else fprintf (FILE, "=A("); \
- output_addr_const (FILE, XV); \
- fprintf (FILE, ")"); \
- break; \
- case CONST_INT: \
- if (CODE == 'B') \
- fprintf (FILE, "%d", (int) (INTVAL (XV) & 0xff)); \
- else if (CODE == 'X') \
- fprintf (FILE, "%02X", (int) (INTVAL (XV) & 0xff)); \
- else if (CODE == 'h') \
- fprintf (FILE, HOST_WIDE_INT_PRINT_DEC, (INTVAL (XV) << 16) >> 16); \
- else if (CODE == 'H') \
- { \
- mvs_page_lit += 2; \
- fprintf (FILE, "=H'" HOST_WIDE_INT_PRINT_DEC "'", (INTVAL (XV) << 16) >> 16); \
- } \
- else if (CODE == 'K') \
- { \
- /* auto sign-extension of signed 16-bit to signed 32-bit */ \
- mvs_page_lit += 4; \
- fprintf (FILE, "=F'" HOST_WIDE_INT_PRINT_DEC "'", (INTVAL (XV) << 16) >> 16); \
- } \
- else if (CODE == 'W') \
- { \
- /* hand-built sign-extension of signed 32-bit to 64-bit */ \
- mvs_page_lit += 8; \
- if (0 <= INTVAL (XV)) { \
- fprintf (FILE, "=XL8'00000000"); \
- } else { \
- fprintf (FILE, "=XL8'FFFFFFFF"); \
- } \
- fprintf (FILE, "%08X'", INTVAL (XV)); \
- } \
- else \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=F'" HOST_WIDE_INT_PRINT_DEC "'", INTVAL (XV)); \
- } \
- break; \
- case CONST_DOUBLE: \
- if (GET_MODE (XV) == DImode) \
- { \
- if (CODE == 'M') \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=XL4'%08X'", CONST_DOUBLE_LOW (XV)); \
- } \
- else if (CODE == 'L') \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=XL4'%08X'", CONST_DOUBLE_HIGH (XV)); \
- } \
- else \
- { \
- mvs_page_lit += 8; \
- fprintf (FILE, "=XL8'%08X%08X'", CONST_DOUBLE_LOW (XV), \
- CONST_DOUBLE_HIGH (XV)); \
- } \
- } \
- else \
- { \
- char buf[50]; \
- if (GET_MODE (XV) == SFmode) \
- { \
- mvs_page_lit += 4; \
- real_to_decimal (buf, CONST_DOUBLE_REAL_VALUE (XV), \
- sizeof (buf), 0, 1); \
- fprintf (FILE, "=E'%s'", buf); \
- } \
- else if (GET_MODE (XV) == DFmode) \
- { \
- mvs_page_lit += 8; \
- real_to_decimal (buf, CONST_DOUBLE_REAL_VALUE (XV), \
- sizeof (buf), 0, 1); \
- fprintf (FILE, "=D'%s'", buf); \
- } \
- else /* VOIDmode */ \
- { \
- mvs_page_lit += 8; \
- fprintf (FILE, "=XL8'%08X%08X'", \
- CONST_DOUBLE_HIGH (XV), CONST_DOUBLE_LOW (XV)); \
- } \
- } \
- break; \
- case CONST: \
- if (GET_CODE (XEXP (XV, 0)) == PLUS \
- && GET_CODE (XEXP (XEXP (XV, 0), 0)) == SYMBOL_REF) \
- { \
- mvs_page_lit += 4; \
- if (SYMBOL_REF_EXTERNAL_P (XEXP (XEXP (XV, 0), 0))) \
- { \
- fprintf (FILE, "=V("); \
- ASM_OUTPUT_LABELREF (FILE, \
- XSTR (XEXP (XEXP (XV, 0), 0), 0)); \
- fprintf (FILE, ")\n\tA\t%s,=F'" HOST_WIDE_INT_PRINT_DEC "'", \
- curreg, INTVAL (XEXP (XEXP (XV, 0), 1))); \
- } \
- else \
- { \
- fprintf (FILE, "=A("); \
- output_addr_const (FILE, XV); \
- fprintf (FILE, ")"); \
- } \
- } \
- else \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=F'"); \
- output_addr_const (FILE, XV); \
- fprintf (FILE, "'"); \
- } \
- break; \
- default: \
- abort(); \
- } \
-}
-
-#define PRINT_OPERAND_ADDRESS(FILE, ADDR) \
-{ \
- rtx breg, xreg, offset, plus; \
- \
- switch (GET_CODE (ADDR)) \
- { \
- case REG: \
- fprintf (FILE, "0(%s)", reg_names[REGNO (ADDR)]); \
- break; \
- case PLUS: \
- breg = 0; \
- xreg = 0; \
- offset = 0; \
- if (GET_CODE (XEXP (ADDR, 0)) == PLUS) \
- { \
- if (GET_CODE (XEXP (ADDR, 1)) == REG) \
- breg = XEXP (ADDR, 1); \
- else \
- offset = XEXP (ADDR, 1); \
- plus = XEXP (ADDR, 0); \
- } \
- else \
- { \
- if (GET_CODE (XEXP (ADDR, 0)) == REG) \
- breg = XEXP (ADDR, 0); \
- else \
- offset = XEXP (ADDR, 0); \
- plus = XEXP (ADDR, 1); \
- } \
- if (GET_CODE (plus) == PLUS) \
- { \
- if (GET_CODE (XEXP (plus, 0)) == REG) \
- { \
- if (breg) \
- xreg = XEXP (plus, 0); \
- else \
- breg = XEXP (plus, 0); \
- } \
- else \
- { \
- offset = XEXP (plus, 0); \
- } \
- if (GET_CODE (XEXP (plus, 1)) == REG) \
- { \
- if (breg) \
- xreg = XEXP (plus, 1); \
- else \
- breg = XEXP (plus, 1); \
- } \
- else \
- { \
- offset = XEXP (plus, 1); \
- } \
- } \
- else if (GET_CODE (plus) == REG) \
- { \
- if (breg) \
- xreg = plus; \
- else \
- breg = plus; \
- } \
- else \
- { \
- offset = plus; \
- } \
- if (offset) \
- { \
- if (GET_CODE (offset) == LABEL_REF) \
- fprintf (FILE, "L%d", \
- CODE_LABEL_NUMBER (XEXP (offset, 0))); \
- else \
- output_addr_const (FILE, offset); \
- } \
- else \
- fprintf (FILE, "0"); \
- if (xreg) \
- fprintf (FILE, "(%s,%s)", \
- reg_names[REGNO (xreg)], reg_names[REGNO (breg)]); \
- else \
- fprintf (FILE, "(%s)", reg_names[REGNO (breg)]); \
- break; \
- default: \
- mvs_page_lit += 4; \
- if (SYMBOL_REF_EXTERNAL_P (ADDR)) fprintf (FILE, "=V("); \
- else fprintf (FILE, "=A("); \
- output_addr_const (FILE, ADDR); \
- fprintf (FILE, ")"); \
- break; \
- } \
-}
-
-#define ASM_DECLARE_FUNCTION_NAME(FILE, NAME, DECL) \
-{ \
- if (strlen (NAME) + 1 > mvs_function_name_length) \
- { \
- if (mvs_function_name) \
- free (mvs_function_name); \
- mvs_function_name = 0; \
- } \
- if (!mvs_function_name) \
- { \
- mvs_function_name_length = strlen (NAME) * 2 + 1; \
- mvs_function_name = (char *) xmalloc (mvs_function_name_length); \
- } \
- if (!strcmp (NAME, "main")) \
- strcpy (mvs_function_name, "gccmain"); \
- else \
- strcpy (mvs_function_name, NAME); \
- fprintf (FILE, "\tDS\t0F\n"); \
- assemble_name (FILE, mvs_function_name); \
- fputs ("\tRMODE\tANY\n", FILE); \
- assemble_name (FILE, mvs_function_name); \
- fputs ("\tCSECT\n", FILE); \
-}
-
-/* Output assembler code to FILE to increment profiler label # LABELNO
- for profiling a function entry. */
-
-#define FUNCTION_PROFILER(FILE, LABELNO) \
- fprintf (FILE, "Error: No profiling available.\n")
-
-#endif /* TARGET_HLASM */
-
-/* ======================================================== */
-
-#ifdef TARGET_ELF_ABI
-
-/* How to refer to registers in assembler output. This sequence is
- indexed by compiler's hard-register-number (see above). */
-
-#define REGISTER_NAMES \
-{ "r0", "r1", "r2", "r3", "r4", "r5", "r6", "r7", \
- "r8", "r9", "r10", "r11", "r12", "r13", "r14", "r15", \
- "f0", "f2", "f4", "f6" \
-}
-
-/* Print operand XV (an rtx) in assembler syntax to file FILE.
- CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified.
- For `%' followed by punctuation, CODE is the punctuation and XV is null. */
-
-#define PRINT_OPERAND(FILE, XV, CODE) \
-{ \
- switch (GET_CODE (XV)) \
- { \
- static char curreg[4]; \
- case REG: \
- if (CODE == 'N') \
- strcpy (curreg, reg_names[REGNO (XV) + 1]); \
- else \
- strcpy (curreg, reg_names[REGNO (XV)]); \
- fprintf (FILE, "%s", curreg); \
- break; \
- case MEM: \
- { \
- rtx addr = XEXP (XV, 0); \
- if (CODE == 'O') \
- { \
- if (GET_CODE (addr) == PLUS) \
- fprintf (FILE, HOST_WIDE_INT_PRINT_DEC, INTVAL (XEXP (addr, 1))); \
- else \
- fprintf (FILE, "0"); \
- } \
- else if (CODE == 'R') \
- { \
- if (GET_CODE (addr) == PLUS) \
- fprintf (FILE, "%s", reg_names[REGNO (XEXP (addr, 0))]);\
- else \
- fprintf (FILE, "%s", reg_names[REGNO (addr)]); \
- } \
- else \
- output_address (XEXP (XV, 0)); \
- } \
- break; \
- case SYMBOL_REF: \
- case LABEL_REF: \
- mvs_page_lit += 4; \
- if (SYMBOL_REF_EXTERNAL_P (XV)) fprintf (FILE, "=V("); \
- else fprintf (FILE, "=A("); \
- output_addr_const (FILE, XV); \
- fprintf (FILE, ")"); \
- break; \
- case CONST_INT: \
- if (CODE == 'B') \
- fprintf (FILE, "%d", (int) (INTVAL (XV) & 0xff)); \
- else if (CODE == 'X') \
- fprintf (FILE, "%02X", (int) (INTVAL (XV) & 0xff)); \
- else if (CODE == 'h') \
- fprintf (FILE, HOST_WIDE_INT_PRINT_DEC, (INTVAL (XV) << 16) >> 16); \
- else if (CODE == 'H') \
- { \
- mvs_page_lit += 2; \
- fprintf (FILE, "=H'" HOST_WIDE_INT_PRINT_DEC "'", \
- (INTVAL (XV) << 16) >> 16); \
- } \
- else if (CODE == 'K') \
- { \
- /* auto sign-extension of signed 16-bit to signed 32-bit */ \
- mvs_page_lit += 4; \
- fprintf (FILE, "=F'" HOST_WIDE_INT_PRINT_DEC "'", \
- (INTVAL (XV) << 16) >> 16); \
- } \
- else if (CODE == 'W') \
- { \
- /* hand-built sign-extension of signed 32-bit to 64-bit */ \
- mvs_page_lit += 8; \
- if (0 <= INTVAL (XV)) { \
- fprintf (FILE, "=XL8'00000000"); \
- } else { \
- fprintf (FILE, "=XL8'FFFFFFFF"); \
- } \
- fprintf (FILE, "%08X'", INTVAL (XV)); \
- } \
- else \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=F'" HOST_WIDE_INT_PRINT_DEC "'", INTVAL (XV)); \
- } \
- break; \
- case CONST_DOUBLE: \
- if (GET_MODE (XV) == DImode) \
- { \
- if (CODE == 'M') \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=XL4'%08X'", CONST_DOUBLE_LOW (XV)); \
- } \
- else if (CODE == 'L') \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=XL4'%08X'", CONST_DOUBLE_HIGH (XV)); \
- } \
- else \
- { \
- mvs_page_lit += 8; \
- fprintf (FILE, "=yyyyXL8'%08X%08X'", \
- CONST_DOUBLE_HIGH (XV), CONST_DOUBLE_LOW (XV)); \
- } \
- } \
- else \
- { \
- char buf[50]; \
- if (GET_MODE (XV) == SFmode) \
- { \
- mvs_page_lit += 4; \
- real_to_decimal (buf, CONST_DOUBLE_REAL_VALUE (XV), \
- sizeof (buf), 0, 1); \
- fprintf (FILE, "=E'%s'", buf); \
- } \
- else if (GET_MODE (XV) == DFmode) \
- { \
- mvs_page_lit += 8; \
- real_to_decimal (buf, CONST_DOUBLE_REAL_VALUE (XV), \
- sizeof (buf), 0, 1); \
- fprintf (FILE, "=D'%s'", buf); \
- } \
- else /* VOIDmode */ \
- { \
- mvs_page_lit += 8; \
- fprintf (FILE, "=XL8'%08X%08X'", \
- CONST_DOUBLE_HIGH (XV), CONST_DOUBLE_LOW (XV)); \
- } \
- } \
- break; \
- case CONST: \
- if (GET_CODE (XEXP (XV, 0)) == PLUS \
- && GET_CODE (XEXP (XEXP (XV, 0), 0)) == SYMBOL_REF) \
- { \
- mvs_page_lit += 4; \
- if (SYMBOL_REF_EXTERNAL_P (XEXP (XEXP (XV, 0), 0))) \
- { \
- fprintf (FILE, "=V("); \
- ASM_OUTPUT_LABELREF (FILE, \
- XSTR (XEXP (XEXP (XV, 0), 0), 0)); \
- fprintf (FILE, ")\n\tA\t%s,=F'" HOST_WIDE_INT_PRINT_DEC "'", \
- curreg, INTVAL (XEXP (XEXP (XV, 0), 1))); \
- } \
- else \
- { \
- fprintf (FILE, "=A("); \
- output_addr_const (FILE, XV); \
- fprintf (FILE, ")"); \
- } \
- } \
- else \
- { \
- mvs_page_lit += 4; \
- fprintf (FILE, "=bogus_bad_F'"); \
- output_addr_const (FILE, XV); \
- fprintf (FILE, "'"); \
-/* XXX hack alert this gets gen'd in -fPIC code in relation to a tablejump */ \
-/* but its somehow fundamentally broken, I can't make any sense out of it */ \
-debug_rtx (XV); \
-abort(); \
- } \
- break; \
- default: \
- abort(); \
- } \
-}
-
-#define PRINT_OPERAND_ADDRESS(FILE, ADDR) \
-{ \
- rtx breg, xreg, offset, plus; \
- \
- switch (GET_CODE (ADDR)) \
- { \
- case REG: \
- fprintf (FILE, "0(%s)", reg_names[REGNO (ADDR)]); \
- break; \
- case PLUS: \
- breg = 0; \
- xreg = 0; \
- offset = 0; \
- if (GET_CODE (XEXP (ADDR, 0)) == PLUS) \
- { \
- if (GET_CODE (XEXP (ADDR, 1)) == REG) \
- breg = XEXP (ADDR, 1); \
- else \
- offset = XEXP (ADDR, 1); \
- plus = XEXP (ADDR, 0); \
- } \
- else \
- { \
- if (GET_CODE (XEXP (ADDR, 0)) == REG) \
- breg = XEXP (ADDR, 0); \
- else \
- offset = XEXP (ADDR, 0); \
- plus = XEXP (ADDR, 1); \
- } \
- if (GET_CODE (plus) == PLUS) \
- { \
- if (GET_CODE (XEXP (plus, 0)) == REG) \
- { \
- if (breg) \
- xreg = XEXP (plus, 0); \
- else \
- breg = XEXP (plus, 0); \
- } \
- else \
- { \
- offset = XEXP (plus, 0); \
- } \
- if (GET_CODE (XEXP (plus, 1)) == REG) \
- { \
- if (breg) \
- xreg = XEXP (plus, 1); \
- else \
- breg = XEXP (plus, 1); \
- } \
- else \
- { \
- offset = XEXP (plus, 1); \
- } \
- } \
- else if (GET_CODE (plus) == REG) \
- { \
- if (breg) \
- xreg = plus; \
- else \
- breg = plus; \
- } \
- else \
- { \
- offset = plus; \
- } \
- if (offset) \
- { \
- if (GET_CODE (offset) == LABEL_REF) \
- fprintf (FILE, "L%d", \
- CODE_LABEL_NUMBER (XEXP (offset, 0))); \
- else \
- output_addr_const (FILE, offset); \
- } \
- else \
- fprintf (FILE, "0"); \
- if (xreg) \
- fprintf (FILE, "(%s,%s)", \
- reg_names[REGNO (xreg)], reg_names[REGNO (breg)]); \
- else \
- fprintf (FILE, "(%s)", reg_names[REGNO (breg)]); \
- break; \
- default: \
- mvs_page_lit += 4; \
- if (SYMBOL_REF_EXTERNAL_P (ADDR)) fprintf (FILE, "=V("); \
- else fprintf (FILE, "=A("); \
- output_addr_const (FILE, ADDR); \
- fprintf (FILE, ")"); \
- break; \
- } \
-}
-
-/* Output assembler code to FILE to increment profiler label # LABELNO
- for profiling a function entry. */
-/* Make it a no-op for now, so we can at least compile glibc */
-#define FUNCTION_PROFILER(FILE, LABELNO) { \
- mvs_check_page (FILE, 24, 4); \
- fprintf (FILE, "\tSTM\tr1,r2,%d(sp)\n", STACK_POINTER_OFFSET-8); \
- fprintf (FILE, "\tLA\tr1,1(0,0)\n"); \
- fprintf (FILE, "\tL\tr2,=A(.LP%d)\n", LABELNO); \
- fprintf (FILE, "\tA\tr1,0(r2)\n"); \
- fprintf (FILE, "\tST\tr1,0(r2)\n"); \
- fprintf (FILE, "\tLM\tr1,r2,%d(sp)\n", STACK_POINTER_OFFSET-8); \
-}
-
-/* Don't bother to output .extern pseudo-ops. They are not needed by
- ELF assemblers. */
-
-#undef ASM_OUTPUT_EXTERNAL
-
-#define ASM_DOUBLE "\t.double"
-
-/* #define ASM_OUTPUT_LABELREF(FILE, NAME) */ /* use gas -- defaults.h */
-
-/* let config/svr4.h define this ...
- * #define ASM_OUTPUT_CASE_LABEL(FILE, PREFIX, NUM, TABLE)
- * fprintf (FILE, "%s%d:\n", PREFIX, NUM)
- */
-
-/* This is how to output an element of a case-vector that is absolute. */
-#define ASM_OUTPUT_ADDR_VEC_ELT(FILE, VALUE) \
- mvs_check_page (FILE, 4, 0); \
- fprintf (FILE, "\t.long\t.L%d\n", VALUE)
-
-/* This is how to output an element of a case-vector that is relative. */
-#define ASM_OUTPUT_ADDR_DIFF_ELT(FILE, BODY, VALUE, REL) \
- mvs_check_page (FILE, 4, 0); \
- fprintf (FILE, "\t.long\t.L%d-.L%d\n", VALUE, REL)
-
-/* Right now, PUSH & POP are used only when profiling is enabled,
- and then, only to push the static chain reg and the function struct
- value reg, and only if those are used by the function being profiled.
- We don't need this for profiling, so punt. */
-#define ASM_OUTPUT_REG_PUSH(FILE, REGNO)
-#define ASM_OUTPUT_REG_POP(FILE, REGNO)
-
-
-/* Indicate that jump tables go in the text section. This is
- necessary when compiling PIC code. */
-#define JUMP_TABLES_IN_TEXT_SECTION 1
-
-/* Define macro used to output shift-double opcodes when the shift
- count is in %cl. Some assemblers require %cl as an argument;
- some don't.
-
- GAS requires the %cl argument, so override i386/unix.h. */
-
-#undef SHIFT_DOUBLE_OMITS_COUNT
-#define SHIFT_DOUBLE_OMITS_COUNT 0
-
-/* Implicit library calls should use memcpy, not bcopy, etc. */
-#define TARGET_MEM_FUNCTIONS
-
-/* Output before read-only data. */
-#define TEXT_SECTION_ASM_OP "\t.text"
-
-/* Output before writable (initialized) data. */
-#define DATA_SECTION_ASM_OP "\t.data"
-
-/* Output before writable (uninitialized) data. */
-#define BSS_SECTION_ASM_OP "\t.bss"
-
-/* In the past there was confusion as to what the argument to .align was
- in GAS. For the last several years the rule has been this: for a.out
- file formats that argument is LOG, and for all other file formats the
- argument is 1<<LOG.
-
- However, GAS now has .p2align and .balign pseudo-ops so to remove any
- doubt or guess work, and since this file is used for both a.out and other
- file formats, we use one of them. */
-
-#define ASM_OUTPUT_ALIGN(FILE,LOG) \
- if ((LOG)!=0) fprintf ((FILE), "\t.balign %d\n", 1<<(LOG))
-
-/* Globalizing directive for a label. */
-#define GLOBAL_ASM_OP ".globl "
-
-/* This says how to output an assembler line
- to define a global common symbol. */
-
-#define ASM_OUTPUT_COMMON(FILE, NAME, SIZE, ROUNDED) \
-( fputs (".comm ", (FILE)), \
- assemble_name ((FILE), (NAME)), \
- fprintf ((FILE), ","HOST_WIDE_INT_PRINT_UNSIGNED"\n", (ROUNDED)))
-
-/* This says how to output an assembler line
- to define a local common symbol. */
-
-#define ASM_OUTPUT_LOCAL(FILE, NAME, SIZE, ROUNDED) \
-( fputs (".lcomm ", (FILE)), \
- assemble_name ((FILE), (NAME)), \
- fprintf ((FILE), ","HOST_WIDE_INT_PRINT_UNSIGNED"\n", (ROUNDED)))
-
-#endif /* TARGET_ELF_ABI */
-#endif /* ! GCC_I370_H */
+++ /dev/null
-;;- Machine description for GNU compiler -- System/370 version.
-;; Copyright (C) 1989, 1993, 1994, 1995, 1997, 1998, 1999, 2000, 2002
-;; Free Software Foundation, Inc.
-;; Contributed by Jan Stein (jan@cd.chalmers.se).
-;; Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
-;; Lots of Bug Fixes & Enhancements by Linas Vepstas (linas@linas.org)
-
-;; This file is part of GCC.
-
-;; GCC is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GCC is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GCC; see the file COPYING. If not, write to
-;; the Free Software Foundation, 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;; =======================================================================
-;; Condition codes for some of the instructions (in particular, for
-;; add, sub, shift, abs, etc. are handled with the cpp macro NOTICE_UPDATE_CC
-;;
-;; Special constraints for 370 machine description:
-;;
-;; a -- Any address register from 1 to 15.
-;; d -- Any register from 0 to 15.
-;; I -- An 8-bit constant (0..255).
-;; J -- A 12-bit constant (0..4095).
-;; K -- A 16-bit constant (-32768..32767).
-;; R -- a valid S operand in an RS, SI or SS instruction, or register
-;; S -- a valid S operand in an RS, SI or SS instruction
-;;
-;; Note this well:
-;; When defining an instruction, e.g. the movsi pattern:
-;;
-;; (define_insn ""
-;; [(set (match_operand:SI 0 "r_or_s_operand" "=dm,d,dm")
-;; (match_operand:SI 1 "r_or_s_operand" "diR,dim,*fF"))]
-;;
-;; The "r_or_s_operand" predicate is used to recognize the instruction;
-;; however, it is not further used to enforce a constraint at later stages.
-;; Thus, for example, although "r_or_s_operand" bars operands of the form
-;; base+index+displacement, such operands can none-the-less show up during
-;; post-instruction-recog processing: thus, for example, garbage like
-;; MVC 152(4,r13),0(r5,r13) might be generated if both op0 and op1 are
-;; mem operands. To avoid this, use the S constraint.
-;;
-;;
-;; Special formats used for outputting 370 instructions.
-;;
-;; %B -- Print a constant byte integer.
-;; %H -- Print a signed 16-bit constant.
-;; %K -- Print a signed 16-bit constant signed-extended to 32-bits.
-;; %L -- Print least significant word of a CONST_DOUBLE.
-;; %M -- Print most significant word of a CONST_DOUBLE.
-;; %N -- Print next register (second word of a DImode reg).
-;; %O -- Print the offset of a memory reference (PLUS (REG) (CONST_INT)).
-;; %R -- Print the register of a memory reference (PLUS (REG) (CONST_INT)).
-;; %X -- Print a constant byte integer in hex.
-;; %W -- Print a signed 32-bit int sign-extended to 64-bits.
-;;
-;; We have a special constraint for pattern matching.
-;;
-;; s_operand -- Matches a valid S operand in a RS, SI or SS type instruction.
-;;
-;; r_or_s_operand -- Matches a register or a valid S operand in a RS, SI
-;; or SS type instruction or a register
-;;
-;; For MVS C/370 we use the following stack locations for:
-;;
-;; 136 - internal function result buffer
-;; 140 - numeric conversion buffer
-;; 144 - pointer to internal function result buffer
-;; 148 - start of automatic variables and function arguments
-;;
-;; To support programs larger than a page, 4096 bytes, PAGE_REGISTER points
-;; to a page origin table, all internal labels are generated to reload the
-;; BASE_REGISTER knowing what page it is on and all branch instructions go
-;; directly to the target if it is known that the target is on the current
-;; page (essentially backward references). All forward references and off
-;; page references are handled by loading the address of target into a
-;; register and branching indirectly.
-;;
-;; Some *di patterns have been commented out per advice from RMS, as gcc
-;; will generate the right things to do.
-;;
-;; See the note in i370.h about register 14, clobbering it, and optimization.
-;; Basically, using clobber in egcs-1.1.1 will ruin ability to optimize around
-;; branches, so don't do it.
-;;
-;; We use the "length" attirbute to store the max possible code size of an
-;; insn. We use this length to estimate the length of forward branches, to
-;; determine if they're on page or off.
-
-(define_attr "length" "" (const_int 0))
-
-;;
-;;- Test instructions.
-;;
-
-;
-; tstdi instruction pattern(s).
-;
-
-(define_insn "tstdi"
- [(set (cc0)
- (match_operand:DI 0 "register_operand" "d"))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- return \"SRDA %0,0\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; tstsi instruction pattern(s).
-;
-
-(define_insn "tstsi"
- [(set (cc0)
- (match_operand:SI 0 "register_operand" "d"))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LTR %0,%0\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; tsthi instruction pattern(s).
-;
-
-(define_insn "tsthi"
- [(set (cc0)
- (match_operand:HI 0 "register_operand" "d"))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 2);
- return \"CH %0,=H'0'\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; tstqi instruction pattern(s).
-;
-
-(define_insn ""
- [(set (cc0)
- (match_operand:QI 0 "r_or_s_operand" "dm"))]
- "unsigned_jump_follows_p (insn)"
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- /* an unsigned compare to zero is always zero/not-zero... */
- mvs_check_page (0, 4, 4);
- return \"N %0,=XL4'000000FF'\";
- }
- mvs_check_page (0, 4, 0);
- return \"CLI %0,0\";
-}"
- [(set_attr "length" "4")]
-)
-
-(define_insn "tstqi"
- [(set (cc0)
- (match_operand:QI 0 "register_operand" "d"))]
- ""
- "*
-{
- check_label_emit ();
- if (unsigned_jump_follows_p (insn))
- {
- /* an unsigned compare to zero is always zero/not-zero... */
- mvs_check_page (0, 4, 4);
- return \"N %0,=XL4'000000FF'\";
- }
- mvs_check_page (0, 8, 0);
- return \"SLL %0,24\;SRA %0,24\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; tstdf instruction pattern(s).
-;
-
-(define_insn "tstdf"
- [(set (cc0)
- (match_operand:DF 0 "general_operand" "f"))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LTDR %0,%0\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; tstsf instruction pattern(s).
-;
-
-(define_insn "tstsf"
- [(set (cc0)
- (match_operand:SF 0 "general_operand" "f"))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LTER %0,%0\";
-}"
- [(set_attr "length" "2")]
-)
-
-;;
-;;- Compare instructions.
-;;
-
-;
-; cmpdi instruction pattern(s).
-;
-
-;(define_insn "cmpdi"
-; [(set (cc0)
-; (compare (match_operand:DI 0 "register_operand" "d")
-; (match_operand:DI 1 "general_operand" "")))]
-; ""
-; "*
-;{
-; check_label_emit ();
-; if (REG_P (operands[1]))
-; {
-; mvs_check_page (0, 8, 0);
-; if (unsigned_jump_follows_p (insn))
-; return \"CLR %0,%1\;BNE *+6\;CLR %N0,%N1\";
-; return \"CR %0,%1\;BNE *+6\;CLR %N0,%N1\";
-; }
-; mvs_check_page (0, 12, 0);
-; if (unsigned_jump_follows_p (insn))
-; return \"CL %0,%M1\;BNE *+8\;CL %N0,%L1\";
-; return \"C %0,%M1\;BNE *+8\;CL %N0,%L1\";
-;}")
-
-;
-; cmpsi instruction pattern(s).
-;
-
-(define_insn "cmpsi"
- [(set (cc0)
- (compare (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "general_operand" "md")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- if (unsigned_jump_follows_p (insn))
- return \"CLR %0,%1\";
- return \"CR %0,%1\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 4);
- if (unsigned_jump_follows_p (insn))
- return \"CL %0,=F'%c1'\";
- return \"C %0,=F'%c1'\";
- }
- mvs_check_page (0, 4, 0);
- if (unsigned_jump_follows_p (insn))
- return \"CL %0,%1\";
- return \"C %0,%1\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; cmphi instruction pattern(s).
-;
-
-; deprecate constraint d because it takes multiple instructions
-; and a memeory access ...
-(define_insn "cmphi"
- [(set (cc0)
- (compare (match_operand:HI 0 "register_operand" "d")
- (match_operand:HI 1 "general_operand" "???dim")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- if (unsigned_jump_follows_p (insn))
- return \"STH %1,140(,13)\;CLM %0,3,140(13)\";
- return \"STH %1,140(,13)\;CH %0,140(,13)\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"CH %0,%H1\";
- }
- mvs_check_page (0, 4, 0);
- return \"CH %0,%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; cmpqi instruction pattern(s).
-;
-
-(define_insn ""
- [(set (cc0)
- (compare (match_operand:QI 0 "r_or_s_operand" "dS")
- (match_operand:QI 1 "r_or_s_operand" "diS")))]
- "unsigned_jump_follows_p (insn)"
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STC %1,140(,13)\;CLM %0,1,140(13)\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 1);
- return \"CLM %0,1,=XL1'%X1'\";
- }
- mvs_check_page (0, 4, 0);
- return \"CLM %0,1,%1\";
- }
- else if (GET_CODE (operands[0]) == CONST_INT)
- {
- cc_status.flags |= CC_REVERSED;
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 1);
- return \"CLM %1,1,=XL1'%X0'\";
- }
- mvs_check_page (0, 4, 0);
- return \"CLI %1,%B0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"CLI %0,%B1\";
- }
- if (GET_CODE (operands[1]) == MEM)
- {
- mvs_check_page (0, 6, 0);
- return \"CLC %O0(1,%R0),%1\";
- }
- cc_status.flags |= CC_REVERSED;
- mvs_check_page (0, 4, 0);
- return \"CLM %1,1,%0\";
-}"
- [(set_attr "length" "8")]
-)
-
-(define_insn "cmpqi"
- [(set (cc0)
- (compare (match_operand:QI 0 "register_operand" "d")
- (match_operand:QI 1 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- if (unsigned_jump_follows_p (insn))
- {
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 1);
- return \"CLM %0,1,=XL1'%X1'\";
- }
- if (!(REG_P (operands[1])))
- {
- mvs_check_page (0, 4, 0);
- return \"CLM %0,1,%1\";
- }
- mvs_check_page (0, 8, 0);
- return \"STC %1,140(,13)\;CLM %0,1,140(13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 18, 0);
- return \"SLL %0,24\;SRA %0,24\;SLL %1,24\;SRA %1,24\;CR %0,%1\";
- }
- mvs_check_page (0, 12, 0);
- return \"SLL %0,24\;SRA %0,24\;C %0,%1\";
-}"
- [(set_attr "length" "18")]
-)
-
-;
-; cmpdf instruction pattern(s).
-;
-
-(define_insn "cmpdf"
- [(set (cc0)
- (compare (match_operand:DF 0 "general_operand" "f,mF")
- (match_operand:DF 1 "general_operand" "fmF,f")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"CDR %0,%1\";
- }
- mvs_check_page (0, 4, 0);
- return \"CD %0,%1\";
- }
- cc_status.flags |= CC_REVERSED;
- mvs_check_page (0, 4, 0);
- return \"CD %1,%0\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; cmpsf instruction pattern(s).
-;
-
-(define_insn "cmpsf"
- [(set (cc0)
- (compare (match_operand:SF 0 "general_operand" "f,mF")
- (match_operand:SF 1 "general_operand" "fmF,f")))]
- ""
- "*
-{
-check_label_emit ();
- if (FP_REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"CER %0,%1\";
- }
- mvs_check_page (0, 4, 0);
- return \"CE %0,%1\";
- }
- cc_status.flags |= CC_REVERSED;
- mvs_check_page (0, 4, 0);
- return \"CE %1,%0\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; cmpmemsi instruction pattern(s).
-;
-
-(define_expand "cmpmemsi"
- [(set (match_operand:SI 0 "general_operand" "")
- (compare (match_operand:BLK 1 "general_operand" "")
- (match_operand:BLK 2 "general_operand" "")))
- (use (match_operand:SI 3 "general_operand" ""))
- (use (match_operand:SI 4 "" ""))]
- ""
- "
-{
- rtx op1, op2;
-
- op1 = XEXP (operands[1], 0);
- if (GET_CODE (op1) == REG
- || (GET_CODE (op1) == PLUS && GET_CODE (XEXP (op1, 0)) == REG
- && GET_CODE (XEXP (op1, 1)) == CONST_INT
- && (unsigned) INTVAL (XEXP (op1, 1)) < 4096))
- {
- op1 = operands[1];
- }
- else
- {
- op1 = gen_rtx_MEM (BLKmode, copy_to_mode_reg (SImode, op1));
- }
-
- op2 = XEXP (operands[2], 0);
- if (GET_CODE (op2) == REG
- || (GET_CODE (op2) == PLUS && GET_CODE (XEXP (op2, 0)) == REG
- && GET_CODE (XEXP (op2, 1)) == CONST_INT
- && (unsigned) INTVAL (XEXP (op2, 1)) < 4096))
- {
- op2 = operands[2];
- }
- else
- {
- op2 = gen_rtx_MEM (BLKmode, copy_to_mode_reg (SImode, op2));
- }
-
- if (GET_CODE (operands[3]) == CONST_INT && INTVAL (operands[3]) < 256)
- {
- emit_insn (gen_rtx_PARALLEL (VOIDmode, gen_rtvec (2,
- gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_COMPARE (VOIDmode, op1, op2)),
- gen_rtx_USE (VOIDmode, operands[3]))));
- }
- else
- {
- /* implementation suggested by Richard Henderson <rth@cygnus.com> */
- rtx reg1 = gen_reg_rtx (DImode);
- rtx reg2 = gen_reg_rtx (DImode);
- rtx result = operands[0];
- rtx mem1 = operands[1];
- rtx mem2 = operands[2];
- rtx len = operands[3];
- if (!CONSTANT_P (len))
- len = force_reg (SImode, len);
-
- /* Load up the address+length pairs. */
- emit_insn (gen_rtx_CLOBBER (VOIDmode, reg1));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg1, 0),
- force_operand (XEXP (mem1, 0), NULL_RTX));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg1, GET_MODE_SIZE (SImode)), len);
-
- emit_insn (gen_rtx_CLOBBER (VOIDmode, reg2));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg2, 0),
- force_operand (XEXP (mem2, 0), NULL_RTX));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg2, GET_MODE_SIZE (SImode)), len);
-
- /* Compare! */
- emit_insn (gen_cmpmemsi_1 (result, reg1, reg2));
- }
- DONE;
-}")
-
-; Compare a block that is less than 256 bytes in length.
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (compare (match_operand:BLK 1 "s_operand" "m")
- (match_operand:BLK 2 "s_operand" "m")))
- (use (match_operand:QI 3 "immediate_operand" "I"))]
- "((unsigned) INTVAL (operands[3]) < 256)"
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 22, 0);
- return \"LA %0,%1\;CLC %O1(%c3,%R1),%2\;BH *+12\;BL *+6\;SLR %0,%0\;LNR %0,%0\";
-}"
- [(set_attr "length" "22")]
-)
-
-; Compare a block that is larger than 255 bytes in length.
-
-(define_insn "cmpmemsi_1"
- [(set (match_operand:SI 0 "register_operand" "+d")
- (compare
- (mem:BLK (subreg:SI (match_operand:DI 1 "register_operand" "+d") 0))
- (mem:BLK (subreg:SI (match_operand:DI 2 "register_operand" "+d") 0))))
- (use (match_dup 1))
- (use (match_dup 2))
- (clobber (match_dup 1))
- (clobber (match_dup 2))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 18, 0);
- return \"LA %0,1(0,0)\;CLCL %1,%2\;BH *+12\;BL *+6\;SLR %0,%0\;LNR %0,%0\";
-}"
- [(set_attr "length" "18")]
-)
-
-;;
-;;- Move instructions.
-;;
-
-;
-; movdi instruction pattern(s).
-;
-
-(define_insn ""
-;; [(set (match_operand:DI 0 "r_or_s_operand" "=dm")
-;; (match_operand:DI 1 "r_or_s_operand" "dim*fF"))]
- [(set (match_operand:DI 0 "r_or_s_operand" "=dS,m")
- (match_operand:DI 1 "r_or_s_operand" "diS*fF,d*fF"))]
-
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STD %1,140(,13)\;LM %0,%N0,140(13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"LR %0,%1\;LR %N0,%N1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 4, 0);
- return \"SLR %0,%0\;SLR %N0,%N0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 6, 0);
- return \"SLR %0,%0\;LA %N0,%c1(0,0)\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 8, 0);
- return \"L %0,%1\;SRDA %0,32\";
- }
- mvs_check_page (0, 4, 0);
- return \"LM %0,%N0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STD %1,%0\";
- }
- else if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STM %1,%N1,%0\";
- }
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(8,%R0),%W1\";
-}"
- [(set_attr "length" "8")]
-)
-
-(define_insn "movdi"
-;; [(set (match_operand:DI 0 "general_operand" "=d,dm")
-;; (match_operand:DI 1 "general_operand" "dimF,*fd"))]
- [(set (match_operand:DI 0 "general_operand" "=d,dm")
- (match_operand:DI 1 "r_or_s_operand" "diSF,*fd"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STD %1,140(,13)\;LM %0,%N0,140(13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"LR %0,%1\;LR %N0,%N1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 4, 0);
- return \"SLR %0,%0\;SLR %N0,%N0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 6, 0);
- return \"SLR %0,%0\;LA %N0,%c1(0,0)\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 8, 0);
- return \"L %0,%1\;SRDA %0,32\";
- }
- mvs_check_page (0, 4, 0);
- return \"LM %0,%N0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STD %1,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"STM %1,%N1,%0\";
-}"
- [(set_attr "length" "8")]
-)
-
-;; we have got to provide a movdi alternative that will go from
-;; register to memory & back in its full glory. However, we try to
-;; discourage its use by listing this alternative last.
-;; The problem is that the instructions above only provide
-;; S-form style (base + displacement) mem access, while the
-;; below provvides the full (base+index+displacement) RX-form.
-;; These are rarely needed, but when needed they're needed.
-
-(define_insn ""
- [(set (match_operand:DI 0 "general_operand" "=d,???m")
- (match_operand:DI 1 "general_operand" "???m,d"))]
-
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 8, 0);
- return \"LM %0,%N0,%1\";
- }
- else if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STM %1,%N1,%0\";
- }
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(8,%R0),%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; movsi instruction pattern(s).
-;
-
-(define_insn ""
-;; [(set (match_operand:SI 0 "r_or_s_operand" "=dm,d,dm")
-;; (match_operand:SI 1 "r_or_s_operand" "diR,dim,*fF"))]
- [(set (match_operand:SI 0 "r_or_s_operand" "=d,dS,dm")
- (match_operand:SI 1 "general_operand" "dim,diS,di*fF"))]
-
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STE %1,140(,13)\;L %0,140(,13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LR %0,%1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 2, 0);
- return \"SLR %0,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- mvs_check_page (0, 4, 0);
- return \"L %0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STE %1,%0\";
- }
- else if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"ST %1,%0\";
- }
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(4,%R0),%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-(define_insn "movsi"
- [(set (match_operand:SI 0 "general_operand" "=d,dm")
- (match_operand:SI 1 "general_operand" "dimF,*fd"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STE %1,140(,13)\;L %0,140(,13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LR %0,%1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 2, 0);
- return \"SLR %0,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- mvs_check_page (0, 4, 0);
- return \"L %0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STE %1,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"ST %1,%0\";
-}"
- [(set_attr "length" "8")]
-)
-
-;(define_expand "movsi"
-; [(set (match_operand:SI 0 "general_operand" "=d,dm")
-; (match_operand:SI 1 "general_operand" "dimF,*fd"))]
-; ""
-; "
-;{
-; rtx op0, op1;
-;
-; op0 = operands[0];
-; if (GET_CODE (op0) == CONST
-; && GET_CODE (XEXP (XEXP (op0, 0), 0)) == SYMBOL_REF
-; && SYMBOL_REF_EXTERNAL_P (XEXP (XEXP (op0, 0), 0)))
-; {
-; op0 = gen_rtx_MEM (SImode, copy_to_mode_reg (SImode, XEXP (op0, 0)));
-; }
-;
-; op1 = operands[1];
-; if (GET_CODE (op1) == CONST
-; && GET_CODE (XEXP (XEXP (op1, 0), 0)) == SYMBOL_REF
-; && SYMBOL_REF_EXTERNAL_P (XEXP (XEXP (op1, 0), 0)))
-; {
-; op1 = gen_rtx_MEM (SImode, copy_to_mode_reg (SImode, XEXP (op1, 0)));
-; }
-;
-; emit_insn (gen_rtx_SET (VOIDmode, op0, op1));
-; DONE;
-;}")
-
-;
-; movhi instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:HI 0 "r_or_s_operand" "=g")
- (match_operand:HI 1 "r_or_s_operand" "g"))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LR %0,%1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 2, 0);
- return \"SLR %0,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"LH %0,%H1\";
- }
- mvs_check_page (0, 4, 0);
- return \"LH %0,%1\";
- }
- else if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STH %1,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(2,%R0),%H1\";
- }
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(2,%R0),%1\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "movhi"
- [(set (match_operand:HI 0 "general_operand" "=d,m")
- (match_operand:HI 1 "general_operand" "g,d"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LR %0,%1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 2, 0);
- return \"SLR %0,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"LH %0,%H1\";
- }
- mvs_check_page (0, 4, 0);
- return \"LH %0,%1\";
- }
- mvs_check_page (0, 4, 0);
- return \"STH %1,%0\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; movqi instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:QI 0 "r_or_s_operand" "=g")
- (match_operand:QI 1 "r_or_s_operand" "g"))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LR %0,%1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 2, 0);
- return \"SLR %0,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- if ((INTVAL (operands[1]) >= 0)
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- mvs_check_page (0, 4, 0);
- return \"L %0,=F'%c1'\";
- }
- mvs_check_page (0, 4, 0);
- return \"IC %0,%1\";
- }
- else if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STC %1,%0\";
- }
- else if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"MVI %0,%B1\";
- }
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(1,%R0),%1\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "movqi"
- [(set (match_operand:QI 0 "general_operand" "=d,m")
- (match_operand:QI 1 "general_operand" "g,d"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LR %0,%1\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 2, 0);
- return \"SLR %0,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- if ((INTVAL (operands[1]) >= 0)
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- mvs_check_page (0, 4, 0);
- return \"L %0,=F'%c1'\";
- }
- mvs_check_page (0, 4, 0);
- return \"IC %0,%1\";
- }
- mvs_check_page (0, 4, 0);
- return \"STC %1,%0\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; movstrictqi instruction pattern(s).
-;
-
-(define_insn "movstrictqi"
- [(set (strict_low_part (match_operand:QI 0 "general_operand" "+d"))
- (match_operand:QI 1 "general_operand" "g"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STC %1,140(,13)\;IC %0,140(,13)\";
- }
- mvs_check_page (0, 4, 0);
- return \"IC %0,%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; movstricthi instruction pattern(s).
-;
-
-(define_insn ""
- [(set (strict_low_part (match_operand:HI 0 "register_operand" "+d"))
- (match_operand:HI 1 "r_or_s_operand" "g"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STH %1,140(,13)\;ICM %0,3,140(13)\";
- }
- else if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"ICM %0,3,%H1\";
- }
- mvs_check_page (0, 4, 0);
- return \"ICM %0,3,%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-(define_insn "movstricthi"
- [(set (strict_low_part (match_operand:HI 0 "general_operand" "+dm"))
- (match_operand:HI 1 "general_operand" "d"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 8, 0);
- return \"STH %1,140(,13)\;ICM %0,3,140(13)\";
- }
- mvs_check_page (0, 4, 0);
- return \"STH %1,%0\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; movdf instruction pattern(s).
-;
-
-(define_insn ""
-;; [(set (match_operand:DF 0 "r_or_s_operand" "=fm,fm,*dm")
-;; (match_operand:DF 1 "r_or_s_operand" "fmF,*dm,fmF"))]
- [(set (match_operand:DF 0 "general_operand" "=f,m,fS,*dS,???d")
- (match_operand:DF 1 "general_operand" "fmF,fF,*dS,fSF,???d"))]
-
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LDR %0,%1\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STM %1,%N1,140(13)\;LD %0,140(,13)\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 2, 0);
- return \"SDR %0,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"LD %0,%1\";
- }
- if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 12, 0);
- return \"STD %1,140(,13)\;LM %0,%N0,140(13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"LR %0,%1\;LR %N0,%N1\";
- }
- mvs_check_page (0, 4, 0);
- return \"LM %0,%N0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STD %1,%0\";
- }
- else if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STM %1,%N1,%0\";
- }
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(8,%R0),%1\";
-}"
- [(set_attr "length" "12")]
-)
-
-(define_insn "movdf"
-;; [(set (match_operand:DF 0 "general_operand" "=f,fm,m,*d")
-;; (match_operand:DF 1 "general_operand" "fmF,*d,f,fmF"))]
- [(set (match_operand:DF 0 "general_operand" "=f,m,fS,*d,???d")
- (match_operand:DF 1 "general_operand" "fmF,f,*d,SfF,???d"))]
-
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LDR %0,%1\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STM %1,%N1,140(13)\;LD %0,140(,13)\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 2, 0);
- return \"SDR %0,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"LD %0,%1\";
- }
- else if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 12, 0);
- return \"STD %1,140(,13)\;LM %0,%N0,140(13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"LR %0,%1\;LR %N0,%N1\";
- }
- mvs_check_page (0, 4, 0);
- return \"LM %0,%N0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STD %1,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"STM %1,%N1,%0\";
-}"
- [(set_attr "length" "12")]
-)
-
-;
-; movsf instruction pattern(s).
-;
-
-(define_insn ""
-;; [(set (match_operand:SF 0 "r_or_s_operand" "=fm,fm,*dm")
-;; (match_operand:SF 1 "r_or_s_operand" "fmF,*dm,fmF"))]
-;; [(set (match_operand:SF 0 "general_operand" "=f,m,fm,*d,S")
-;; (match_operand:SF 1 "general_operand" "fmF,fF,*d,fmF,S"))]
- [(set (match_operand:SF 0 "general_operand" "=f*d,fm,S,???d")
- (match_operand:SF 1 "general_operand" "fmF,fF*d,S,???d"))]
-
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LER %0,%1\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"ST %1,140(,13)\;LE %0,140(,13)\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 2, 0);
- return \"SER %0,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"LE %0,%1\";
- }
- else if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STE %1,140(,13)\;L %0,140(,13)\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LR %0,%1\";
- }
- mvs_check_page (0, 4, 0);
- return \"L %0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STE %1,%0\";
- }
- else if (REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"ST %1,%0\";
- }
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(4,%R0),%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-(define_insn "movsf"
- [(set (match_operand:SF 0 "general_operand" "=f,fm,m,*d")
- (match_operand:SF 1 "general_operand" "fmF,*d,f,fmF"))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 2, 0);
- return \"LER %0,%1\";
- }
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"ST %1,140(,13)\;LE %0,140(,13)\";
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 2, 0);
- return \"SER %0,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"LE %0,%1\";
- }
- else if (REG_P (operands[0]))
- {
- if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"STE %1,140(,13)\;L %0,140(,13)\";
- }
- mvs_check_page (0, 4, 0);
- return \"L %0,%1\";
- }
- else if (FP_REG_P (operands[1]))
- {
- mvs_check_page (0, 4, 0);
- return \"STE %1,%0\";
- }
- mvs_check_page (0, 4, 0);
- return \"ST %1,%0\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; clrstrsi instruction pattern(s).
-; memset a block of bytes to zero.
-; block must be less than 16M (24 bits) in length
-;
-(define_expand "clrstrsi"
- [(set (match_operand:BLK 0 "general_operand" "g")
- (const_int 0))
- (use (match_operand:SI 1 "general_operand" ""))
- (match_operand 2 "" "")]
- ""
- "
-{
- {
- /* implementation suggested by Richard Henderson <rth@cygnus.com> */
- rtx reg1 = gen_reg_rtx (DImode);
- rtx reg2 = gen_reg_rtx (DImode);
- rtx mem1 = operands[0];
- rtx zippo = gen_rtx_CONST_INT (SImode, 0);
- rtx len = operands[1];
- if (!CONSTANT_P (len))
- len = force_reg (SImode, len);
-
- /* Load up the address+length pairs. */
- emit_insn (gen_rtx_CLOBBER (VOIDmode, reg1));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg1, 0),
- force_operand (XEXP (mem1, 0), NULL_RTX));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg1, GET_MODE_SIZE (SImode)), len);
-
- emit_insn (gen_rtx_CLOBBER (VOIDmode, reg2));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg2, 0), zippo);
- emit_move_insn (gen_rtx_SUBREG (SImode, reg2, GET_MODE_SIZE (SImode)), zippo);
-
- /* Copy! */
- emit_insn (gen_movstrsi_1 (reg1, reg2));
- }
- DONE;
-}")
-
-;
-; movstrsi instruction pattern(s).
-; block must be less than 16M (24 bits) in length
-
-(define_expand "movstrsi"
- [(set (match_operand:BLK 0 "general_operand" "")
- (match_operand:BLK 1 "general_operand" ""))
- (use (match_operand:SI 2 "general_operand" ""))
- (match_operand 3 "" "")]
- ""
- "
-{
- rtx op0, op1;
-
- op0 = XEXP (operands[0], 0);
- if (GET_CODE (op0) == REG
- || (GET_CODE (op0) == PLUS && GET_CODE (XEXP (op0, 0)) == REG
- && GET_CODE (XEXP (op0, 1)) == CONST_INT
- && (unsigned) INTVAL (XEXP (op0, 1)) < 4096))
- op0 = operands[0];
- else
- op0 = replace_equiv_address (operands[0], copy_to_mode_reg (SImode, op0));
-
- op1 = XEXP (operands[1], 0);
- if (GET_CODE (op1) == REG
- || (GET_CODE (op1) == PLUS && GET_CODE (XEXP (op1, 0)) == REG
- && GET_CODE (XEXP (op1, 1)) == CONST_INT
- && (unsigned) INTVAL (XEXP (op1, 1)) < 4096))
- op1 = operands[1];
- else
- op1 = replace_equiv_address (operands[1], copy_to_mode_reg (SImode, op1));
-
- if (GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) < 256)
- emit_insn (gen_rtx_PARALLEL (VOIDmode,
- gen_rtvec (2,
- gen_rtx_SET (VOIDmode, op0, op1),
- gen_rtx_USE (VOIDmode, operands[2]))));
-
- else
- {
- /* implementation provided by Richard Henderson <rth@cygnus.com> */
- rtx reg1 = gen_reg_rtx (DImode);
- rtx reg2 = gen_reg_rtx (DImode);
- rtx mem1 = operands[0];
- rtx mem2 = operands[1];
- rtx len = operands[2];
- if (!CONSTANT_P (len))
- len = force_reg (SImode, len);
-
- /* Load up the address+length pairs. */
- emit_insn (gen_rtx_CLOBBER (VOIDmode, reg1));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg1, 0),
- force_operand (XEXP (mem1, 0), NULL_RTX));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg1, GET_MODE_SIZE (SImode)), len);
-
- emit_insn (gen_rtx_CLOBBER (VOIDmode, reg2));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg2, 0),
- force_operand (XEXP (mem2, 0), NULL_RTX));
- emit_move_insn (gen_rtx_SUBREG (SImode, reg2, GET_MODE_SIZE (SImode)), len);
-
- /* Copy! */
- emit_insn (gen_movstrsi_1 (reg1, reg2));
- }
- DONE;
-}")
-
-; Move a block that is less than 256 bytes in length.
-
-(define_insn ""
- [(set (match_operand:BLK 0 "s_operand" "=m")
- (match_operand:BLK 1 "s_operand" "m"))
- (use (match_operand 2 "immediate_operand" "I"))]
- "((unsigned) INTVAL (operands[2]) < 256)"
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 6, 0);
- return \"MVC %O0(%c2,%R0),%1\";
-}"
- [(set_attr "length" "6")]
-)
-
-; Move a block that is larger than 255 bytes in length.
-
-(define_insn "movstrsi_1"
- [(set (mem:BLK (subreg:SI (match_operand:DI 0 "register_operand" "+d") 0))
- (mem:BLK (subreg:SI (match_operand:DI 1 "register_operand" "+d") 0)))
- (use (match_dup 0))
- (use (match_dup 1))
- (clobber (match_dup 0))
- (clobber (match_dup 1))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"MVCL %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;;
-;;- Conversion instructions.
-;;
-
-;
-; extendsidi2 instruction pattern(s).
-;
-
-(define_expand "extendsidi2"
- [(set (match_operand:DI 0 "register_operand" "=d")
- (sign_extend:DI (match_operand:SI 1 "general_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operands[1]) != CONST_INT)
- {
- emit_insn (gen_rtx_SET (VOIDmode,
- operand_subword (operands[0], 0, 1, DImode), operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_ASHIFTRT (DImode, operands[0],
- gen_rtx_CONST_INT (SImode, 32))));
- }
- else
- {
- if (INTVAL (operands[1]) < 0)
- {
- emit_insn (gen_rtx_SET (VOIDmode,
- operand_subword (operands[0], 0, 1, DImode),
- gen_rtx_CONST_INT (SImode, -1)));
- }
- else
- {
- emit_insn (gen_rtx_SET (VOIDmode,
- operand_subword (operands[0], 0, 1, DImode),
- gen_rtx_CONST_INT (SImode, 0)));
- }
- emit_insn (gen_rtx_SET (VOIDmode, gen_lowpart (SImode, operands[0]),
- operands[1]));
- }
- DONE;
-}")
-
-;
-; extendhisi2 instruction pattern(s).
-;
-
-(define_insn "extendhisi2"
- [(set (match_operand:SI 0 "general_operand" "=d,m")
- (sign_extend:SI (match_operand:HI 1 "general_operand" "g,d")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- if (REG_P (operands[1]))
- {
- if (REGNO (operands[0]) != REGNO (operands[1]))
- {
- mvs_check_page (0, 10, 0);
- return \"LR %0,%1\;SLL %0,16\;SRA %0,16\";
- }
- else
- return \"\"; /* Should be empty. 16-bits regs are always 32-bits. */
- }
- if (operands[1] == const0_rtx)
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 2, 0);
- return \"SLR %0,%0\";
- }
- if (GET_CODE (operands[1]) == CONST_INT
- && (unsigned) INTVAL (operands[1]) < 4096)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"LH %0,%H1\";
- }
- mvs_check_page (0, 4, 0);
- return \"LH %0,%1\";
- }
- mvs_check_page (0, 12, 0);
- return \"SLL %1,16\;SRA %1,16\;ST %1,%0\";
-}"
- [(set_attr "length" "12")]
-)
-
-;
-; extendqisi2 instruction pattern(s).
-;
-
-(define_insn "extendqisi2"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (sign_extend:SI (match_operand:QI 1 "general_operand" "0mi")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_SET (operands[0], operands[1]);
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"SLL %0,24\;SRA %0,24\";
- }
- if (s_operand (operands[1], GET_MODE (operands[1])))
- {
- mvs_check_page (0, 8, 0);
- return \"ICM %0,8,%1\;SRA %0,24\";
- }
- mvs_check_page (0, 12, 0);
- return \"IC %0,%1\;SLL %0,24\;SRA %0,24\";
-}"
- [(set_attr "length" "12")]
-)
-
-;
-; extendqihi2 instruction pattern(s).
-;
-
-(define_insn "extendqihi2"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (sign_extend:HI (match_operand:QI 1 "general_operand" "0m")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_SET (operands[0], operands[1]);
- if (REG_P (operands[1]))
- {
- mvs_check_page (0, 8, 0);
- return \"SLL %0,24\;SRA %0,24\";
- }
- if (s_operand (operands[1], GET_MODE (operands[1])))
- {
- mvs_check_page (0, 8, 0);
- return \"ICM %0,8,%1\;SRA %0,24\";
- }
- mvs_check_page (0, 12, 0);
- return \"IC %0,%1\;SLL %0,24\;SRA %0,24\";
-}"
- [(set_attr "length" "12")]
-)
-
-;
-; zero_extendsidi2 instruction pattern(s).
-;
-
-(define_expand "zero_extendsidi2"
- [(set (match_operand:DI 0 "register_operand" "=d")
- (zero_extend:DI (match_operand:SI 1 "general_operand" "")))]
- ""
- "
-{
- emit_insn (gen_rtx_SET (VOIDmode,
- operand_subword (operands[0], 0, 1, DImode), operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_LSHIFTRT (DImode, operands[0],
- gen_rtx_CONST_INT (SImode, 32))));
- DONE;
-}")
-
-;
-; zero_extendhisi2 instruction pattern(s).
-;
-
-(define_insn "zero_extendhisi2"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (zero_extend:SI (match_operand:HI 1 "general_operand" "0")))]
- ""
- "*
-{
- check_label_emit ();
- /* AND only sets zero/not-zero bits not the arithmetic bits ... */
- CC_STATUS_INIT;
- mvs_check_page (0, 4, 4);
- return \"N %1,=XL4'0000FFFF'\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; zero_extendqisi2 instruction pattern(s).
-;
-
-(define_insn "zero_extendqisi2"
- [(set (match_operand:SI 0 "general_operand" "=d,&d")
- (zero_extend:SI (match_operand:QI 1 "general_operand" "0i,m")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[1]))
- {
- /* AND only sets zero/not-zero bits not the arithmetic bits ... */
- CC_STATUS_INIT;
- mvs_check_page (0, 4, 4);
- return \"N %0,=XL4'000000FF'\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- CC_STATUS_INIT;
- mvs_check_page (0, 8, 0);
- return \"SLR %0,%0\;IC %0,%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; zero_extendqihi2 instruction pattern(s).
-;
-
-(define_insn "zero_extendqihi2"
- [(set (match_operand:HI 0 "general_operand" "=d,&d")
- (zero_extend:HI (match_operand:QI 1 "general_operand" "0i,m")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[1]))
- {
- /* AND only sets zero/not-zero bits not the arithmetic bits ... */
- CC_STATUS_INIT;
- mvs_check_page (0, 4, 4);
- return \"N %0,=XL4'000000FF'\";
- }
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c1(0,0)\";
- }
- CC_STATUS_INIT;
- mvs_check_page (0, 8, 0);
- return \"SLR %0,%0\;IC %0,%1\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; truncsihi2 instruction pattern(s).
-;
-
-(define_insn "truncsihi2"
- [(set (match_operand:HI 0 "general_operand" "=d,m")
- (truncate:HI (match_operand:SI 1 "general_operand" "0,d")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 8, 0);
- return \"SLL %0,16\;SRA %0,16\";
- }
- mvs_check_page (0, 4, 0);
- return \"STH %1,%0\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; fix_truncdfsi2 instruction pattern(s).
-;
-
-(define_insn "fix_truncdfsi2"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (fix:SI (truncate:DF (match_operand:DF 1 "general_operand" "+f"))))
- (clobber (reg:DF 16))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT;
- if (REGNO (operands[1]) == 16)
- {
- mvs_check_page (0, 12, 8);
- return \"AD 0,=XL8'4F08000000000000'\;STD 0,140(,13)\;L %0,144(,13)\";
- }
- mvs_check_page (0, 14, 8);
- return \"LDR 0,%1\;AD 0,=XL8'4F08000000000000'\;STD 0,140(,13)\;L %0,144(,13)\";
-}"
- [(set_attr "length" "14")]
-)
-
-;
-; floatsidf2 instruction pattern(s).
-;
-; LE/370 mode uses the float field of the TCA.
-;
-
-(define_insn "floatsidf2"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (float:DF (match_operand:SI 1 "general_operand" "d")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT;
-#ifdef TARGET_ELF_ABI
- mvs_check_page (0, 22, 12);
- return \"MVC 140(4,13),=XL4'4E000000'\;ST %1,144(,13)\;XI 144(13),128\;LD %0,140(,13)\;SD %0,=XL8'4E00000080000000'\";
-#else
- mvs_check_page (0, 16, 8);
- return \"ST %1,508(,12)\;XI 508(12),128\;LD %0,504(,12)\;SD %0,=XL8'4E00000080000000'\";
-#endif
-}"
- [(set_attr "length" "22")]
-)
-
-;
-; truncdfsf2 instruction pattern(s).
-;
-
-(define_insn "truncdfsf2"
- [(set (match_operand:SF 0 "general_operand" "=f")
- (float_truncate:SF (match_operand:DF 1 "general_operand" "f")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LRER %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; extendsfdf2 instruction pattern(s).
-;
-
-(define_insn "extendsfdf2"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (float_extend:DF (match_operand:SF 1 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_SET (0, const0_rtx);
- if (FP_REG_P (operands[1]))
- {
- if (REGNO (operands[0]) == REGNO (operands[1]))
- {
- mvs_check_page (0, 10, 0);
- return \"STE %1,140(,13)\;SDR %0,%0\;LE %0,140(,13)\";
- }
- mvs_check_page (0, 4, 0);
- return \"SDR %0,%0\;LER %0,%1\";
- }
- mvs_check_page (0, 6, 0);
- return \"SDR %0,%0\;LE %0,%1\";
-}"
- [(set_attr "length" "10")]
-)
-
-;;
-;;- Add instructions.
-;;
-
-;
-; adddi3 instruction pattern(s).
-;
-;
-;(define_expand "adddi3"
-; [(set (match_operand:DI 0 "general_operand" "")
-; (plus:DI (match_operand:DI 1 "general_operand" "")
-; (match_operand:DI 2 "general_operand" "")))]
-; ""
-; "
-;{
-; rtx label = gen_label_rtx ();
-; rtx op0_high = operand_subword (operands[0], 0, 1, DImode);
-; rtx op0_low = gen_lowpart (SImode, operands[0]);
-;
-; emit_insn (gen_rtx_SET (VOIDmode, op0_high,
-; gen_rtx_PLUS (SImode,
-; operand_subword (operands[1], 0, 1, DImode),
-; operand_subword (operands[2], 0, 1, DImode))));
-; emit_jump_insn (gen_rtx_PARALLEL (VOIDmode, gen_rtvec (2,
-; gen_rtx_SET (VOIDmode, op0_low,
-; gen_rtx_PLUS (SImode, gen_lowpart (SImode, operands[1]),
-; gen_lowpart (SImode, operands[2]))),
-; gen_rtx_USE (VOIDmode, gen_rtx_LABEL_REF (VOIDmode, label)))));
-; emit_insn (gen_rtx_SET (VOIDmode, op0_high,
-; gen_rtx_PLUS (SImode, op0_high,
-; gen_rtx_CONST_INT (SImode, 1))));
-; emit_label (label);
-; DONE;
-;}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d")
- (plus:SI (match_operand:SI 1 "general_operand" "%0")
- (match_operand:SI 2 "general_operand" "g")))
- (use (label_ref (match_operand 3 "" "")))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- int onpage;
-
- check_label_emit ();
- onpage = mvs_check_label (CODE_LABEL_NUMBER (operands[3]));
- if (REG_P (operands[2]))
- {
- if (!onpage)
- {
- mvs_check_page (0, 8, 4);
- return \"ALR %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- if (mvs_check_page (0, 6, 0))
- {
- mvs_check_page (0, 2, 4);
- return \"ALR %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- return \"ALR %0,%2\;BC 12,%l3\";
- }
- if (!onpage)
- {
- mvs_check_page (0, 10, 4);
- return \"AL %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- if (mvs_check_page (0, 8 ,0))
- {
- mvs_check_page (0, 2, 4);
- return \"AL %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- return \"AL %0,%2\;BC 12,%l3\";
-}"
- [(set_attr "length" "10")]
-)
-
-;
-; addsi3 instruction pattern(s).
-;
-; The following insn is used when it is known that operand one is an address,
-; frame, stack or argument pointer, and operand two is a constant that is
-; small enough to fit in the displacement field.
-; Notice that we can't allow the frame pointer to used as a normal register
-; because of this insn.
-;
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (plus:SI (match_operand:SI 1 "general_operand" "%a")
- (match_operand:SI 2 "immediate_operand" "J")))]
- "((REGNO (operands[1]) == FRAME_POINTER_REGNUM || REGNO (operands[1]) == ARG_POINTER_REGNUM || REGNO (operands[1]) == STACK_POINTER_REGNUM) && (unsigned) INTVAL (operands[2]) < 4096)"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* add assumes CC but LA doesn't set CC */
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c2(,%1)\";
-}"
- [(set_attr "length" "4")]
-)
-
-; This insn handles additions that are relative to the frame pointer.
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (plus:SI (match_operand:SI 1 "register_operand" "%a")
- (match_operand:SI 2 "immediate_operand" "i")))]
- "REGNO (operands[1]) == FRAME_POINTER_REGNUM"
- "*
-{
- check_label_emit ();
- if ((unsigned) INTVAL (operands[2]) < 4096)
- {
- CC_STATUS_INIT; /* add assumes CC but LA doesn't set CC */
- mvs_check_page (0, 4, 0);
- return \"LA %0,%c2(,%1)\";
- }
- if (REGNO (operands[1]) == REGNO (operands[0]))
- {
- CC_STATUS_INIT;
- mvs_check_page (0, 4, 0);
- return \"A %0,%2\";
- }
- mvs_check_page (0, 6, 0);
- return \"L %0,%2\;AR %0,%1\";
-}"
- [(set_attr "length" "6")]
-)
-
-;;
-;; The CC status bits for the arithmetic instructions are handled
-;; in the NOTICE_UPDATE_CC macro (yeah???) and so they do not need
-;; to be set below. They only need to be invalidated if *not* set
-;; (e.g. by BCTR) ... yeah I think that's right ...
-;;
-
-(define_insn "addsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (plus:SI (match_operand:SI 1 "general_operand" "%0")
- (match_operand:SI 2 "general_operand" "g")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"AR %0,%2\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- if (INTVAL (operands[2]) == -1)
- {
- CC_STATUS_INIT; /* add assumes CC but BCTR doesn't set CC */
- mvs_check_page (0, 2, 0);
- return \"BCTR %0,0\";
- }
- }
- mvs_check_page (0, 4, 0);
- return \"A %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; addhi3 instruction pattern(s).
-;
-
-(define_insn "addhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (plus:HI (match_operand:HI 1 "general_operand" "%0")
- (match_operand:HI 2 "general_operand" "dmi")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 8, 0);
- return \"STH %2,140(,13)\;AH %0,140(,13)\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- if (INTVAL (operands[2]) == -1)
- {
- CC_STATUS_INIT; /* add assumes CC but BCTR doesn't set CC */
- mvs_check_page (0, 2, 0);
- return \"BCTR %0,0\";
- }
- mvs_check_page (0, 4, 0);
- return \"AH %0,%H2\";
- }
- mvs_check_page (0, 4, 0);
- return \"AH %0,%2\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; addqi3 instruction pattern(s).
-;
-
-(define_insn "addqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (plus:QI (match_operand:QI 1 "general_operand" "%a")
- (match_operand:QI 2 "general_operand" "ai")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* add assumes CC but LA doesn't set CC */
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"LA %0,0(%1,%2)\";
- return \"LA %0,%B2(,%1)\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; adddf3 instruction pattern(s).
-;
-
-(define_insn "adddf3"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (plus:DF (match_operand:DF 1 "general_operand" "%0")
- (match_operand:DF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"ADR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"AD %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; addsf3 instruction pattern(s).
-;
-
-(define_insn "addsf3"
- [(set (match_operand:SF 0 "general_operand" "=f")
- (plus:SF (match_operand:SF 1 "general_operand" "%0")
- (match_operand:SF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"AER %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"AE %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Subtract instructions.
-;;
-
-;
-; subdi3 instruction pattern(s).
-;
-;
-;(define_expand "subdi3"
-; [(set (match_operand:DI 0 "general_operand" "")
-; (minus:DI (match_operand:DI 1 "general_operand" "")
-; (match_operand:DI 2 "general_operand" "")))]
-; ""
-; "
-;{
-; rtx label = gen_label_rtx ();
-; rtx op0_high = operand_subword (operands[0], 0, 1, DImode);
-; rtx op0_low = gen_lowpart (SImode, operands[0]);
-;
-; emit_insn (gen_rtx_SET (VOIDmode, op0_high,
-; gen_rtx_MINUS (SImode,
-; operand_subword (operands[1], 0, 1, DImode),
-; operand_subword (operands[2], 0, 1, DImode))));
-; emit_jump_insn (gen_rtx_PARALLEL (VOIDmode, gen_rtvec (2,
-; gen_rtx_SET (VOIDmode, op0_low,
-; gen_rtx_MINUS (SImode,
-; gen_lowpart (SImode, operands[1]),
-; gen_lowpart (SImode, operands[2]))),
-; gen_rtx_USE (VOIDmode,
-; gen_rtx_LABEL_REF (VOIDmode, label)))));
-; emit_insn (gen_rtx_SET (VOIDmode, op0_high,
-; gen_rtx_MINUS (SImode, op0_high,
-; gen_rtx_CONST_INT (SImode, 1))));
-; emit_label (label);
-; DONE;
-;}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d")
- (minus:SI (match_operand:SI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "g")))
- (use (label_ref (match_operand 3 "" "")))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- int onpage;
-
- check_label_emit ();
- CC_STATUS_INIT;
- onpage = mvs_check_label (CODE_LABEL_NUMBER (operands[3]));
- if (REG_P (operands[2]))
- {
- if (!onpage)
- {
- mvs_check_page (0, 8, 4);
- return \"SLR %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- if (mvs_check_page (0, 6, 0))
- {
- mvs_check_page (0, 2, 4);
- return \"SLR %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- return \"SLR %0,%2\;BC 12,%l3\";
- }
- if (!onpage)
- {
- mvs_check_page (0, 10, 4);
- return \"SL %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- if (mvs_check_page (0, 8, 0))
- {
- mvs_check_page (0, 2, 4);
- return \"SL %0,%2\;L 14,=A(%l3)\;BCR 12,14\";
- }
- return \"SL %0,%2\;BC 12,%l3\";
-}"
- [(set_attr "length" "10")]
-)
-
-;
-; subsi3 instruction pattern(s).
-;
-
-(define_insn "subsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (minus:SI (match_operand:SI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "g")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"SR %0,%2\";
- }
- if (operands[2] == const1_rtx)
- {
- CC_STATUS_INIT; /* subtract assumes CC but BCTR doesn't set CC */
- mvs_check_page (0, 2, 0);
- return \"BCTR %0,0\";
- }
- mvs_check_page (0, 4, 0);
- return \"S %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; subhi3 instruction pattern(s).
-;
-
-(define_insn "subhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (minus:HI (match_operand:HI 1 "general_operand" "0")
- (match_operand:HI 2 "general_operand" "g")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 8, 0);
- return \"STH %2,140(,13)\;SH %0,140(,13)\";
- }
- if (operands[2] == const1_rtx)
- {
- CC_STATUS_INIT; /* subtract assumes CC but BCTR doesn't set CC */
- mvs_check_page (0, 2, 0);
- return \"BCTR %0,0\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"SH %0,%H2\";
- }
- mvs_check_page (0, 4, 0);
- return \"SH %0,%2\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; subqi3 instruction pattern(s).
-;
-
-(define_expand "subqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (minus:QI (match_operand:QI 1 "general_operand" "0")
- (match_operand:QI 2 "general_operand" "di")))]
- ""
- "
-{
- if (REG_P (operands[2]))
- {
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_MINUS (QImode, operands[1], operands[2])));
- }
- else
- {
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_PLUS (QImode, operands[1],
- negate_rtx (QImode, operands[2]))));
- }
- DONE;
-}")
-
-(define_insn ""
- [(set (match_operand:QI 0 "register_operand" "=d")
- (minus:QI (match_operand:QI 1 "register_operand" "0")
- (match_operand:QI 2 "register_operand" "d")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"SR %0,%2\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; subdf3 instruction pattern(s).
-;
-
-(define_insn "subdf3"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (minus:DF (match_operand:DF 1 "general_operand" "0")
- (match_operand:DF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"SDR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"SD %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; subsf3 instruction pattern(s).
-;
-
-(define_insn "subsf3"
- [(set (match_operand:SF 0 "general_operand" "=f")
- (minus:SF (match_operand:SF 1 "general_operand" "0")
- (match_operand:SF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"SER %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"SE %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Multiply instructions.
-;;
-
-;
-; mulsi3 instruction pattern(s).
-;
-
-(define_expand "mulsi3"
- [(set (match_operand:SI 0 "general_operand" "")
- (mult:SI (match_operand:SI 1 "general_operand" "")
- (match_operand:SI 2 "general_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operands[1]) == CONST_INT
- && CONST_OK_FOR_LETTER_P (INTVAL (operands[1]), 'K'))
- {
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_MULT (SImode, operands[2], operands[1])));
- }
- else if (GET_CODE (operands[2]) == CONST_INT
- && CONST_OK_FOR_LETTER_P (INTVAL (operands[2]), 'K'))
- {
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_MULT (SImode, operands[1], operands[2])));
- }
- else
- {
- rtx r = gen_reg_rtx (DImode);
-
- /* XXX trouble. Below we generate some rtx's that model what
- * is really supposed to happen with multiply on the 370/390
- * hardware, and that is all well & good. However, during optimization
- * it can happen that the two operands are exchanged (after all,
- * multiplication is commutitive), in which case the doubleword
- * ends up in memory and everything is hosed. The gen_reg_rtx
- * should have kept it in a reg ... We hack around this
- * below, in the M/MR isntruction pattern, and constrain it to
- * \"di\" instead of \"g\". But this still ends up with lots & lots of
- * movement between registers & memory and is an awful waste.
- * Dunno how to untwist it elegantly; but it seems to work for now.
- */
- emit_insn (gen_rtx_SET (VOIDmode,
- gen_rtx_SUBREG (SImode, r, GET_MODE_SIZE (SImode)),
- operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, r,
- gen_rtx_MULT (DImode, r, operands[2])));
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_SUBREG (SImode, r, GET_MODE_SIZE (SImode))));
- }
- DONE;
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d")
- (mult:SI (match_operand:SI 1 "general_operand" "%0")
- (match_operand:SI 2 "immediate_operand" "K")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- return \"MH %0,%H2\";
-}"
- [(set_attr "length" "4")]
-)
-
-(define_insn ""
- [(set (match_operand:DI 0 "register_operand" "=d")
- (mult:DI (match_operand:DI 1 "general_operand" "%0")
- (match_operand:SI 2 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"MR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"M %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; muldf3 instruction pattern(s).
-;
-
-(define_insn "muldf3"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (mult:DF (match_operand:DF 1 "general_operand" "%0")
- (match_operand:DF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"MDR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"MD %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; mulsf3 instruction pattern(s).
-;
-
-(define_insn "mulsf3"
- [(set (match_operand:SF 0 "general_operand" "=f")
- (mult:SF (match_operand:SF 1 "general_operand" "%0")
- (match_operand:SF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"MER %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"ME %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Divide instructions.
-;;
-
-;
-; divsi3 instruction pattern(s).
-;
-
-(define_expand "divsi3"
- [(set (match_operand:SI 0 "general_operand" "")
- (div:SI (match_operand:SI 1 "general_operand" "")
- (match_operand:SI 2 "general_operand" "")))]
- ""
- "
-{
- rtx r = gen_reg_rtx (DImode);
-
- emit_insn (gen_extendsidi2 (r, operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, r,
- gen_rtx_DIV (DImode, r, operands[2])));
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_SUBREG (SImode, r, GET_MODE_SIZE (SImode))));
- DONE;
-}")
-
-
-;
-; udivsi3 instruction pattern(s).
-;
-
-(define_expand "udivsi3"
- [(set (match_operand:SI 0 "general_operand" "")
- (udiv:SI (match_operand:SI 1 "general_operand" "")
- (match_operand:SI 2 "general_operand" "")))]
- ""
- "
-{
- rtx dr = gen_reg_rtx (DImode);
- rtx dr_0 = gen_rtx_SUBREG (SImode, dr, 0);
- rtx dr_1 = gen_rtx_SUBREG (SImode, dr, GET_MODE_SIZE (SImode));
-
-
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- if (INTVAL (operands[2]) > 0)
- {
- emit_insn (gen_zero_extendsidi2 (dr, operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, dr,
- gen_rtx_DIV (DImode, dr, operands[2])));
- }
- else
- {
- rtx label1 = gen_label_rtx ();
-
- emit_insn (gen_rtx_SET (VOIDmode, dr_0, operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, dr_1, const0_rtx));
- emit_insn (gen_cmpsi (dr_0, operands[2]));
- emit_jump_insn (gen_bltu (label1));
- emit_insn (gen_rtx_SET (VOIDmode, dr_1, const1_rtx));
- emit_label (label1);
- }
- }
- else
- {
- rtx label1 = gen_label_rtx ();
- rtx label2 = gen_label_rtx ();
- rtx label3 = gen_label_rtx ();
- rtx sr = gen_reg_rtx (SImode);
-
- emit_insn (gen_rtx_SET (VOIDmode, dr_0, operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, sr, operands[2]));
- emit_insn (gen_rtx_SET (VOIDmode, dr_1, const0_rtx));
- emit_insn (gen_cmpsi (sr, dr_0));
- emit_jump_insn (gen_bgtu (label3));
- emit_insn (gen_cmpsi (sr, const1_rtx));
- emit_jump_insn (gen_blt (label2));
- emit_insn (gen_cmpsi (sr, const1_rtx));
- emit_jump_insn (gen_beq (label1));
- emit_insn (gen_rtx_SET (VOIDmode, dr,
- gen_rtx_LSHIFTRT (DImode, dr,
- gen_rtx_CONST_INT (SImode, 32))));
- emit_insn (gen_rtx_SET (VOIDmode, dr,
- gen_rtx_DIV (DImode, dr, sr)));
- emit_jump_insn (gen_jump (label3));
- emit_label (label1);
- emit_insn (gen_rtx_SET (VOIDmode, dr_1, dr_0));
- emit_jump_insn (gen_jump (label3));
- emit_label (label2);
- emit_insn (gen_rtx_SET (VOIDmode, dr_1, const1_rtx));
- emit_label (label3);
- }
- emit_insn (gen_rtx_SET (VOIDmode, operands[0], dr_1));
-
- DONE;
-}")
-
-; This is used by divsi3 & udivsi3.
-
-(define_insn ""
- [(set (match_operand:DI 0 "register_operand" "=d")
- (div:DI (match_operand:DI 1 "register_operand" "0")
- (match_operand:SI 2 "general_operand" "dm")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"DR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"D %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; divdf3 instruction pattern(s).
-;
-
-(define_insn "divdf3"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (div:DF (match_operand:DF 1 "general_operand" "0")
- (match_operand:DF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"DDR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"DD %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; divsf3 instruction pattern(s).
-;
-
-(define_insn "divsf3"
- [(set (match_operand:SF 0 "general_operand" "=f")
- (div:SF (match_operand:SF 1 "general_operand" "0")
- (match_operand:SF 2 "general_operand" "fmF")))]
- ""
- "*
-{
- check_label_emit ();
- if (FP_REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"DER %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"DE %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Modulo instructions.
-;;
-
-;
-; modsi3 instruction pattern(s).
-;
-
-(define_expand "modsi3"
- [(set (match_operand:SI 0 "general_operand" "")
- (mod:SI (match_operand:SI 1 "general_operand" "")
- (match_operand:SI 2 "general_operand" "")))]
- ""
- "
-{
- rtx r = gen_reg_rtx (DImode);
-
- emit_insn (gen_extendsidi2 (r, operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, r,
- gen_rtx_MOD (DImode, r, operands[2])));
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_SUBREG (SImode, r, 0)));
- DONE;
-}")
-
-;
-; umodsi3 instruction pattern(s).
-;
-
-(define_expand "umodsi3"
- [(set (match_operand:SI 0 "general_operand" "")
- (umod:SI (match_operand:SI 1 "general_operand" "")
- (match_operand:SI 2 "general_operand" "")))]
- ""
- "
-{
- rtx dr = gen_reg_rtx (DImode);
- rtx dr_0 = gen_rtx_SUBREG (SImode, dr, 0);
-
- emit_insn (gen_rtx_SET (VOIDmode, dr_0, operands[1]));
-
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- if (INTVAL (operands[2]) > 0)
- {
- emit_insn (gen_rtx_SET (VOIDmode, dr,
- gen_rtx_LSHIFTRT (DImode, dr,
- gen_rtx_CONST_INT (SImode, 32))));
- emit_insn (gen_rtx_SET (VOIDmode, dr,
- gen_rtx_MOD (DImode, dr, operands[2])));
- }
- else
- {
- rtx label1 = gen_label_rtx ();
- rtx sr = gen_reg_rtx (SImode);
-
- emit_insn (gen_rtx_SET (VOIDmode, sr, operands[2]));
- emit_insn (gen_cmpsi (dr_0, sr));
- emit_jump_insn (gen_bltu (label1));
- emit_insn (gen_rtx_SET (VOIDmode, sr, gen_rtx_ABS (SImode, sr)));
- emit_insn (gen_rtx_SET (VOIDmode, dr_0,
- gen_rtx_PLUS (SImode, dr_0, sr)));
- emit_label (label1);
- }
- }
- else
- {
- rtx label1 = gen_label_rtx ();
- rtx label2 = gen_label_rtx ();
- rtx label3 = gen_label_rtx ();
- rtx sr = gen_reg_rtx (SImode);
-
- emit_insn (gen_rtx_SET (VOIDmode, dr_0, operands[1]));
- emit_insn (gen_rtx_SET (VOIDmode, sr, operands[2]));
- emit_insn (gen_cmpsi (sr, dr_0));
- emit_jump_insn (gen_bgtu (label3));
- emit_insn (gen_cmpsi (sr, const1_rtx));
- emit_jump_insn (gen_blt (label2));
- emit_jump_insn (gen_beq (label1));
- emit_insn (gen_rtx_SET (VOIDmode, dr,
- gen_rtx_LSHIFTRT (DImode, dr,
- gen_rtx_CONST_INT (SImode, 32))));
- emit_insn (gen_rtx_SET (VOIDmode, dr, gen_rtx_MOD (DImode, dr, sr)));
- emit_jump_insn (gen_jump (label3));
- emit_label (label1);
- emit_insn (gen_rtx_SET (VOIDmode, dr_0, const0_rtx));
- emit_jump_insn (gen_jump (label3));
- emit_label (label2);
- emit_insn (gen_rtx_SET (VOIDmode, dr_0,
- gen_rtx_MINUS (SImode, dr_0, sr)));
- emit_label (label3);
-
- }
- emit_insn (gen_rtx_SET (VOIDmode, operands[0], dr_0));
-
- DONE;
-}")
-
-; This is used by modsi3 & umodsi3.
-
-(define_insn ""
- [(set (match_operand:DI 0 "register_operand" "=d")
- (mod:DI (match_operand:DI 1 "register_operand" "0")
- (match_operand:SI 2 "general_operand" "dm")))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"DR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"D %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- And instructions.
-;;
-
-;
-; anddi3 instruction pattern(s).
-;
-
-;(define_expand "anddi3"
-; [(set (match_operand:DI 0 "general_operand" "")
-; (and:DI (match_operand:DI 1 "general_operand" "")
-; (match_operand:DI 2 "general_operand" "")))]
-; ""
-; "
-;{
-; rtx gen_andsi3();
-;
-; emit_insn (gen_andsi3 (operand_subword (operands[0], 0, 1, DImode),
-; operand_subword (operands[1], 0, 1, DImode),
-; operand_subword (operands[2], 0, 1, DImode)));
-; emit_insn (gen_andsi3 (gen_lowpart (SImode, operands[0]),
-; gen_lowpart (SImode, operands[1]),
-; gen_lowpart (SImode, operands[2])));
-; DONE;
-;}")
-
-;
-; andsi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:SI 0 "r_or_s_operand" "=d,m")
- (and:SI (match_operand:SI 1 "r_or_s_operand" "%0,0")
- (match_operand:SI 2 "r_or_s_operand" "g,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* and sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"NR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"N %0,%2\";
- }
- mvs_check_page (0, 6, 0);
- return \"NC %O0(4,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "andsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (and:SI (match_operand:SI 1 "general_operand" "%0")
- (match_operand:SI 2 "general_operand" "g")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* and sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"NR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"N %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; andhi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:HI 0 "r_or_s_operand" "=d,m")
- (and:HI (match_operand:HI 1 "r_or_s_operand" "%0,0")
- (match_operand:HI 2 "r_or_s_operand" "di,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* and sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"NR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- /* %K2 == sign extend operand to 32 bits so that CH works */
- mvs_check_page (0, 4, 0);
- if (GET_CODE (operands[2]) == CONST_INT)
- return \"N %0,%K2\";
- return \"N %0,%2\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 6, 0);
- return \"NC %O0(2,%R0),%H2\";
- }
- mvs_check_page (0, 6, 0);
- return \"NC %O0(2,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "andhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (and:HI (match_operand:HI 1 "general_operand" "%0")
- (match_operand:HI 2 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* and sets CC but not how we want it */
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- /* %K2 == sign extend operand to 32 bits so that CH works */
- mvs_check_page (0, 4, 0);
- return \"N %0,%K2\";
- }
- mvs_check_page (0, 2, 0);
- return \"NR %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; andqi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:QI 0 "r_or_s_operand" "=d,m")
- (and:QI (match_operand:QI 1 "r_or_s_operand" "%0,0")
- (match_operand:QI 2 "r_or_s_operand" "di,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* and sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"NR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"N %0,%2\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"NI %0,%B2\";
- }
- mvs_check_page (0, 6, 0);
- return \"NC %O0(1,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "andqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (and:QI (match_operand:QI 1 "general_operand" "%0")
- (match_operand:QI 2 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* and sets CC but not how we want it */
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"N %0,%2\";
- }
- mvs_check_page (0, 2, 0);
- return \"NR %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Bit set (inclusive or) instructions.
-;;
-
-;
-; iordi3 instruction pattern(s).
-;
-
-;(define_expand "iordi3"
-; [(set (match_operand:DI 0 "general_operand" "")
-; (ior:DI (match_operand:DI 1 "general_operand" "")
-; (match_operand:DI 2 "general_operand" "")))]
-; ""
-; "
-;{
-; rtx gen_iorsi3();
-;
-; emit_insn (gen_iorsi3 (operand_subword (operands[0], 0, 1, DImode),
-; operand_subword (operands[1], 0, 1, DImode),
-; operand_subword (operands[2], 0, 1, DImode)));
-; emit_insn (gen_iorsi3 (gen_lowpart (SImode, operands[0]),
-; gen_lowpart (SImode, operands[1]),
-; gen_lowpart (SImode, operands[2])));
-; DONE;
-;}")
-
-;
-; iorsi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:SI 0 "r_or_s_operand" "=d,m")
- (ior:SI (match_operand:SI 1 "r_or_s_operand" "%0,0")
- (match_operand:SI 2 "r_or_s_operand" "g,Si")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* OR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"OR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"O %0,%2\";
- }
- mvs_check_page (0, 6, 0);
- return \"OC %O0(4,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "iorsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (ior:SI (match_operand:SI 1 "general_operand" "%0")
- (match_operand:SI 2 "general_operand" "g")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* OR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"OR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"O %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; iorhi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:HI 0 "r_or_s_operand" "=d,m")
- (ior:HI (match_operand:HI 1 "r_or_s_operand" "%0,0")
- (match_operand:HI 2 "r_or_s_operand" "di,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* OR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"OR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"O %0,%2\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 6, 2);
- return \"OC %O0(2,%R0),%H2\";
- }
- mvs_check_page (0, 6, 0);
- return \"OC %O0(2,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "iorhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (ior:HI (match_operand:HI 1 "general_operand" "%0")
- (match_operand:HI 2 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* OR sets CC but not how we want it */
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"O %0,%2\";
- }
- mvs_check_page (0, 2, 0);
- return \"OR %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; iorqi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:QI 0 "r_or_s_operand" "=d,m")
- (ior:QI (match_operand:QI 1 "r_or_s_operand" "%0,0")
- (match_operand:QI 2 "r_or_s_operand" "di,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* OR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"OR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"O %0,%2\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"OI %0,%B2\";
- }
- mvs_check_page (0, 6, 0);
- return \"OC %O0(1,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "iorqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (ior:QI (match_operand:QI 1 "general_operand" "%0")
- (match_operand:QI 2 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* OR sets CC but not how we want it */
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"O %0,%2\";
- }
- mvs_check_page (0, 2, 0);
- return \"OR %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Xor instructions.
-;;
-
-;
-; xordi3 instruction pattern(s).
-;
-
-;(define_expand "xordi3"
-; [(set (match_operand:DI 0 "general_operand" "")
-; (xor:DI (match_operand:DI 1 "general_operand" "")
-; (match_operand:DI 2 "general_operand" "")))]
-; ""
-; "
-;{
-; rtx gen_xorsi3();
-;
-; emit_insn (gen_xorsi3 (operand_subword (operands[0], 0, 1, DImode),
-; operand_subword (operands[1], 0, 1, DImode),
-; operand_subword (operands[2], 0, 1, DImode)));
-; emit_insn (gen_xorsi3 (gen_lowpart (SImode, operands[0]),
-; gen_lowpart (SImode, operands[1]),
-; gen_lowpart (SImode, operands[2])));
-; DONE;
-;}")
-
-;
-; xorsi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:SI 0 "r_or_s_operand" "=d,m")
- (xor:SI (match_operand:SI 1 "r_or_s_operand" "%0,0")
- (match_operand:SI 2 "r_or_s_operand" "g,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"XR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"X %0,%2\";
- }
- mvs_check_page (0, 6, 0);
- return \"XC %O0(4,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "xorsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (xor:SI (match_operand:SI 1 "general_operand" "%0")
- (match_operand:SI 2 "general_operand" "g")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"XR %0,%2\";
- }
- mvs_check_page (0, 4, 0);
- return \"X %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; xorhi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:HI 0 "r_or_s_operand" "=d,m")
- (xor:HI (match_operand:HI 1 "r_or_s_operand" "%0,0")
- (match_operand:HI 2 "r_or_s_operand" "di,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"XR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"X %0,%H2\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 6, 0);
- return \"XC %O0(2,%R0),%H2\";
- }
- mvs_check_page (0, 6, 0);
- return \"XC %O0(2,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "xorhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (xor:HI (match_operand:HI 1 "general_operand" "%0")
- (match_operand:HI 2 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"X %0,%H2\";
- }
- mvs_check_page (0, 2, 0);
- return \"XR %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; xorqi3 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:QI 0 "r_or_s_operand" "=d,m")
- (xor:QI (match_operand:QI 1 "r_or_s_operand" "%0,0")
- (match_operand:QI 2 "r_or_s_operand" "di,mi")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 2, 0);
- return \"XR %0,%2\";
- }
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 0);
- return \"X %0,%2\";
- }
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"XI %0,%B2\";
- }
- mvs_check_page (0, 6, 0);
- return \"XC %O0(1,%R0),%2\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "xorqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (xor:QI (match_operand:QI 1 "general_operand" "%0")
- (match_operand:QI 2 "general_operand" "di")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (GET_CODE (operands[2]) == CONST_INT)
- {
- mvs_check_page (0, 4, 0);
- return \"X %0,%2\";
- }
- mvs_check_page (0, 2, 0);
- return \"XR %0,%2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Negate instructions.
-;;
-
-;
-; negsi2 instruction pattern(s).
-;
-
-(define_insn "negsi2"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (neg:SI (match_operand:SI 1 "general_operand" "d")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LCR %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; neghi2 instruction pattern(s).
-;
-
-(define_insn "neghi2"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (neg:HI (match_operand:HI 1 "general_operand" "d")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 10, 0);
- return \"SLL %1,16\;SRA %1,16\;LCR %0,%1\";
-}"
- [(set_attr "length" "10")]
-)
-
-;
-; negdf2 instruction pattern(s).
-;
-
-(define_insn "negdf2"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (neg:DF (match_operand:DF 1 "general_operand" "f")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LCDR %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; negsf2 instruction pattern(s).
-;
-
-(define_insn "negsf2"
- [(set (match_operand:SF 0 "general_operand" "=f")
- (neg:SF (match_operand:SF 1 "general_operand" "f")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LCER %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;;
-;;- Absolute value instructions.
-;;
-
-;
-; abssi2 instruction pattern(s).
-;
-
-(define_insn "abssi2"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (abs:SI (match_operand:SI 1 "general_operand" "d")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LPR %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; abshi2 instruction pattern(s).
-;
-
-(define_insn "abshi2"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (abs:HI (match_operand:HI 1 "general_operand" "d")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 10, 0);
- return \"SLL %1,16\;SRA %1,16\;LPR %0,%1\";
-}"
- [(set_attr "length" "10")]
-)
-
-;
-; absdf2 instruction pattern(s).
-;
-
-(define_insn "absdf2"
- [(set (match_operand:DF 0 "general_operand" "=f")
- (abs:DF (match_operand:DF 1 "general_operand" "f")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LPDR %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;
-; abssf2 instruction pattern(s).
-;
-
-(define_insn "abssf2"
- [(set (match_operand:SF 0 "general_operand" "=f")
- (abs:SF (match_operand:SF 1 "general_operand" "f")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LPER %0,%1\";
-}"
- [(set_attr "length" "2")]
-)
-
-;;
-;;- One complement instructions.
-;;
-
-;
-; one_cmpldi2 instruction pattern(s).
-;
-
-;(define_expand "one_cmpldi2"
-; [(set (match_operand:DI 0 "general_operand" "")
-; (not:DI (match_operand:DI 1 "general_operand" "")))]
-; ""
-; "
-;{
-; rtx gen_one_cmplsi2();
-;
-; emit_insn (gen_one_cmplsi2 (operand_subword (operands[0], 0, 1, DImode),
-; operand_subword (operands[1], 0, 1, DImode)));
-; emit_insn (gen_one_cmplsi2 (gen_lowpart (SImode, operands[0]),
-; gen_lowpart (SImode, operands[1])));
-; DONE;
-;}")
-
-;
-; one_cmplsi2 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:SI 0 "r_or_s_operand" "=dm")
- (not:SI (match_operand:SI 1 "r_or_s_operand" "0")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 4);
- return \"X %0,=F'-1'\";
- }
- CC_STATUS_INIT;
- mvs_check_page (0, 6, 4);
- return \"XC %O0(4,%R0),=F'-1'\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "one_cmplsi2"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (not:SI (match_operand:SI 1 "general_operand" "0")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- mvs_check_page (0, 4, 4);
- return \"X %0,=F'-1'\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; one_cmplhi2 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:HI 0 "r_or_s_operand" "=dm")
- (not:HI (match_operand:HI 1 "r_or_s_operand" "0")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 4);
- return \"X %0,=F'-1'\";
- }
- mvs_check_page (0, 6, 4);
- return \"XC %O0(2,%R0),=XL4'FFFF'\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn "one_cmplhi2"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (not:HI (match_operand:HI 1 "general_operand" "0")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- mvs_check_page (0, 4, 4);
- return \"X %0,=F'-1'\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; one_cmplqi2 instruction pattern(s).
-;
-
-(define_insn ""
- [(set (match_operand:QI 0 "r_or_s_operand" "=dm")
- (not:QI (match_operand:QI 1 "r_or_s_operand" "0")))]
- "TARGET_CHAR_INSTRUCTIONS"
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 4, 4);
- return \"X %0,=F'-1'\";
- }
- mvs_check_page (0, 4, 0);
- return \"XI %0,255\";
-}"
- [(set_attr "length" "4")]
-)
-
-(define_insn "one_cmplqi2"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (not:QI (match_operand:QI 1 "general_operand" "0")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* XOR sets CC but not how we want it */
- mvs_check_page (0, 4, 4);
- return \"X %0,=F'-1'\";
-}"
- [(set_attr "length" "4")]
-)
-
-;;
-;;- Arithmetic shift instructions.
-;;
-
-;
-; ashldi3 instruction pattern(s).
-;
-
-(define_insn "ashldi3"
- [(set (match_operand:DI 0 "general_operand" "=d")
- (ashift:DI (match_operand:DI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- /* this status set seems not have the desired effect,
- * proably because the 64-bit long-long test is emulated ?! */
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"SLDA %0,0(%2)\";
- return \"SLDA %0,%c2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; ashrdi3 instruction pattern(s).
-;
-
-(define_insn "ashrdi3"
- [(set (match_operand:DI 0 "register_operand" "=d")
- (ashiftrt:DI (match_operand:DI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- /* this status set seems not have the desired effect,
- * proably because the 64-bit long-long test is emulated ?! */
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"SRDA %0,0(%2)\";
- return \"SRDA %0,%c2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; ashlsi3 instruction pattern(s).
-;
-
-(define_insn "ashlsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (ashift:SI (match_operand:SI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"SLL %0,0(%2)\";
- return \"SLL %0,%c2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; ashrsi3 instruction pattern(s).
-;
-
-(define_insn "ashrsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (ashiftrt:SI (match_operand:SI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_SET (operands[0], operands[1]);
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"SRA %0,0(%2)\";
- return \"SRA %0,%c2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; ashlhi3 instruction pattern(s).
-;
-
-(define_insn "ashlhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (ashift:HI (match_operand:HI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 8, 0);
- if (REG_P (operands[2]))
- return \"SLL %0,16(%2)\;SRA %0,16\";
- return \"SLL %0,16+%c2\;SRA %0,16\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; ashrhi3 instruction pattern(s).
-;
-
-(define_insn "ashrhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (ashiftrt:HI (match_operand:HI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 8, 0);
- if (REG_P (operands[2]))
- return \"SLL %0,16\;SRA %0,16(%2)\";
- return \"SLL %0,16\;SRA %0,16+%c2\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; ashlqi3 instruction pattern(s).
-;
-
-(define_insn "ashlqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (ashift:QI (match_operand:QI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"SLL %0,0(%2)\";
- return \"SLL %0,%c2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; ashrqi3 instruction pattern(s).
-;
-
-(define_insn "ashrqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (ashiftrt:QI (match_operand:QI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 8, 0);
- if (REG_P (operands[2]))
- return \"SLL %0,24\;SRA %0,24(%2)\";
- return \"SLL %0,24\;SRA %0,24+%c2\";
-}"
- [(set_attr "length" "8")]
-)
-
-;;
-;;- Logical shift instructions.
-;;
-
-;
-; lshrdi3 instruction pattern(s).
-;
-
-(define_insn "lshrdi3"
- [(set (match_operand:DI 0 "general_operand" "=d")
- (lshiftrt:DI (match_operand:DI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"SRDL %0,0(%2)\";
- return \"SRDL %0,%c2\";
-}"
- [(set_attr "length" "4")]
-)
-
-
-;
-; lshrsi3 instruction pattern(s).
-;
-
-(define_insn "lshrsi3"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (lshiftrt:SI (match_operand:SI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (REG_P (operands[2]))
- return \"SRL %0,0(%2)\";
- return \"SRL %0,%c2\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; lshrhi3 instruction pattern(s).
-;
-
-(define_insn "lshrhi3"
- [(set (match_operand:HI 0 "general_operand" "=d")
- (lshiftrt:HI (match_operand:HI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* AND sets the CC but not how we want it */
- if (REG_P (operands[2]))
- {
- mvs_check_page (0, 8, 4);
- return \"N %0,=XL4'0000FFFF'\;SRL %0,0(%2)\";
- }
- mvs_check_page (0, 8, 4);
- return \"N %0,=XL4'0000FFFF'\;SRL %0,%c2\";
-}"
- [(set_attr "length" "8")]
-)
-
-;
-; lshrqi3 instruction pattern(s).
-;
-
-(define_insn "lshrqi3"
- [(set (match_operand:QI 0 "general_operand" "=d")
- (lshiftrt:QI (match_operand:QI 1 "general_operand" "0")
- (match_operand:SI 2 "general_operand" "Ja")))]
- ""
- "*
-{
- check_label_emit ();
- CC_STATUS_INIT; /* AND sets the CC but not how we want it */
- mvs_check_page (0, 8, 4);
- if (REG_P (operands[2]))
- return \"N %0,=XL4'000000FF'\;SRL %0,0(%2)\";
- return \"N %0,=XL4'000000FF'\;SRL %0,%c2\";
-}"
- [(set_attr "length" "8")]
-)
-
-;; =======================================================================
-;;- Conditional jump instructions.
-;; =======================================================================
-
-;
-; beq instruction pattern(s).
-;
-
-(define_insn "beq"
- [(set (pc)
- (if_then_else (eq (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BE %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BER 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; bne instruction pattern(s).
-;
-
-(define_insn "bne"
- [(set (pc)
- (if_then_else (ne (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNE %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNER 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; bgt instruction pattern(s).
-;
-
-(define_insn "bgt"
- [(set (pc)
- (if_then_else (gt (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; bgtu instruction pattern(s).
-;
-
-(define_insn "bgtu"
- [(set (pc)
- (if_then_else (gtu (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; blt instruction pattern(s).
-;
-
-(define_insn "blt"
- [(set (pc)
- (if_then_else (lt (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; bltu instruction pattern(s).
-;
-
-(define_insn "bltu"
- [(set (pc)
- (if_then_else (ltu (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; bge instruction pattern(s).
-;
-
-(define_insn "bge"
- [(set (pc)
- (if_then_else (ge (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; bgeu instruction pattern(s).
-;
-
-(define_insn "bgeu"
- [(set (pc)
- (if_then_else (geu (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; ble instruction pattern(s).
-;
-
-(define_insn "ble"
- [(set (pc)
- (if_then_else (le (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; bleu instruction pattern(s).
-;
-
-(define_insn "bleu"
- [(set (pc)
- (if_then_else (leu (cc0)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;;
-;;- Negated conditional jump instructions.
-;;
-
-(define_insn ""
- [(set (pc)
- (if_then_else (eq (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNE %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNER 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (ne (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BE %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BER 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (gt (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (gtu (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (lt (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (ltu (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BNL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BNLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (ge (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (geu (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BL %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BLR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (le (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else (leu (cc0)
- (const_int 0))
- (pc)
- (label_ref (match_operand 0 "" ""))))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"BH %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BHR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;; ==============================================================
-;;- Subtract one and jump if not zero.
-;; These insns seem to not be getting matched ...
-;; XXX should fix this, as it would improve for loops
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (ne (plus:SI (match_operand:SI 0 "register_operand" "+d")
- (const_int -1))
- (const_int 0))
- (label_ref (match_operand 1 "" ""))
- (pc)))
- (set (match_dup 0)
- (plus:SI (match_dup 0)
- (const_int -1)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (mvs_check_label (CODE_LABEL_NUMBER (operands[1])))
- {
- return \"BCT %0,%l1\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l1)\;BCTR %0,14\";
-}"
- [(set_attr "length" "6")]
-)
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (eq (plus:SI (match_operand:SI 0 "register_operand" "+d")
- (const_int -1))
- (const_int 0))
- (pc)
- (label_ref (match_operand 1 "" ""))))
- (set (match_dup 0)
- (plus:SI (match_dup 0)
- (const_int -1)))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (mvs_check_label (CODE_LABEL_NUMBER (operands[1])))
- {
- return \"BCT %0,%l1\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l1)\;BCTR %0,14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;; =============================================================
-;;- Unconditional jump instructions.
-;;
-
-;
-; jump instruction pattern(s).
-;
-
-(define_insn "jump"
- [(set (pc)
- (label_ref (match_operand 0 "" "")))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 4, 0);
- if (i370_short_branch(insn) || mvs_check_label (CODE_LABEL_NUMBER (operands[0])))
- {
- return \"B %l0\";
- }
- mvs_check_page (0, 2, 4);
- return \"L 14,=A(%l0)\;BR 14\";
-}"
- [(set_attr "length" "6")]
-)
-
-;
-; indirect-jump instruction pattern(s).
-; hack alert -- should check that displacement is < 4096
-
-(define_insn "indirect_jump"
- [(set (pc) (match_operand:SI 0 "general_operand" "rm"))]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 2, 0);
- return \"BR %0\";
- }
- mvs_check_page (0, 4, 0);
- return \"B %0\";
-}"
- [(set_attr "length" "4")]
-)
-
-;
-; tablejump instruction pattern(s).
-;
-
-(define_insn "tablejump"
- [(set (pc)
- (match_operand:SI 0 "general_operand" "am"))
- (use (label_ref (match_operand 1 "" "")))
-; (clobber (reg:SI 14))
- ]
- ""
- "*
-{
- check_label_emit ();
- if (REG_P (operands[0]))
- {
- mvs_check_page (0, 6, 0);
- return \"BR %0\;DS 0F\";
- }
- mvs_check_page (0, 10, 0);
- return \"L 14,%0\;BR 14\;DS 0F\";
-}"
- [(set_attr "length" "10")]
-)
-
-;;
-;;- Jump to subroutine.
-;;
-;; For the C/370 environment the internal functions, ie. sqrt, are called with
-;; a non-standard form. So, we must fix it here. There's no BM like IBM.
-;;
-;; The ELF ABI is different from the C/370 ABI because we have a simpler,
-;; more powerful way of dealing with structure-value returns. Basically,
-;; we use R1 to point at structure returns (64-bit and larger returns)
-;; and R11 to point at the args. Note that this handles double-precision
-;; (64-bit) values just fine, in a less-kludged manner than the C/370 ABI.
-;; Since R1 is used, we use R2 to pass the argument pointer to the routine.
-
-;
-; call instruction pattern(s).
-;
-; We define four call instruction patterns below. The first two patterns,
-; although general, end up matching (only?) calls through function pointers.
-; The last two, which require a symbol-ref to match, get used for all
-; ordinary subroutine calls.
-
-(define_insn "call"
- [(call (match_operand:QI 0 "memory_operand" "m")
- (match_operand:SI 1 "immediate_operand" "i"))
- (clobber (reg:SI 2))
- ]
- ""
- "*
-{
- static char temp[128];
- int i = STACK_POINTER_OFFSET;
- CC_STATUS_INIT;
-
- check_label_emit ();
-#ifdef TARGET_ELF_ABI
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA r2,%d(,sp)\;LA 15,%%0\;BASR 14,15\", i );
- return temp;
-#else
- if (mvs_function_check (XSTR (operands[0], 0)))
- {
- mvs_check_page (0, 22, 4);
- sprintf ( temp, \"LA 1,136(,13)\;ST 1,%d(,13)\;LA 1,%d(,13)\;LA 15,%%0\;BALR 14,15\;LD 0,136(,13)\",
- i - 4, i - 4 );
- }
- else
- {
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA 1,%d(,13)\;LA 15,%%0\;BALR 14,15\", i );
- }
- return temp;
-#endif
-}"
- [(set_attr "length" "22")]
-)
-
-;
-; call_value instruction pattern(s).
-;
-
-(define_insn "call_value"
- [(set (match_operand 0 "" "=rf")
- (call (match_operand:QI 1 "memory_operand" "m")
- (match_operand:SI 2 "general_operand" "i")))
- (clobber (reg:SI 2))
- ]
- ""
- "*
-{
- static char temp[128];
- int i = STACK_POINTER_OFFSET;
- CC_STATUS_INIT;
-
- check_label_emit ();
-#ifdef TARGET_ELF_ABI
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA r2,%d(,sp)\;LA 15,%%1\;BASR 14,15\", i );
- return temp;
-#else
- if (mvs_function_check (XSTR (operands[1], 0)))
- {
- mvs_check_page (0, 22, 4);
- sprintf ( temp, \"LA 1,136(,13)\;ST 1,%d(,13)\;LA 1,%d(,13)\;LA 15,%%1\;BALR 14,15\;LD 0,136(,13)\",
- i - 4, i - 4 );
- }
- else
- {
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA 1,%d(,13)\;LA 15,%%1\;BALR 14,15\", i );
- }
- return temp;
-#endif
-}"
- [(set_attr "length" "22")]
-)
-
-(define_insn ""
- [(call (mem:QI (match_operand:SI 0 "" "i"))
- (match_operand:SI 1 "general_operand" "g"))
- (clobber (reg:SI 2))
- ]
- "GET_CODE (operands[0]) == SYMBOL_REF"
- "*
-{
- static char temp[128];
- int i = STACK_POINTER_OFFSET;
- CC_STATUS_INIT;
-
- check_label_emit ();
-#ifdef TARGET_ELF_ABI
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA r2,%d(,sp)\;L 15,%%0\;BASR 14,15\", i );
- return temp;
-#else
- if (mvs_function_check (XSTR (operands[0], 0)))
- {
- mvs_check_page (0, 22, 4);
- sprintf ( temp, \"LA 1,136(,13)\;ST 1,%d(,13)\;LA 1,%d(,13)\;L 15,%%0\;BALR 14,15\;LD 0,136(,13)\",
- i - 4, i - 4 );
- }
- else
- {
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA 1,%d(,13)\;L 15,%%0\;BALR 14,15\", i );
- }
- return temp;
-#endif
-}"
- [(set_attr "length" "22")]
-)
-
-(define_insn ""
- [(set (match_operand 0 "" "=rf")
- (call (mem:QI (match_operand:SI 1 "" "i"))
- (match_operand:SI 2 "general_operand" "g")))
- (clobber (reg:SI 2))
- ]
- "GET_CODE (operands[1]) == SYMBOL_REF"
- "*
-{
- static char temp[128];
- int i = STACK_POINTER_OFFSET;
- CC_STATUS_INIT;
-
- check_label_emit ();
-#ifdef TARGET_ELF_ABI
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA r2,%d(,sp)\;L 15,%%1\;BASR 14,15\", i );
- return temp;
-#else
- if (mvs_function_check (XSTR (operands[1], 0)))
- {
- mvs_check_page (0, 22, 4);
- sprintf ( temp, \"LA 1,136(,13)\;ST 1,%d(,13)\;LA 1,%d(,13)\;L 15,%%1\;BALR 14,15\;LD 0,136(,13)\",
- i - 4, i - 4 );
- }
- else
- {
- mvs_check_page (0, 10, 4);
- sprintf ( temp, \"LA 1,%d(,13)\;L 15,%%1\;BALR 14,15\", i );
- }
- return temp;
-#endif
-}"
- [(set_attr "length" "22")]
-)
-
-;;
-;; Call subroutine returning any type.
-;; This instruction pattern appears to be used only by the
-;; expand_builtin_apply definition for __builtin_apply. It is needed
-;; since call_value might return an int in r15 or a float in fpr0 (r16)
-;; and the builtin code calls abort since the reg is ambiguous. Well,
-;; the below is probably broken anyway, we just want to go for now.
-;;
-(define_expand "untyped_call"
-[(parallel [(call (match_operand 0 "" "")
- (const_int 0))
- (match_operand 1 "" "")
- (match_operand 2 "" "")])]
- ""
- "
-{
- int i;
-
- emit_call_insn (GEN_CALL (operands[0], const0_rtx, const0_rtx, const0_rtx));
-
- for (i = 0; i < XVECLEN (operands[2], 0); i++)
- {
- rtx set = XVECEXP (operands[2], 0, i);
- emit_move_insn (SET_DEST (set), SET_SRC (set));
- }
-
- /* The optimizer does not know that the call sets the function value
- registers we stored in the result block. We avoid problems by
- claiming that all hard registers are used and clobbered at this
- point. */
- /* emit_insn (gen_blockage ()); */
-
- DONE;
-}")
-
-
-;;
-;;- Miscellaneous instructions.
-;;
-
-;
-; nop instruction pattern(s).
-;
-
-(define_insn "nop"
- [(const_int 0)]
- ""
- "*
-{
- check_label_emit ();
- mvs_check_page (0, 2, 0);
- return \"LR 0,0\";
-}"
- [(set_attr "length" "2")]
-)
+++ /dev/null
-/* Definitions of target machine for GNU compiler. System/370 version.
- Copyright (C) 1989, 1993, 1995, 1996, 1997, 2003
- Free Software Foundation, Inc.
- Contributed by Jan Stein (jan@cd.chalmers.se).
- Modified for Linux/390 by Linas Vepstas (linas@linas.org)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-
-#define TARGET_VERSION fprintf (stderr, " (i370 GNU/Linux with ELF)");
-
-/* Specify that we're generating code for a Linux port to 370 */
-
-#define TARGET_ELF_ABI
-
-/* Target OS preprocessor built-ins. */
-#define TARGET_OS_CPP_BUILTINS() LINUX_TARGET_OS_CPP_BUILTINS()
-
-/* Options for this target machine. */
-
-#define LIBGCC_SPEC "libgcc.a%s"
-
-#ifdef SOME_FUTURE_DAY
-
-#define CPP_SPEC "%{posix: -D_POSIX_SOURCE} %(cpp_sysv) %(cpp_endian_big) \
-%{mcall-linux: %(cpp_os_linux) } \
-%{!mcall-linux: %(cpp_os_default) }"
-
-#define LIB_SPEC "\
-%{mcall-linux: %(lib_linux) } \
-%{!mcall-linux:%(lib_default) }"
-
-#define STARTFILE_SPEC "\
-%{mcall-linux: %(startfile_linux) } \
-%{!mcall-linux: %(startfile_default) }"
-
-#define ENDFILE_SPEC "\
-%{mcall-linux: %(endfile_linux) } \
-%{!mcall-linux: %(endfile_default) }"
-
-/* GNU/Linux support. */
-#ifndef LIB_LINUX_SPEC
-#define LIB_LINUX_SPEC "%{mnewlib: --start-group -llinux -lc --end-group } %{!mnewlib: -lc }"
-#endif
-
-#ifndef STARTFILE_LINUX_SPEC
-#define STARTFILE_LINUX_SPEC "\
-%{!shared: %{pg:gcrt1.o%s} %{!pg:%{p:gcrt1.o%s} %{!p:crt1.o%s}}} \
-%{mnewlib: ecrti.o%s} \
-%{!mnewlib: crti.o%s %{!shared:crtbegin.o%s} %{shared:crtbeginS.o%s}}"
-#endif
-
-#ifndef ENDFILE_LINUX_SPEC
-#define ENDFILE_LINUX_SPEC "\
-%{mnewlib: ecrtn.o%s} \
-%{!mnewlib: %{!shared:crtend.o%s} %{shared:crtendS.o%s} crtn.o%s}"
-#endif
-
-#ifndef LINK_START_LINUX_SPEC
-#define LINK_START_LINUX_SPEC "-Ttext 0x10000"
-#endif
-
-#ifndef LINK_OS_LINUX_SPEC
-#define LINK_OS_LINUX_SPEC ""
-#endif
-
-#ifndef CPP_OS_LINUX_SPEC
-#define CPP_OS_LINUX_SPEC "-D__unix__ -D__gnu_linux__ -D__linux__ \
-%{!ansi: -Dunix -Dlinux } \
--Asystem=unix -Asystem=linux"
-#endif
-
-#ifndef CPP_OS_LINUX_SPEC
-#define CPP_OS_LINUX_SPEC ""
-#endif
-
-
-/* Define any extra SPECS that the compiler needs to generate. */
-#undef SUBTARGET_EXTRA_SPECS
-#define SUBTARGET_EXTRA_SPECS \
- { "lib_linux", LIB_LINUX_SPEC }, \
- { "lib_default", LIB_DEFAULT_SPEC }, \
- { "startfile_linux", STARTFILE_LINUX_SPEC }, \
- { "startfile_default", STARTFILE_DEFAULT_SPEC }, \
- { "endfile_linux", ENDFILE_LINUX_SPEC }, \
- { "endfile_default", ENDFILE_DEFAULT_SPEC }, \
- { "link_shlib", LINK_SHLIB_SPEC }, \
- { "link_target", LINK_TARGET_SPEC }, \
- { "link_start", LINK_START_SPEC }, \
- { "link_start_linux", LINK_START_LINUX_SPEC }, \
- { "link_os", LINK_OS_SPEC }, \
- { "link_os_linux", LINK_OS_LINUX_SPEC }, \
- { "link_os_default", LINK_OS_DEFAULT_SPEC }, \
- { "cpp_endian_big", CPP_ENDIAN_BIG_SPEC }, \
- { "cpp_os_linux", CPP_OS_LINUX_SPEC }, \
- { "cpp_os_default", CPP_OS_DEFAULT_SPEC },
-
-#endif /* SOME_FUTURE_DAY */
+++ /dev/null
-/* Definitions of target machine for GNU compiler. System/370 version.
- Copyright (C) 1989, 1993, 1995, 1996, 1997, 2003
- Free Software Foundation, Inc.
- Contributed by Jan Stein (jan@cd.chalmers.se).
- Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#define TARGET_VERSION printf (" (370/MVS)");
-
-/* Specify that we're generating code for the Language Environment */
-
-#define LE370 1
-#define TARGET_EBCDIC 1
-#define TARGET_HLASM 1
-
-/* Options for the preprocessor for this target machine. */
-
-#define CPP_SPEC "-trigraphs"
-
-/* Target OS preprocessor built-ins. */
-#define TARGET_OS_CPP_BUILTINS() \
- do { \
- builtin_define_std ("MVS"); \
- builtin_define_std ("mvs"); \
- MAYBE_LE370_MACROS(); \
- builtin_assert ("system=mvs"); \
- } while (0)
-
-#if defined(LE370)
-# define MAYBE_LE370_MACROS() do {builtin_define_std ("LE370");} while (0)
-#else
-# define MAYBE_LE370_MACROS()
-#endif
+++ /dev/null
-/* Definitions of target machine for GNU compiler. System/370 version.
- Copyright (C) 1989, 1993, 1995, 1996, 1997, 2003
- Free Software Foundation, Inc.
- Contributed by Jan Stein (jan@cd.chalmers.se).
- Modified for OS/390 OpenEdition by Dave Pitts (dpitts@cozx.com)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#define TARGET_VERSION printf (" (370/OpenEdition)");
-
-/* Specify that we're generating code for the Language Environment */
-
-#define LE370 1
-#define LONGEXTERNAL 1
-#define TARGET_EBCDIC 1
-#define TARGET_HLASM 1
-
-/* Options for the preprocessor for this target machine. */
-
-#define CPP_SPEC "-trigraphs"
-
-/* Options for this target machine. */
-
-#define LIB_SPEC ""
-#define LIBGCC_SPEC ""
-#define STARTFILE_SPEC "/usr/local/lib/gccmain.o"
-
-/* Target OS preprocessor built-ins. */
-#define TARGET_OS_CPP_BUILTINS() \
- do { \
- builtin_define_std ("unix"); \
- builtin_define_std ("UNIX"); \
- builtin_define_std ("openedition"); \
- builtin_define ("__i370__"); \
- builtin_assert ("system=openedition"); \
- builtin_assert ("system=unix"); \
- } while (0)
-
+++ /dev/null
-i370-c.o: $(srcdir)/config/i370/i370-c.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \
- $(TM_H) $(TREE_H) toplev.h $(CPPLIB_H) c-pragma.h $(TM_P_H)
- $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)/config/i370/i370-c.c
+++ /dev/null
-/* Intel 80960 specific, C compiler specific functions.
- Copyright (C) 1992, 1995, 1996, 1997, 1998, 1999, 2000
- Free Software Foundation, Inc.
- Contributed by Steven McGeady, Intel Corp.
- Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
- Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "cpplib.h"
-#include "tree.h"
-#include "c-pragma.h"
-#include "toplev.h"
-#include "ggc.h"
-#include "tm_p.h"
-
-/* Handle pragmas for compatibility with Intel's compilers. */
-
-/* NOTE: ic960 R3.0 pragma align definition:
-
- #pragma align [(size)] | (identifier=size[,...])
- #pragma noalign [(identifier)[,...]]
-
- (all parens are optional)
-
- - size is [1,2,4,8,16]
- - noalign means size==1
- - applies only to component elements of a struct (and union?)
- - identifier applies to structure tag (only)
- - missing identifier means next struct
-
- - alignment rules for bitfields need more investigation.
-
- This implementation only handles the case of no identifiers. */
-
-void
-i960_pr_align (pfile)
- cpp_reader *pfile ATTRIBUTE_UNUSED;
-{
- tree number;
- enum cpp_ttype type;
- int align;
-
- type = c_lex (&number);
- if (type == CPP_OPEN_PAREN)
- type = c_lex (&number);
- if (type == CPP_NAME)
- {
- warning ("sorry, not implemented: #pragma align NAME=SIZE");
- return;
- }
- if (type != CPP_NUMBER)
- {
- warning ("malformed #pragma align - ignored");
- return;
- }
-
- align = TREE_INT_CST_LOW (number);
- switch (align)
- {
- case 0:
- /* Return to last alignment. */
- align = i960_last_maxbitalignment / 8;
- /* Fall through. */
- case 16:
- case 8:
- case 4:
- case 2:
- case 1:
- i960_last_maxbitalignment = i960_maxbitalignment;
- i960_maxbitalignment = align * 8;
- break;
-
- default:
- /* Silently ignore bad values. */
- break;
- }
-}
-
-void
-i960_pr_noalign (pfile)
- cpp_reader *pfile ATTRIBUTE_UNUSED;
-{
- enum cpp_ttype type;
- tree number;
-
- type = c_lex (&number);
- if (type == CPP_OPEN_PAREN)
- type = c_lex (&number);
- if (type == CPP_NAME)
- {
- warning ("sorry, not implemented: #pragma noalign NAME");
- return;
- }
-
- i960_last_maxbitalignment = i960_maxbitalignment;
- i960_maxbitalignment = 8;
-}
+++ /dev/null
-/* Definitions of target machine for GNU compiler, for "naked" Intel
- 80960 using coff object format and coff debugging symbols.
- Copyright (C) 1988, 1989, 1991, 1996, 2000 Free Software Foundation.
- Contributed by Steven McGeady (mcg@omepd.intel.com)
- Additional work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
- Converted to GCC 2.0 by Michael Tiemann, Cygnus Support.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* Support -gstabs using stabs in COFF sections. */
-
-/* Generate SDB_DEBUGGING_INFO by default. */
-#undef PREFERRED_DEBUGGING_TYPE
-#define PREFERRED_DEBUGGING_TYPE SDB_DEBUG
-
-/* This is intended to be used with Cygnus's newlib library, so we want to
- use the standard definition of LIB_SPEC. */
-#undef LIB_SPEC
-
-/* Emit a .file directive. */
-#define TARGET_ASM_FILE_START_FILE_DIRECTIVE true
-
-/* Support the ctors and dtors sections for g++. */
-
-#define CTORS_SECTION_ASM_OP "\t.section\t.ctors,\"x\""
-#define DTORS_SECTION_ASM_OP "\t.section\t.dtors,\"x\""
-
-/* end of i960-coff.h */
+++ /dev/null
-/* Definitions of target machine for GNU compiler, for Intel 80960
- Copyright (C) 2002 Free Software Foundation, Inc.
- Contributed by Steven McGeady, Intel Corp.
- Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
- Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* long double */
-FLOAT_MODE (TF, 16, ieee_extended_intel_128_format);
-
-/* Add any extra modes needed to represent the condition code.
-
- Also, signed and unsigned comparisons are distinguished, as
- are operations which are compatible with chkbit insns. */
-
-CC_MODE (CC_UNS);
-CC_MODE (CC_CHK);
+++ /dev/null
-/* Definitions of target machine for GNU compiler, for Intel 80960
- Copyright (C) 2000
- Free Software Foundation, Inc.
- Contributed by Steven McGeady, Intel Corp.
- Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
- Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#ifndef GCC_I960_PROTOS_H
-#define GCC_I960_PROTOS_H
-
-#ifdef RTX_CODE
-extern struct rtx_def *legitimize_address (rtx, rtx, enum machine_mode);
-/* Define the function that build the compare insn for scc and bcc. */
-
-extern struct rtx_def *gen_compare_reg (enum rtx_code, rtx, rtx);
-
-/* Define functions in i960.c and used in insn-output.c. */
-
-extern const char *i960_output_ldconst (rtx, rtx);
-extern const char *i960_output_call_insn (rtx, rtx, rtx, rtx);
-extern const char *i960_output_ret_insn (rtx);
-extern const char *i960_output_move_double (rtx, rtx);
-extern const char *i960_output_move_double_zero (rtx);
-extern const char *i960_output_move_quad (rtx, rtx);
-extern const char *i960_output_move_quad_zero (rtx);
-
-extern int literal (rtx, enum machine_mode);
-extern int hard_regno_mode_ok (int, enum machine_mode);
-extern int fp_literal (rtx, enum machine_mode);
-extern int signed_literal (rtx, enum machine_mode);
-extern int legitimate_address_p (enum machine_mode, rtx, int);
-extern void i960_print_operand (FILE *, rtx, int);
-extern int fpmove_src_operand (rtx, enum machine_mode);
-extern int arith_operand (rtx, enum machine_mode);
-extern int logic_operand (rtx, enum machine_mode);
-extern int fp_arith_operand (rtx, enum machine_mode);
-extern int signed_arith_operand (rtx, enum machine_mode);
-extern int fp_literal_one (rtx, enum machine_mode);
-extern int fp_literal_zero (rtx, enum machine_mode);
-extern int symbolic_memory_operand (rtx, enum machine_mode);
-extern int eq_or_neq (rtx, enum machine_mode);
-extern int arith32_operand (rtx, enum machine_mode);
-extern int power2_operand (rtx, enum machine_mode);
-extern int cmplpower2_operand (rtx, enum machine_mode);
-extern enum machine_mode select_cc_mode (RTX_CODE, rtx);
-extern int emit_move_sequence (rtx *, enum machine_mode);
-extern int i960_bypass (rtx, rtx, rtx, int);
-extern void i960_print_operand_addr (FILE *, rtx);
-extern int i960_expr_alignment (rtx, int);
-extern int i960_improve_align (rtx, rtx, int);
-extern int i960_si_ti (rtx, rtx);
-extern int i960_si_di (rtx, rtx);
-#ifdef TREE_CODE
-extern struct rtx_def *i960_function_arg (CUMULATIVE_ARGS *,
- enum machine_mode,
- tree, int);
-extern rtx i960_va_arg (tree, tree);
-extern void i960_va_start (tree, rtx);
-#endif /* TREE_CODE */
-extern enum reg_class secondary_reload_class (enum reg_class, enum machine_mode, rtx);
-#endif /* RTX_CODE */
-
-#ifdef TREE_CODE
-extern void i960_function_name_declare (FILE *, const char *, tree);
-extern void i960_function_arg_advance (CUMULATIVE_ARGS *, enum machine_mode, tree, int);
-extern int i960_round_align (int, tree);
-extern void i960_setup_incoming_varargs (CUMULATIVE_ARGS *, enum machine_mode, tree, int *, int);
-extern int i960_final_reg_parm_stack_space (int, tree);
-extern int i960_reg_parm_stack_space (tree);
-#endif /* TREE_CODE */
-
-extern int process_pragma (int(*)(void), void(*)(int), const char *);
-extern int i960_object_bytes_bitalign (int);
-extern void i960_initialize (void);
-extern int bitpos (unsigned int);
-extern int is_mask (unsigned int);
-extern int bitstr (unsigned int, int *, int *);
-extern int compute_frame_size (int);
-extern void output_function_profiler (FILE *, int);
-extern void i960_scan_opcode (const char *);
-
-extern void i960_pr_align (struct cpp_reader *);
-extern void i960_pr_noalign (struct cpp_reader *);
-
-#endif /* ! GCC_I960_PROTOS_H */
+++ /dev/null
-/* Subroutines used for code generation on intel 80960.
- Copyright (C) 1992, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
- Free Software Foundation, Inc.
- Contributed by Steven McGeady, Intel Corp.
- Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
- Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include <math.h>
-#include "rtl.h"
-#include "regs.h"
-#include "hard-reg-set.h"
-#include "real.h"
-#include "insn-config.h"
-#include "conditions.h"
-#include "output.h"
-#include "insn-attr.h"
-#include "flags.h"
-#include "tree.h"
-#include "expr.h"
-#include "except.h"
-#include "function.h"
-#include "recog.h"
-#include "toplev.h"
-#include "tm_p.h"
-#include "target.h"
-#include "target-def.h"
-
-static void i960_output_function_prologue (FILE *, HOST_WIDE_INT);
-static void i960_output_function_epilogue (FILE *, HOST_WIDE_INT);
-static void i960_output_mi_thunk (FILE *, tree, HOST_WIDE_INT,
- HOST_WIDE_INT, tree);
-static bool i960_rtx_costs (rtx, int, int, int *);
-static int i960_address_cost (rtx);
-static tree i960_build_builtin_va_list (void);
-
-/* Save the operands last given to a compare for use when we
- generate a scc or bcc insn. */
-
-rtx i960_compare_op0, i960_compare_op1;
-
-/* Used to implement #pragma align/noalign. Initialized by OVERRIDE_OPTIONS
- macro in i960.h. */
-
-int i960_maxbitalignment;
-int i960_last_maxbitalignment;
-
-/* Used to implement switching between MEM and ALU insn types, for better
- C series performance. */
-
-enum insn_types i960_last_insn_type;
-
-/* The leaf-procedure return register. Set only if this is a leaf routine. */
-
-static int i960_leaf_ret_reg;
-
-/* True if replacing tail calls with jumps is OK. */
-
-static int tail_call_ok;
-
-/* A string containing a list of insns to emit in the epilogue so as to
- restore all registers saved by the prologue. Created by the prologue
- code as it saves registers away. */
-
-char epilogue_string[1000];
-
-/* A unique number (per function) for return labels. */
-
-static int ret_label = 0;
-
-/* This is true if FNDECL is either a varargs or a stdarg function.
- This is used to help identify functions that use an argument block. */
-
-#define VARARGS_STDARG_FUNCTION(FNDECL) \
-(TYPE_ARG_TYPES (TREE_TYPE (FNDECL)) != 0 \
- && (TREE_VALUE (tree_last (TYPE_ARG_TYPES (TREE_TYPE (FNDECL))))) \
- != void_type_node)
-\f
-/* Initialize the GCC target structure. */
-#undef TARGET_ASM_ALIGNED_SI_OP
-#define TARGET_ASM_ALIGNED_SI_OP "\t.word\t"
-
-#undef TARGET_ASM_FUNCTION_PROLOGUE
-#define TARGET_ASM_FUNCTION_PROLOGUE i960_output_function_prologue
-#undef TARGET_ASM_FUNCTION_EPILOGUE
-#define TARGET_ASM_FUNCTION_EPILOGUE i960_output_function_epilogue
-
-#undef TARGET_ASM_OUTPUT_MI_THUNK
-#define TARGET_ASM_OUTPUT_MI_THUNK i960_output_mi_thunk
-#undef TARGET_CAN_ASM_OUTPUT_MI_THUNK
-#define TARGET_CAN_ASM_OUTPUT_MI_THUNK default_can_output_mi_thunk_no_vcall
-
-#undef TARGET_RTX_COSTS
-#define TARGET_RTX_COSTS i960_rtx_costs
-#undef TARGET_ADDRESS_COST
-#define TARGET_ADDRESS_COST i960_address_cost
-
-#undef TARGET_BUILD_BUILTIN_VA_LIST
-#define TARGET_BUILD_BUILTIN_VA_LIST i960_build_builtin_va_list
-
-struct gcc_target targetm = TARGET_INITIALIZER;
-\f
-/* Override conflicting target switch options.
- Doesn't actually detect if more than one -mARCH option is given, but
- does handle the case of two blatantly conflicting -mARCH options.
-
- Also initialize variables before compiling any files. */
-
-void
-i960_initialize ()
-{
- if (TARGET_K_SERIES && TARGET_C_SERIES)
- {
- warning ("conflicting architectures defined - using C series");
- target_flags &= ~TARGET_FLAG_K_SERIES;
- }
- if (TARGET_K_SERIES && TARGET_MC)
- {
- warning ("conflicting architectures defined - using K series");
- target_flags &= ~TARGET_FLAG_MC;
- }
- if (TARGET_C_SERIES && TARGET_MC)
- {
- warning ("conflicting architectures defined - using C series");
- target_flags &= ~TARGET_FLAG_MC;
- }
- if (TARGET_IC_COMPAT3_0)
- {
- flag_short_enums = 1;
- flag_signed_char = 1;
- target_flags |= TARGET_FLAG_CLEAN_LINKAGE;
- if (TARGET_IC_COMPAT2_0)
- {
- warning ("iC2.0 and iC3.0 are incompatible - using iC3.0");
- target_flags &= ~TARGET_FLAG_IC_COMPAT2_0;
- }
- }
- if (TARGET_IC_COMPAT2_0)
- {
- flag_signed_char = 1;
- target_flags |= TARGET_FLAG_CLEAN_LINKAGE;
- }
-
- if (TARGET_IC_COMPAT2_0)
- {
- i960_maxbitalignment = 8;
- i960_last_maxbitalignment = 128;
- }
- else
- {
- i960_maxbitalignment = 128;
- i960_last_maxbitalignment = 8;
- }
-}
-\f
-/* Return true if OP can be used as the source of an fp move insn. */
-
-int
-fpmove_src_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (GET_CODE (op) == CONST_DOUBLE || general_operand (op, mode));
-}
-
-#if 0
-/* Return true if OP is a register or zero. */
-
-int
-reg_or_zero_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return register_operand (op, mode) || op == const0_rtx;
-}
-#endif
-
-/* Return truth value of whether OP can be used as an operands in a three
- address arithmetic insn (such as add %o1,7,%l2) of mode MODE. */
-
-int
-arith_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (register_operand (op, mode) || literal (op, mode));
-}
-
-/* Return truth value of whether OP can be used as an operands in a three
- address logic insn, possibly complementing OP, of mode MODE. */
-
-int
-logic_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (register_operand (op, mode)
- || (GET_CODE (op) == CONST_INT
- && INTVAL(op) >= -32 && INTVAL(op) < 32));
-}
-
-/* Return true if OP is a register or a valid floating point literal. */
-
-int
-fp_arith_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (register_operand (op, mode) || fp_literal (op, mode));
-}
-
-/* Return true if OP is a register or a valid signed integer literal. */
-
-int
-signed_arith_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (register_operand (op, mode) || signed_literal (op, mode));
-}
-
-/* Return truth value of whether OP is an integer which fits the
- range constraining immediate operands in three-address insns. */
-
-int
-literal (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- return ((GET_CODE (op) == CONST_INT) && INTVAL(op) >= 0 && INTVAL(op) < 32);
-}
-
-/* Return true if OP is a float constant of 1. */
-
-int
-fp_literal_one (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (TARGET_NUMERICS && mode == GET_MODE (op) && op == CONST1_RTX (mode));
-}
-
-/* Return true if OP is a float constant of 0. */
-
-int
-fp_literal_zero (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return (TARGET_NUMERICS && mode == GET_MODE (op) && op == CONST0_RTX (mode));
-}
-
-/* Return true if OP is a valid floating point literal. */
-
-int
-fp_literal(op, mode)
- rtx op;
- enum machine_mode mode;
-{
- return fp_literal_zero (op, mode) || fp_literal_one (op, mode);
-}
-
-/* Return true if OP is a valid signed immediate constant. */
-
-int
-signed_literal(op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- return ((GET_CODE (op) == CONST_INT) && INTVAL(op) > -32 && INTVAL(op) < 32);
-}
-
-/* Return truth value of statement that OP is a symbolic memory
- operand of mode MODE. */
-
-int
-symbolic_memory_operand (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- if (GET_CODE (op) == SUBREG)
- op = SUBREG_REG (op);
- if (GET_CODE (op) != MEM)
- return 0;
- op = XEXP (op, 0);
- return (GET_CODE (op) == SYMBOL_REF || GET_CODE (op) == CONST
- || GET_CODE (op) == HIGH || GET_CODE (op) == LABEL_REF);
-}
-
-/* Return truth value of whether OP is EQ or NE. */
-
-int
-eq_or_neq (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- return (GET_CODE (op) == EQ || GET_CODE (op) == NE);
-}
-
-/* OP is an integer register or a constant. */
-
-int
-arith32_operand (op, mode)
- rtx op;
- enum machine_mode mode;
-{
- if (register_operand (op, mode))
- return 1;
- return (CONSTANT_P (op));
-}
-
-/* Return true if OP is an integer constant which is a power of 2. */
-
-int
-power2_operand (op,mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- if (GET_CODE (op) != CONST_INT)
- return 0;
-
- return exact_log2 (INTVAL (op)) >= 0;
-}
-
-/* Return true if OP is an integer constant which is the complement of a
- power of 2. */
-
-int
-cmplpower2_operand (op, mode)
- rtx op;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- if (GET_CODE (op) != CONST_INT)
- return 0;
-
- return exact_log2 (~ INTVAL (op)) >= 0;
-}
-
-/* If VAL has only one bit set, return the index of that bit. Otherwise
- return -1. */
-
-int
-bitpos (val)
- unsigned int val;
-{
- register int i;
-
- for (i = 0; val != 0; i++, val >>= 1)
- {
- if (val & 1)
- {
- if (val != 1)
- return -1;
- return i;
- }
- }
- return -1;
-}
-
-/* Return nonzero if OP is a mask, i.e. all one bits are consecutive.
- The return value indicates how many consecutive nonzero bits exist
- if this is a mask. This is the same as the next function, except that
- it does not indicate what the start and stop bit positions are. */
-
-int
-is_mask (val)
- unsigned int val;
-{
- register int start, end = 0, i;
-
- start = -1;
- for (i = 0; val != 0; val >>= 1, i++)
- {
- if (val & 1)
- {
- if (start < 0)
- start = i;
-
- end = i;
- continue;
- }
- /* Still looking for the first bit. */
- if (start < 0)
- continue;
-
- /* We've seen the start of a bit sequence, and now a zero. There
- must be more one bits, otherwise we would have exited the loop.
- Therefore, it is not a mask. */
- if (val)
- return 0;
- }
-
- /* The bit string has ones from START to END bit positions only. */
- return end - start + 1;
-}
-
-/* If VAL is a mask, then return nonzero, with S set to the starting bit
- position and E set to the ending bit position of the mask. The return
- value indicates how many consecutive bits exist in the mask. This is
- the same as the previous function, except that it also indicates the
- start and end bit positions of the mask. */
-
-int
-bitstr (val, s, e)
- unsigned int val;
- int *s, *e;
-{
- register int start, end, i;
-
- start = -1;
- end = -1;
- for (i = 0; val != 0; val >>= 1, i++)
- {
- if (val & 1)
- {
- if (start < 0)
- start = i;
-
- end = i;
- continue;
- }
-
- /* Still looking for the first bit. */
- if (start < 0)
- continue;
-
- /* We've seen the start of a bit sequence, and now a zero. There
- must be more one bits, otherwise we would have exited the loop.
- Therefor, it is not a mask. */
- if (val)
- {
- start = -1;
- end = -1;
- break;
- }
- }
-
- /* The bit string has ones from START to END bit positions only. */
- *s = start;
- *e = end;
- return ((start < 0) ? 0 : end - start + 1);
-}
-\f
-/* Return the machine mode to use for a comparison. */
-
-enum machine_mode
-select_cc_mode (op, x)
- RTX_CODE op;
- rtx x ATTRIBUTE_UNUSED;
-{
- if (op == GTU || op == LTU || op == GEU || op == LEU)
- return CC_UNSmode;
- return CCmode;
-}
-
-/* X and Y are two things to compare using CODE. Emit the compare insn and
- return the rtx for register 36 in the proper mode. */
-
-rtx
-gen_compare_reg (code, x, y)
- enum rtx_code code;
- rtx x, y;
-{
- rtx cc_reg;
- enum machine_mode ccmode = SELECT_CC_MODE (code, x, y);
- enum machine_mode mode
- = GET_MODE (x) == VOIDmode ? GET_MODE (y) : GET_MODE (x);
-
- if (mode == SImode)
- {
- if (! arith_operand (x, mode))
- x = force_reg (SImode, x);
- if (! arith_operand (y, mode))
- y = force_reg (SImode, y);
- }
-
- cc_reg = gen_rtx_REG (ccmode, 36);
- emit_insn (gen_rtx_SET (VOIDmode, cc_reg,
- gen_rtx_COMPARE (ccmode, x, y)));
-
- return cc_reg;
-}
-
-/* For the i960, REG is cost 1, REG+immed CONST is cost 2, REG+REG is cost 2,
- REG+nonimmed CONST is cost 4. REG+SYMBOL_REF, SYMBOL_REF, and similar
- are 4. Indexed addresses are cost 6. */
-
-/* ??? Try using just RTX_COST, i.e. not defining ADDRESS_COST. */
-
-static int
-i960_address_cost (x)
- rtx x;
-{
- if (GET_CODE (x) == REG)
- return 1;
-
- /* This is a MEMA operand -- it's free. */
- if (GET_CODE (x) == CONST_INT
- && INTVAL (x) >= 0
- && INTVAL (x) < 4096)
- return 0;
-
- if (GET_CODE (x) == PLUS)
- {
- rtx base = XEXP (x, 0);
- rtx offset = XEXP (x, 1);
-
- if (GET_CODE (base) == SUBREG)
- base = SUBREG_REG (base);
- if (GET_CODE (offset) == SUBREG)
- offset = SUBREG_REG (offset);
-
- if (GET_CODE (base) == REG)
- {
- if (GET_CODE (offset) == REG)
- return 2;
- if (GET_CODE (offset) == CONST_INT)
- {
- if ((unsigned)INTVAL (offset) < 2047)
- return 2;
- return 4;
- }
- if (CONSTANT_P (offset))
- return 4;
- }
- if (GET_CODE (base) == PLUS || GET_CODE (base) == MULT)
- return 6;
-
- /* This is an invalid address. The return value doesn't matter, but
- for convenience we make this more expensive than anything else. */
- return 12;
- }
- if (GET_CODE (x) == MULT)
- return 6;
-
- /* Symbol_refs and other unrecognized addresses are cost 4. */
- return 4;
-}
-\f
-/* Emit insns to move operands[1] into operands[0].
-
- Return 1 if we have written out everything that needs to be done to
- do the move. Otherwise, return 0 and the caller will emit the move
- normally. */
-
-int
-emit_move_sequence (operands, mode)
- rtx *operands;
- enum machine_mode mode;
-{
- /* We can only store registers to memory. */
-
- if (GET_CODE (operands[0]) == MEM && GET_CODE (operands[1]) != REG
- && (operands[1] != const0_rtx || current_function_args_size
- || current_function_stdarg
- || rtx_equal_function_value_matters))
- /* Here we use the same test as movsi+1 pattern -- see i960.md. */
- operands[1] = force_reg (mode, operands[1]);
-
- /* Storing multi-word values in unaligned hard registers to memory may
- require a scratch since we have to store them a register at a time and
- adding 4 to the memory address may not yield a valid insn. */
- /* ??? We don't always need the scratch, but that would complicate things.
- Maybe later. */
- /* ??? We must also handle stores to pseudos here, because the pseudo may be
- replaced with a MEM later. This would be cleaner if we didn't have
- a separate pattern for unaligned DImode/TImode stores. */
- if (GET_MODE_SIZE (mode) > UNITS_PER_WORD
- && (GET_CODE (operands[0]) == MEM
- || (GET_CODE (operands[0]) == REG
- && REGNO (operands[0]) >= FIRST_PSEUDO_REGISTER))
- && GET_CODE (operands[1]) == REG
- && REGNO (operands[1]) < FIRST_PSEUDO_REGISTER
- && ! HARD_REGNO_MODE_OK (REGNO (operands[1]), mode))
- {
- emit_insn (gen_rtx_PARALLEL
- (VOIDmode,
- gen_rtvec (2,
- gen_rtx_SET (VOIDmode, operands[0], operands[1]),
- gen_rtx_CLOBBER (VOIDmode,
- gen_rtx_SCRATCH (Pmode)))));
- return 1;
- }
-
- return 0;
-}
-
-/* Output assembler to move a double word value. */
-
-const char *
-i960_output_move_double (dst, src)
- rtx dst, src;
-{
- rtx operands[5];
-
- if (GET_CODE (dst) == REG
- && GET_CODE (src) == REG)
- {
- if ((REGNO (src) & 1)
- || (REGNO (dst) & 1))
- {
- /* We normally copy the low-numbered register first. However, if
- the second source register is the same as the first destination
- register, we must copy in the opposite order. */
- if (REGNO (src) + 1 == REGNO (dst))
- return "mov %D1,%D0\n\tmov %1,%0";
- else
- return "mov %1,%0\n\tmov %D1,%D0";
- }
- else
- return "movl %1,%0";
- }
- else if (GET_CODE (dst) == REG
- && GET_CODE (src) == CONST_INT
- && CONST_OK_FOR_LETTER_P (INTVAL (src), 'I'))
- {
- if (REGNO (dst) & 1)
- return "mov %1,%0\n\tmov 0,%D0";
- else
- return "movl %1,%0";
- }
- else if (GET_CODE (dst) == REG
- && GET_CODE (src) == MEM)
- {
- if (REGNO (dst) & 1)
- {
- /* One can optimize a few cases here, but you have to be
- careful of clobbering registers used in the address and
- edge conditions. */
- operands[0] = dst;
- operands[1] = src;
- operands[2] = gen_rtx_REG (Pmode, REGNO (dst) + 1);
- operands[3] = gen_rtx_MEM (word_mode, operands[2]);
- operands[4] = adjust_address (operands[3], word_mode,
- UNITS_PER_WORD);
- output_asm_insn
- ("lda %1,%2\n\tld %3,%0\n\tld %4,%D0", operands);
- return "";
- }
- else
- return "ldl %1,%0";
- }
- else if (GET_CODE (dst) == MEM
- && GET_CODE (src) == REG)
- {
- if (REGNO (src) & 1)
- {
- operands[0] = dst;
- operands[1] = adjust_address (dst, word_mode, UNITS_PER_WORD);
- if (! memory_address_p (word_mode, XEXP (operands[1], 0)))
- abort ();
- operands[2] = src;
- output_asm_insn ("st %2,%0\n\tst %D2,%1", operands);
- return "";
- }
- return "stl %1,%0";
- }
- else
- abort ();
-}
-
-/* Output assembler to move a double word zero. */
-
-const char *
-i960_output_move_double_zero (dst)
- rtx dst;
-{
- rtx operands[2];
-
- operands[0] = dst;
- {
- operands[1] = adjust_address (dst, word_mode, 4);
- output_asm_insn ("st g14,%0\n\tst g14,%1", operands);
- }
- return "";
-}
-
-/* Output assembler to move a quad word value. */
-
-const char *
-i960_output_move_quad (dst, src)
- rtx dst, src;
-{
- rtx operands[7];
-
- if (GET_CODE (dst) == REG
- && GET_CODE (src) == REG)
- {
- if ((REGNO (src) & 3)
- || (REGNO (dst) & 3))
- {
- /* We normally copy starting with the low numbered register.
- However, if there is an overlap such that the first dest reg
- is <= the last source reg but not < the first source reg, we
- must copy in the opposite order. */
- if (REGNO (dst) <= REGNO (src) + 3
- && REGNO (dst) >= REGNO (src))
- return "mov %F1,%F0\n\tmov %E1,%E0\n\tmov %D1,%D0\n\tmov %1,%0";
- else
- return "mov %1,%0\n\tmov %D1,%D0\n\tmov %E1,%E0\n\tmov %F1,%F0";
- }
- else
- return "movq %1,%0";
- }
- else if (GET_CODE (dst) == REG
- && GET_CODE (src) == CONST_INT
- && CONST_OK_FOR_LETTER_P (INTVAL (src), 'I'))
- {
- if (REGNO (dst) & 3)
- return "mov %1,%0\n\tmov 0,%D0\n\tmov 0,%E0\n\tmov 0,%F0";
- else
- return "movq %1,%0";
- }
- else if (GET_CODE (dst) == REG
- && GET_CODE (src) == MEM)
- {
- if (REGNO (dst) & 3)
- {
- /* One can optimize a few cases here, but you have to be
- careful of clobbering registers used in the address and
- edge conditions. */
- operands[0] = dst;
- operands[1] = src;
- operands[2] = gen_rtx_REG (Pmode, REGNO (dst) + 3);
- operands[3] = gen_rtx_MEM (word_mode, operands[2]);
- operands[4]
- = adjust_address (operands[3], word_mode, UNITS_PER_WORD);
- operands[5]
- = adjust_address (operands[4], word_mode, UNITS_PER_WORD);
- operands[6]
- = adjust_address (operands[5], word_mode, UNITS_PER_WORD);
- output_asm_insn ("lda %1,%2\n\tld %3,%0\n\tld %4,%D0\n\tld %5,%E0\n\tld %6,%F0", operands);
- return "";
- }
- else
- return "ldq %1,%0";
- }
- else if (GET_CODE (dst) == MEM
- && GET_CODE (src) == REG)
- {
- if (REGNO (src) & 3)
- {
- operands[0] = dst;
- operands[1] = adjust_address (dst, word_mode, UNITS_PER_WORD);
- operands[2] = adjust_address (dst, word_mode, 2 * UNITS_PER_WORD);
- operands[3] = adjust_address (dst, word_mode, 3 * UNITS_PER_WORD);
- if (! memory_address_p (word_mode, XEXP (operands[3], 0)))
- abort ();
- operands[4] = src;
- output_asm_insn ("st %4,%0\n\tst %D4,%1\n\tst %E4,%2\n\tst %F4,%3", operands);
- return "";
- }
- return "stq %1,%0";
- }
- else
- abort ();
-}
-
-/* Output assembler to move a quad word zero. */
-
-const char *
-i960_output_move_quad_zero (dst)
- rtx dst;
-{
- rtx operands[4];
-
- operands[0] = dst;
- {
- operands[1] = adjust_address (dst, word_mode, 4);
- operands[2] = adjust_address (dst, word_mode, 8);
- operands[3] = adjust_address (dst, word_mode, 12);
- output_asm_insn ("st g14,%0\n\tst g14,%1\n\tst g14,%2\n\tst g14,%3", operands);
- }
- return "";
-}
-
-\f
-/* Emit insns to load a constant to non-floating point registers.
- Uses several strategies to try to use as few insns as possible. */
-
-const char *
-i960_output_ldconst (dst, src)
- register rtx dst, src;
-{
- register int rsrc1;
- register unsigned rsrc2;
- enum machine_mode mode = GET_MODE (dst);
- rtx operands[4];
-
- operands[0] = operands[2] = dst;
- operands[1] = operands[3] = src;
-
- /* Anything that isn't a compile time constant, such as a SYMBOL_REF,
- must be a ldconst insn. */
-
- if (GET_CODE (src) != CONST_INT && GET_CODE (src) != CONST_DOUBLE)
- {
- output_asm_insn ("ldconst %1,%0", operands);
- return "";
- }
- else if (mode == TFmode)
- {
- REAL_VALUE_TYPE d;
- long value_long[3];
- int i;
-
- if (fp_literal_zero (src, TFmode))
- return "movt 0,%0";
-
- REAL_VALUE_FROM_CONST_DOUBLE (d, src);
- REAL_VALUE_TO_TARGET_LONG_DOUBLE (d, value_long);
-
- output_asm_insn ("# ldconst %1,%0",operands);
-
- for (i = 0; i < 3; i++)
- {
- operands[0] = gen_rtx_REG (SImode, REGNO (dst) + i);
- operands[1] = GEN_INT (value_long[i]);
- output_asm_insn (i960_output_ldconst (operands[0], operands[1]),
- operands);
- }
-
- return "";
- }
- else if (mode == DFmode)
- {
- rtx first, second;
-
- if (fp_literal_zero (src, DFmode))
- return "movl 0,%0";
-
- split_double (src, &first, &second);
-
- output_asm_insn ("# ldconst %1,%0",operands);
-
- operands[0] = gen_rtx_REG (SImode, REGNO (dst));
- operands[1] = first;
- output_asm_insn (i960_output_ldconst (operands[0], operands[1]),
- operands);
- operands[0] = gen_rtx_REG (SImode, REGNO (dst) + 1);
- operands[1] = second;
- output_asm_insn (i960_output_ldconst (operands[0], operands[1]),
- operands);
- return "";
- }
- else if (mode == SFmode)
- {
- REAL_VALUE_TYPE d;
- long value;
-
- REAL_VALUE_FROM_CONST_DOUBLE (d, src);
- REAL_VALUE_TO_TARGET_SINGLE (d, value);
-
- output_asm_insn ("# ldconst %1,%0",operands);
- operands[0] = gen_rtx_REG (SImode, REGNO (dst));
- operands[1] = GEN_INT (value);
- output_asm_insn (i960_output_ldconst (operands[0], operands[1]),
- operands);
- return "";
- }
- else if (mode == TImode)
- {
- /* ??? This is currently not handled at all. */
- abort ();
-
- /* Note: lowest order word goes in lowest numbered reg. */
- rsrc1 = INTVAL (src);
- if (rsrc1 >= 0 && rsrc1 < 32)
- return "movq %1,%0";
- else
- output_asm_insn ("movq\t0,%0\t# ldconstq %1,%0",operands);
- /* Go pick up the low-order word. */
- }
- else if (mode == DImode)
- {
- rtx upperhalf, lowerhalf, xoperands[2];
-
- if (GET_CODE (src) == CONST_DOUBLE || GET_CODE (src) == CONST_INT)
- split_double (src, &lowerhalf, &upperhalf);
-
- else
- abort ();
-
- /* Note: lowest order word goes in lowest numbered reg. */
- /* Numbers from 0 to 31 can be handled with a single insn. */
- rsrc1 = INTVAL (lowerhalf);
- if (upperhalf == const0_rtx && rsrc1 >= 0 && rsrc1 < 32)
- return "movl %1,%0";
-
- /* Output the upper half with a recursive call. */
- xoperands[0] = gen_rtx_REG (SImode, REGNO (dst) + 1);
- xoperands[1] = upperhalf;
- output_asm_insn (i960_output_ldconst (xoperands[0], xoperands[1]),
- xoperands);
- /* The lower word is emitted as normally. */
- }
- else
- {
- rsrc1 = INTVAL (src);
- if (mode == QImode)
- {
- if (rsrc1 > 0xff)
- rsrc1 &= 0xff;
- }
- else if (mode == HImode)
- {
- if (rsrc1 > 0xffff)
- rsrc1 &= 0xffff;
- }
- }
-
- if (rsrc1 >= 0)
- {
- /* ldconst 0..31,X -> mov 0..31,X */
- if (rsrc1 < 32)
- {
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- return "lda %1,%0";
- return "mov %1,%0";
- }
-
- /* ldconst 32..63,X -> add 31,nn,X */
- if (rsrc1 < 63)
- {
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- return "lda %1,%0";
- operands[1] = GEN_INT (rsrc1 - 31);
- output_asm_insn ("addo\t31,%1,%0\t# ldconst %3,%0", operands);
- return "";
- }
- }
- else if (rsrc1 < 0)
- {
- /* ldconst -1..-31 -> sub 0,0..31,X */
- if (rsrc1 >= -31)
- {
- /* return 'sub -(%1),0,%0' */
- operands[1] = GEN_INT (- rsrc1);
- output_asm_insn ("subo\t%1,0,%0\t# ldconst %3,%0", operands);
- return "";
- }
-
- /* ldconst -32 -> not 31,X */
- if (rsrc1 == -32)
- {
- operands[1] = GEN_INT (~rsrc1);
- output_asm_insn ("not\t%1,%0 # ldconst %3,%0", operands);
- return "";
- }
- }
-
- /* If const is a single bit. */
- if (bitpos (rsrc1) >= 0)
- {
- operands[1] = GEN_INT (bitpos (rsrc1));
- output_asm_insn ("setbit\t%1,0,%0\t# ldconst %3,%0", operands);
- return "";
- }
-
- /* If const is a bit string of less than 6 bits (1..31 shifted). */
- if (is_mask (rsrc1))
- {
- int s, e;
-
- if (bitstr (rsrc1, &s, &e) < 6)
- {
- rsrc2 = ((unsigned int) rsrc1) >> s;
- operands[1] = GEN_INT (rsrc2);
- operands[2] = GEN_INT (s);
- output_asm_insn ("shlo\t%2,%1,%0\t# ldconst %3,%0", operands);
- return "";
- }
- }
-
- /* Unimplemented cases:
- const is in range 0..31 but rotated around end of word:
- ror 31,3,g0 -> ldconst 0xe0000003,g0
-
- and any 2 instruction cases that might be worthwhile */
-
- output_asm_insn ("ldconst %1,%0", operands);
- return "";
-}
-
-/* Determine if there is an opportunity for a bypass optimization.
- Bypass succeeds on the 960K* if the destination of the previous
- instruction is the second operand of the current instruction.
- Bypass always succeeds on the C*.
-
- Return 1 if the pattern should interchange the operands.
-
- CMPBR_FLAG is true if this is for a compare-and-branch insn.
- OP1 and OP2 are the two source operands of a 3 operand insn. */
-
-int
-i960_bypass (insn, op1, op2, cmpbr_flag)
- register rtx insn, op1, op2;
- int cmpbr_flag;
-{
- register rtx prev_insn, prev_dest;
-
- if (TARGET_C_SERIES)
- return 0;
-
- /* Can't do this if op1 isn't a register. */
- if (! REG_P (op1))
- return 0;
-
- /* Can't do this for a compare-and-branch if both ops aren't regs. */
- if (cmpbr_flag && ! REG_P (op2))
- return 0;
-
- prev_insn = prev_real_insn (insn);
-
- if (prev_insn && GET_CODE (prev_insn) == INSN
- && GET_CODE (PATTERN (prev_insn)) == SET)
- {
- prev_dest = SET_DEST (PATTERN (prev_insn));
- if ((GET_CODE (prev_dest) == REG && REGNO (prev_dest) == REGNO (op1))
- || (GET_CODE (prev_dest) == SUBREG
- && GET_CODE (SUBREG_REG (prev_dest)) == REG
- && REGNO (SUBREG_REG (prev_dest)) == REGNO (op1)))
- return 1;
- }
- return 0;
-}
-\f
-/* Output the code which declares the function name. This also handles
- leaf routines, which have special requirements, and initializes some
- global variables. */
-
-void
-i960_function_name_declare (file, name, fndecl)
- FILE *file;
- const char *name;
- tree fndecl;
-{
- register int i, j;
- int leaf_proc_ok;
- rtx insn;
-
- /* Increment global return label. */
-
- ret_label++;
-
- /* Compute whether tail calls and leaf routine optimizations can be performed
- for this function. */
-
- if (TARGET_TAILCALL)
- tail_call_ok = 1;
- else
- tail_call_ok = 0;
-
- if (TARGET_LEAFPROC)
- leaf_proc_ok = 1;
- else
- leaf_proc_ok = 0;
-
- /* Even if nobody uses extra parms, can't have leafproc or tail calls if
- argblock, because argblock uses g14 implicitly. */
-
- if (current_function_args_size != 0 || VARARGS_STDARG_FUNCTION (fndecl))
- {
- tail_call_ok = 0;
- leaf_proc_ok = 0;
- }
-
- /* See if caller passes in an address to return value. */
-
- if (aggregate_value_p (DECL_RESULT (fndecl), fndecl))
- {
- tail_call_ok = 0;
- leaf_proc_ok = 0;
- }
-
- /* Can not use tail calls or make this a leaf routine if there is a non
- zero frame size. */
-
- if (get_frame_size () != 0)
- leaf_proc_ok = 0;
-
- /* I don't understand this condition, and do not think that it is correct.
- Apparently this is just checking whether the frame pointer is used, and
- we can't trust regs_ever_live[fp] since it is (almost?) always set. */
-
- if (tail_call_ok)
- for (insn = get_insns (); insn; insn = NEXT_INSN (insn))
- if (GET_CODE (insn) == INSN
- && reg_mentioned_p (frame_pointer_rtx, insn))
- {
- tail_call_ok = 0;
- break;
- }
-
- /* Check for CALL insns. Can not be a leaf routine if there are any. */
-
- if (leaf_proc_ok)
- for (insn = get_insns (); insn; insn = NEXT_INSN (insn))
- if (GET_CODE (insn) == CALL_INSN)
- {
- leaf_proc_ok = 0;
- break;
- }
-
- /* Can not be a leaf routine if any non-call clobbered registers are
- used in this function. */
-
- if (leaf_proc_ok)
- for (i = 0, j = 0; i < FIRST_PSEUDO_REGISTER; i++)
- if (regs_ever_live[i]
- && ((! call_used_regs[i]) || (i > 7 && i < 12)))
- {
- /* Global registers. */
- if (i < 16 && i > 7 && i != 13)
- leaf_proc_ok = 0;
- /* Local registers. */
- else if (i < 32)
- leaf_proc_ok = 0;
- }
-
- /* Now choose a leaf return register, if we can find one, and if it is
- OK for this to be a leaf routine. */
-
- i960_leaf_ret_reg = -1;
-
- if (optimize && leaf_proc_ok)
- {
- for (i960_leaf_ret_reg = -1, i = 0; i < 8; i++)
- if (regs_ever_live[i] == 0)
- {
- i960_leaf_ret_reg = i;
- regs_ever_live[i] = 1;
- break;
- }
- }
-
- /* Do this after choosing the leaf return register, so it will be listed
- if one was chosen. */
-
- fprintf (file, "\t# Function '%s'\n", (name[0] == '*' ? &name[1] : name));
- fprintf (file, "\t# Registers used: ");
-
- for (i = 0, j = 0; i < FIRST_PSEUDO_REGISTER; i++)
- {
- if (regs_ever_live[i])
- {
- fprintf (file, "%s%s ", reg_names[i], call_used_regs[i] ? "" : "*");
-
- if (i > 15 && j == 0)
- {
- fprintf (file,"\n\t#\t\t ");
- j++;
- }
- }
- }
-
- fprintf (file, "\n");
-
- if (i960_leaf_ret_reg >= 0)
- {
- /* Make it a leaf procedure. */
-
- if (TREE_PUBLIC (fndecl))
- fprintf (file,"\t.globl\t%s.lf\n", (name[0] == '*' ? &name[1] : name));
-
- fprintf (file, "\t.leafproc\t");
- assemble_name (file, name);
- fprintf (file, ",%s.lf\n", (name[0] == '*' ? &name[1] : name));
- ASM_OUTPUT_LABEL (file, name);
- fprintf (file, "\tlda Li960R%d,g14\n", ret_label);
- fprintf (file, "%s.lf:\n", (name[0] == '*' ? &name[1] : name));
- fprintf (file, "\tmov g14,g%d\n", i960_leaf_ret_reg);
-
- if (TARGET_C_SERIES)
- {
- fprintf (file, "\tlda 0,g14\n");
- i960_last_insn_type = I_TYPE_MEM;
- }
- else
- {
- fprintf (file, "\tmov 0,g14\n");
- i960_last_insn_type = I_TYPE_REG;
- }
- }
- else
- {
- ASM_OUTPUT_LABEL (file, name);
- i960_last_insn_type = I_TYPE_CTRL;
- }
-}
-\f
-/* Compute and return the frame size. */
-
-int
-compute_frame_size (size)
- int size;
-{
- int actual_fsize;
- int outgoing_args_size = current_function_outgoing_args_size;
-
- /* The STARTING_FRAME_OFFSET is totally hidden to us as far
- as size is concerned. */
- actual_fsize = (size + 15) & -16;
- actual_fsize += (outgoing_args_size + 15) & -16;
-
- return actual_fsize;
-}
-
-/* Here register group is range of registers which can be moved by
- one i960 instruction. */
-
-struct reg_group
-{
- char start_reg;
- char length;
-};
-
-static int i960_form_reg_groups (int, int, int *, int, struct reg_group *);
-static int i960_reg_group_compare (const void *, const void *);
-static int i960_split_reg_group (struct reg_group *, int, int);
-static void i960_arg_size_and_align (enum machine_mode, tree, int *, int *);
-
-/* The following functions forms the biggest as possible register
- groups with registers in STATE. REGS contain states of the
- registers in range [start, finish_reg). The function returns the
- number of groups formed. */
-static int
-i960_form_reg_groups (start_reg, finish_reg, regs, state, reg_groups)
- int start_reg;
- int finish_reg;
- int *regs;
- int state;
- struct reg_group *reg_groups;
-{
- int i;
- int nw = 0;
-
- for (i = start_reg; i < finish_reg; )
- {
- if (regs [i] != state)
- {
- i++;
- continue;
- }
- else if (i % 2 != 0 || regs [i + 1] != state)
- reg_groups [nw].length = 1;
- else if (i % 4 != 0 || regs [i + 2] != state)
- reg_groups [nw].length = 2;
- else if (regs [i + 3] != state)
- reg_groups [nw].length = 3;
- else
- reg_groups [nw].length = 4;
- reg_groups [nw].start_reg = i;
- i += reg_groups [nw].length;
- nw++;
- }
- return nw;
-}
-
-/* We sort register winodws in descending order by length. */
-static int
-i960_reg_group_compare (group1, group2)
- const void *group1;
- const void *group2;
-{
- const struct reg_group *w1 = group1;
- const struct reg_group *w2 = group2;
-
- if (w1->length > w2->length)
- return -1;
- else if (w1->length < w2->length)
- return 1;
- else
- return 0;
-}
-
-/* Split the first register group in REG_GROUPS on subgroups one of
- which will contain SUBGROUP_LENGTH registers. The function
- returns new number of winodws. */
-static int
-i960_split_reg_group (reg_groups, nw, subgroup_length)
- struct reg_group *reg_groups;
- int nw;
- int subgroup_length;
-{
- if (subgroup_length < reg_groups->length - subgroup_length)
- /* This guarantees correct alignments of the two subgroups for
- i960 (see spliting for the group length 2, 3, 4). More
- generalized algorithm would require splitting the group more
- two subgroups. */
- subgroup_length = reg_groups->length - subgroup_length;
- /* More generalized algorithm would require to try merging
- subgroups here. But in case i960 it always results in failure
- because of register group alignment. */
- reg_groups[nw].length = reg_groups->length - subgroup_length;
- reg_groups[nw].start_reg = reg_groups->start_reg + subgroup_length;
- nw++;
- reg_groups->length = subgroup_length;
- qsort (reg_groups, nw, sizeof (struct reg_group), i960_reg_group_compare);
- return nw;
-}
-
-/* Output code for the function prologue. */
-
-static void
-i960_output_function_prologue (file, size)
- FILE *file;
- HOST_WIDE_INT size;
-{
- register int i, j, nr;
- int n_saved_regs = 0;
- int n_remaining_saved_regs;
- HOST_WIDE_INT lvar_size;
- HOST_WIDE_INT actual_fsize, offset;
- int gnw, lnw;
- struct reg_group *g, *l;
- char tmpstr[1000];
- /* -1 if reg must be saved on proc entry, 0 if available, 1 if saved
- somewhere. */
- int regs[FIRST_PSEUDO_REGISTER];
- /* All global registers (which must be saved) divided by groups. */
- struct reg_group global_reg_groups [16];
- /* All local registers (which are available) divided by groups. */
- struct reg_group local_reg_groups [16];
-
-
- for (i = 0; i < FIRST_PSEUDO_REGISTER; i++)
- if (regs_ever_live[i]
- && ((! call_used_regs[i]) || (i > 7 && i < 12))
- /* No need to save the static chain pointer. */
- && ! (i == STATIC_CHAIN_REGNUM && current_function_needs_context))
- {
- regs[i] = -1;
- /* Count global registers that need saving. */
- if (i < 16)
- n_saved_regs++;
- }
- else
- regs[i] = 0;
-
- n_remaining_saved_regs = n_saved_regs;
-
- epilogue_string[0] = '\0';
-
- if (current_function_profile)
- {
- /* When profiling, we may use registers 20 to 27 to save arguments, so
- they can't be used here for saving globals. J is the number of
- argument registers the mcount call will save. */
- for (j = 7; j >= 0 && ! regs_ever_live[j]; j--)
- ;
-
- for (i = 20; i <= j + 20; i++)
- regs[i] = -1;
- }
-
- gnw = i960_form_reg_groups (0, 16, regs, -1, global_reg_groups);
- lnw = i960_form_reg_groups (19, 32, regs, 0, local_reg_groups);
- qsort (global_reg_groups, gnw, sizeof (struct reg_group),
- i960_reg_group_compare);
- qsort (local_reg_groups, lnw, sizeof (struct reg_group),
- i960_reg_group_compare);
- for (g = global_reg_groups, l = local_reg_groups; lnw != 0 && gnw != 0;)
- {
- if (g->length == l->length)
- {
- fprintf (file, "\tmov%s %s,%s\n",
- ((g->length == 4) ? "q" :
- (g->length == 3) ? "t" :
- (g->length == 2) ? "l" : ""),
- reg_names[(unsigned char) g->start_reg],
- reg_names[(unsigned char) l->start_reg]);
- sprintf (tmpstr, "\tmov%s %s,%s\n",
- ((g->length == 4) ? "q" :
- (g->length == 3) ? "t" :
- (g->length == 2) ? "l" : ""),
- reg_names[(unsigned char) l->start_reg],
- reg_names[(unsigned char) g->start_reg]);
- strcat (epilogue_string, tmpstr);
- n_remaining_saved_regs -= g->length;
- for (i = 0; i < g->length; i++)
- {
- regs [i + g->start_reg] = 1;
- regs [i + l->start_reg] = -1;
- regs_ever_live [i + l->start_reg] = 1;
- }
- g++;
- l++;
- gnw--;
- lnw--;
- }
- else if (g->length > l->length)
- gnw = i960_split_reg_group (g, gnw, l->length);
- else
- lnw = i960_split_reg_group (l, lnw, g->length);
- }
-
- actual_fsize = compute_frame_size (size) + 4 * n_remaining_saved_regs;
-#if 0
- /* ??? The 1.2.1 compiler does this also. This is meant to round the frame
- size up to the nearest multiple of 16. I don't know whether this is
- necessary, or even desirable.
-
- The frame pointer must be aligned, but the call instruction takes care of
- that. If we leave the stack pointer unaligned, we may save a little on
- dynamic stack allocation. And we don't lose, at least according to the
- i960CA manual. */
- actual_fsize = (actual_fsize + 15) & ~0xF;
-#endif
-
- /* Check stack limit if necessary. */
- if (current_function_limit_stack)
- {
- rtx min_stack = stack_limit_rtx;
- if (actual_fsize != 0)
- min_stack = plus_constant (stack_limit_rtx, -actual_fsize);
-
- /* Now, emulate a little bit of reload. We want to turn 'min_stack'
- into an arith_operand. Use register 20 as the temporary. */
- if (legitimate_address_p (Pmode, min_stack, 1)
- && !arith_operand (min_stack, Pmode))
- {
- rtx tmp = gen_rtx_MEM (Pmode, min_stack);
- fputs ("\tlda\t", file);
- i960_print_operand (file, tmp, 0);
- fputs (",r4\n", file);
- min_stack = gen_rtx_REG (Pmode, 20);
- }
- if (arith_operand (min_stack, Pmode))
- {
- fputs ("\tcmpo\tsp,", file);
- i960_print_operand (file, min_stack, 0);
- fputs ("\n\tfaultge.f\n", file);
- }
- else
- warning ("stack limit expression is not supported");
- }
-
- /* Allocate space for register save and locals. */
- if (actual_fsize > 0)
- {
- if (actual_fsize < 32)
- fprintf (file, "\taddo " HOST_WIDE_INT_PRINT_DEC ",sp,sp\n",
- actual_fsize);
- else
- fprintf (file, "\tlda\t" HOST_WIDE_INT_PRINT_DEC "(sp),sp\n",
- actual_fsize);
- }
-
- /* Take hardware register save area created by the call instruction
- into account, but store them before the argument block area. */
- lvar_size = actual_fsize - compute_frame_size (0) - n_remaining_saved_regs * 4;
- offset = STARTING_FRAME_OFFSET + lvar_size;
- /* Save registers on stack if needed. */
- /* ??? Is it worth to use the same algorithm as one for saving
- global registers in local registers? */
- for (i = 0, j = n_remaining_saved_regs; j > 0 && i < 16; i++)
- {
- if (regs[i] != -1)
- continue;
-
- nr = 1;
-
- if (i <= 14 && i % 2 == 0 && regs[i+1] == -1 && offset % 2 == 0)
- nr = 2;
-
- if (nr == 2 && i <= 12 && i % 4 == 0 && regs[i+2] == -1
- && offset % 4 == 0)
- nr = 3;
-
- if (nr == 3 && regs[i+3] == -1)
- nr = 4;
-
- fprintf (file,"\tst%s %s," HOST_WIDE_INT_PRINT_DEC "(fp)\n",
- ((nr == 4) ? "q" :
- (nr == 3) ? "t" :
- (nr == 2) ? "l" : ""),
- reg_names[i], offset);
- sprintf (tmpstr,"\tld%s " HOST_WIDE_INT_PRINT_DEC "(fp),%s\n",
- ((nr == 4) ? "q" :
- (nr == 3) ? "t" :
- (nr == 2) ? "l" : ""),
- offset, reg_names[i]);
- strcat (epilogue_string, tmpstr);
- i += nr-1;
- j -= nr;
- offset += nr * 4;
- }
-
- if (actual_fsize == 0)
- return;
-
- fprintf (file, "\t#Prologue stats:\n");
- fprintf (file, "\t# Total Frame Size: " HOST_WIDE_INT_PRINT_DEC " bytes\n",
- actual_fsize);
-
- if (lvar_size)
- fprintf (file, "\t# Local Variable Size: " HOST_WIDE_INT_PRINT_DEC
- " bytes\n", lvar_size);
- if (n_saved_regs)
- fprintf (file, "\t# Register Save Size: %d regs, %d bytes\n",
- n_saved_regs, n_saved_regs * 4);
- fprintf (file, "\t#End Prologue#\n");
-}
-
-/* Output code for the function profiler. */
-
-void
-output_function_profiler (file, labelno)
- FILE *file;
- int labelno;
-{
- /* The last used parameter register. */
- int last_parm_reg;
- int i, j, increment;
- int varargs_stdarg_function
- = VARARGS_STDARG_FUNCTION (current_function_decl);
-
- /* Figure out the last used parameter register. The proper thing to do
- is to walk incoming args of the function. A function might have live
- parameter registers even if it has no incoming args. Note that we
- don't have to save parameter registers g8 to g11 because they are
- call preserved. */
-
- /* See also output_function_prologue, which tries to use local registers
- for preserved call-saved global registers. */
-
- for (last_parm_reg = 7;
- last_parm_reg >= 0 && ! regs_ever_live[last_parm_reg];
- last_parm_reg--)
- ;
-
- /* Save parameter registers in regs r4 (20) to r11 (27). */
-
- for (i = 0, j = 4; i <= last_parm_reg; i += increment, j += increment)
- {
- if (i % 4 == 0 && (last_parm_reg - i) >= 3)
- increment = 4;
- else if (i % 4 == 0 && (last_parm_reg - i) >= 2)
- increment = 3;
- else if (i % 2 == 0 && (last_parm_reg - i) >= 1)
- increment = 2;
- else
- increment = 1;
-
- fprintf (file, "\tmov%s g%d,r%d\n",
- (increment == 4 ? "q" : increment == 3 ? "t"
- : increment == 2 ? "l": ""), i, j);
- }
-
- /* If this function uses the arg pointer, then save it in r3 and then
- set it to zero. */
-
- if (current_function_args_size != 0 || varargs_stdarg_function)
- fprintf (file, "\tmov g14,r3\n\tmov 0,g14\n");
-
- /* Load location address into g0 and call mcount. */
-
- fprintf (file, "\tlda\tLP%d,g0\n\tcallx\tmcount\n", labelno);
-
- /* If this function uses the arg pointer, restore it. */
-
- if (current_function_args_size != 0 || varargs_stdarg_function)
- fprintf (file, "\tmov r3,g14\n");
-
- /* Restore parameter registers. */
-
- for (i = 0, j = 4; i <= last_parm_reg; i += increment, j += increment)
- {
- if (i % 4 == 0 && (last_parm_reg - i) >= 3)
- increment = 4;
- else if (i % 4 == 0 && (last_parm_reg - i) >= 2)
- increment = 3;
- else if (i % 2 == 0 && (last_parm_reg - i) >= 1)
- increment = 2;
- else
- increment = 1;
-
- fprintf (file, "\tmov%s r%d,g%d\n",
- (increment == 4 ? "q" : increment == 3 ? "t"
- : increment == 2 ? "l": ""), j, i);
- }
-}
-
-/* Output code for the function epilogue. */
-
-static void
-i960_output_function_epilogue (file, size)
- FILE *file;
- HOST_WIDE_INT size ATTRIBUTE_UNUSED;
-{
- if (i960_leaf_ret_reg >= 0)
- {
- fprintf (file, "Li960R%d: ret\n", ret_label);
- return;
- }
-
- if (*epilogue_string == 0)
- {
- register rtx tmp;
-
- /* Emit a return insn, but only if control can fall through to here. */
-
- tmp = get_last_insn ();
- while (tmp)
- {
- if (GET_CODE (tmp) == BARRIER)
- return;
- if (GET_CODE (tmp) == CODE_LABEL)
- break;
- if (GET_CODE (tmp) == JUMP_INSN)
- {
- if (GET_CODE (PATTERN (tmp)) == RETURN)
- return;
- break;
- }
- if (GET_CODE (tmp) == NOTE)
- {
- tmp = PREV_INSN (tmp);
- continue;
- }
- break;
- }
- fprintf (file, "Li960R%d: ret\n", ret_label);
- return;
- }
-
- fprintf (file, "Li960R%d:\n", ret_label);
-
- fprintf (file, "\t#EPILOGUE#\n");
-
- /* Output the string created by the prologue which will restore all
- registers saved by the prologue. */
-
- if (epilogue_string[0] != '\0')
- fprintf (file, "%s", epilogue_string);
-
- /* Must clear g14 on return if this function set it.
- Only varargs/stdarg functions modify g14. */
-
- if (VARARGS_STDARG_FUNCTION (current_function_decl))
- fprintf (file, "\tmov 0,g14\n");
-
- fprintf (file, "\tret\n");
- fprintf (file, "\t#End Epilogue#\n");
-}
-
-/* Output code for a call insn. */
-
-const char *
-i960_output_call_insn (target, argsize_rtx, arg_pointer, insn)
- register rtx target, argsize_rtx, arg_pointer, insn;
-{
- int argsize = INTVAL (argsize_rtx);
- rtx nexti = next_real_insn (insn);
- rtx operands[2];
- int varargs_stdarg_function
- = VARARGS_STDARG_FUNCTION (current_function_decl);
-
- operands[0] = target;
- operands[1] = arg_pointer;
-
- if (current_function_args_size != 0 || varargs_stdarg_function)
- output_asm_insn ("mov g14,r3", operands);
-
- if (argsize > 48)
- output_asm_insn ("lda %a1,g14", operands);
- else if (current_function_args_size != 0 || varargs_stdarg_function)
- output_asm_insn ("mov 0,g14", operands);
-
- /* The code used to assume that calls to SYMBOL_REFs could not be more
- than 24 bits away (b vs bx, callj vs callx). This is not true. This
- feature is now implemented by relaxing in the GNU linker. It can convert
- bx to b if in range, and callx to calls/call/balx/bal as appropriate. */
-
- /* Nexti could be zero if the called routine is volatile. */
- if (optimize && (*epilogue_string == 0) && argsize == 0 && tail_call_ok
- && (nexti == 0 || GET_CODE (PATTERN (nexti)) == RETURN))
- {
- /* Delete following return insn. */
- if (nexti && no_labels_between_p (insn, nexti))
- delete_insn (nexti);
- output_asm_insn ("bx %0", operands);
- return "# notreached";
- }
-
- output_asm_insn ("callx %0", operands);
-
- /* If the caller sets g14 to the address of the argblock, then the caller
- must clear it after the return. */
-
- if (current_function_args_size != 0 || varargs_stdarg_function)
- output_asm_insn ("mov r3,g14", operands);
- else if (argsize > 48)
- output_asm_insn ("mov 0,g14", operands);
-
- return "";
-}
-
-/* Output code for a return insn. */
-
-const char *
-i960_output_ret_insn (insn)
- register rtx insn;
-{
- static char lbuf[20];
-
- if (*epilogue_string != 0)
- {
- if (! TARGET_CODE_ALIGN && next_real_insn (insn) == 0)
- return "";
-
- sprintf (lbuf, "b Li960R%d", ret_label);
- return lbuf;
- }
-
- /* Must clear g14 on return if this function set it.
- Only varargs/stdarg functions modify g14. */
-
- if (VARARGS_STDARG_FUNCTION (current_function_decl))
- output_asm_insn ("mov 0,g14", 0);
-
- if (i960_leaf_ret_reg >= 0)
- {
- sprintf (lbuf, "bx (%s)", reg_names[i960_leaf_ret_reg]);
- return lbuf;
- }
- return "ret";
-}
-\f
-/* Print the operand represented by rtx X formatted by code CODE. */
-
-void
-i960_print_operand (file, x, code)
- FILE *file;
- rtx x;
- int code;
-{
- enum rtx_code rtxcode = x ? GET_CODE (x) : NIL;
-
- if (rtxcode == REG)
- {
- switch (code)
- {
- case 'D':
- /* Second reg of a double or quad. */
- fprintf (file, "%s", reg_names[REGNO (x)+1]);
- break;
-
- case 'E':
- /* Third reg of a quad. */
- fprintf (file, "%s", reg_names[REGNO (x)+2]);
- break;
-
- case 'F':
- /* Fourth reg of a quad. */
- fprintf (file, "%s", reg_names[REGNO (x)+3]);
- break;
-
- case 0:
- fprintf (file, "%s", reg_names[REGNO (x)]);
- break;
-
- default:
- abort ();
- }
- return;
- }
- else if (rtxcode == MEM)
- {
- output_address (XEXP (x, 0));
- return;
- }
- else if (rtxcode == CONST_INT)
- {
- HOST_WIDE_INT val = INTVAL (x);
- if (code == 'C')
- val = ~val;
- if (val > 9999 || val < -999)
- fprintf (file, HOST_WIDE_INT_PRINT_HEX, val);
- else
- fprintf (file, HOST_WIDE_INT_PRINT_DEC, val);
- return;
- }
- else if (rtxcode == CONST_DOUBLE)
- {
- char dstr[30];
-
- if (x == CONST0_RTX (GET_MODE (x)))
- {
- fprintf (file, "0f0.0");
- return;
- }
- else if (x == CONST1_RTX (GET_MODE (x)))
- {
- fprintf (file, "0f1.0");
- return;
- }
-
- real_to_decimal (dstr, CONST_DOUBLE_REAL_VALUE (x), sizeof (dstr), 0, 1);
- fprintf (file, "0f%s", dstr);
- return;
- }
-
- switch(code)
- {
- case 'B':
- /* Branch or jump, depending on assembler. */
- if (TARGET_ASM_COMPAT)
- fputs ("j", file);
- else
- fputs ("b", file);
- break;
-
- case 'S':
- /* Sign of condition. */
- if ((rtxcode == EQ) || (rtxcode == NE) || (rtxcode == GTU)
- || (rtxcode == LTU) || (rtxcode == GEU) || (rtxcode == LEU))
- fputs ("o", file);
- else if ((rtxcode == GT) || (rtxcode == LT)
- || (rtxcode == GE) || (rtxcode == LE))
- fputs ("i", file);
- else
- abort();
- break;
-
- case 'I':
- /* Inverted condition. */
- rtxcode = reverse_condition (rtxcode);
- goto normal;
-
- case 'X':
- /* Inverted condition w/ reversed operands. */
- rtxcode = reverse_condition (rtxcode);
- /* Fallthrough. */
-
- case 'R':
- /* Reversed operand condition. */
- rtxcode = swap_condition (rtxcode);
- /* Fallthrough. */
-
- case 'C':
- /* Normal condition. */
- normal:
- if (rtxcode == EQ) { fputs ("e", file); return; }
- else if (rtxcode == NE) { fputs ("ne", file); return; }
- else if (rtxcode == GT) { fputs ("g", file); return; }
- else if (rtxcode == GTU) { fputs ("g", file); return; }
- else if (rtxcode == LT) { fputs ("l", file); return; }
- else if (rtxcode == LTU) { fputs ("l", file); return; }
- else if (rtxcode == GE) { fputs ("ge", file); return; }
- else if (rtxcode == GEU) { fputs ("ge", file); return; }
- else if (rtxcode == LE) { fputs ("le", file); return; }
- else if (rtxcode == LEU) { fputs ("le", file); return; }
- else abort ();
- break;
-
- case '+':
- /* For conditional branches, substitute ".t" or ".f". */
- if (TARGET_BRANCH_PREDICT)
- {
- x = find_reg_note (current_output_insn, REG_BR_PROB, 0);
- if (x)
- {
- int pred_val = INTVAL (XEXP (x, 0));
- fputs ((pred_val < REG_BR_PROB_BASE / 2 ? ".f" : ".t"), file);
- }
- }
- break;
-
- case 0:
- output_addr_const (file, x);
- break;
-
- default:
- abort ();
- }
-
- return;
-}
-\f
-/* Print a memory address as an operand to reference that memory location.
-
- This is exactly the same as legitimate_address_p, except that it the prints
- addresses instead of recognizing them. */
-
-void
-i960_print_operand_addr (file, addr)
- FILE *file;
- register rtx addr;
-{
- rtx breg, ireg;
- rtx scale, offset;
-
- ireg = 0;
- breg = 0;
- offset = 0;
- scale = const1_rtx;
-
- if (GET_CODE (addr) == REG)
- breg = addr;
- else if (CONSTANT_P (addr))
- offset = addr;
- else if (GET_CODE (addr) == PLUS)
- {
- rtx op0, op1;
-
- op0 = XEXP (addr, 0);
- op1 = XEXP (addr, 1);
-
- if (GET_CODE (op0) == REG)
- {
- breg = op0;
- if (GET_CODE (op1) == REG)
- ireg = op1;
- else if (CONSTANT_P (op1))
- offset = op1;
- else
- abort ();
- }
- else if (GET_CODE (op0) == PLUS)
- {
- if (GET_CODE (XEXP (op0, 0)) == MULT)
- {
- ireg = XEXP (XEXP (op0, 0), 0);
- scale = XEXP (XEXP (op0, 0), 1);
- if (GET_CODE (XEXP (op0, 1)) == REG)
- {
- breg = XEXP (op0, 1);
- offset = op1;
- }
- else
- abort ();
- }
- else if (GET_CODE (XEXP (op0, 0)) == REG)
- {
- breg = XEXP (op0, 0);
- if (GET_CODE (XEXP (op0, 1)) == REG)
- {
- ireg = XEXP (op0, 1);
- offset = op1;
- }
- else
- abort ();
- }
- else
- abort ();
- }
- else if (GET_CODE (op0) == MULT)
- {
- ireg = XEXP (op0, 0);
- scale = XEXP (op0, 1);
- if (GET_CODE (op1) == REG)
- breg = op1;
- else if (CONSTANT_P (op1))
- offset = op1;
- else
- abort ();
- }
- else
- abort ();
- }
- else if (GET_CODE (addr) == MULT)
- {
- ireg = XEXP (addr, 0);
- scale = XEXP (addr, 1);
- }
- else
- abort ();
-
- if (offset)
- output_addr_const (file, offset);
- if (breg)
- fprintf (file, "(%s)", reg_names[REGNO (breg)]);
- if (ireg)
- fprintf (file, "[%s*" HOST_WIDE_INT_PRINT_DEC "]",
- reg_names[REGNO (ireg)], INTVAL (scale));
-}
-\f
-/* GO_IF_LEGITIMATE_ADDRESS recognizes an RTL expression
- that is a valid memory address for an instruction.
- The MODE argument is the machine mode for the MEM expression
- that wants to use this address.
-
- On 80960, legitimate addresses are:
- base ld (g0),r0
- disp (12 or 32 bit) ld foo,r0
- base + index ld (g0)[g1*1],r0
- base + displ ld 0xf00(g0),r0
- base + index*scale + displ ld 0xf00(g0)[g1*4],r0
- index*scale + base ld (g0)[g1*4],r0
- index*scale + displ ld 0xf00[g1*4],r0
- index*scale ld [g1*4],r0
- index + base + displ ld 0xf00(g0)[g1*1],r0
-
- In each case, scale can be 1, 2, 4, 8, or 16. */
-
-/* This is exactly the same as i960_print_operand_addr, except that
- it recognizes addresses instead of printing them.
-
- It only recognizes address in canonical form. LEGITIMIZE_ADDRESS should
- convert common non-canonical forms to canonical form so that they will
- be recognized. */
-
-/* These two macros allow us to accept either a REG or a SUBREG anyplace
- where a register is valid. */
-
-#define RTX_OK_FOR_BASE_P(X, STRICT) \
- ((GET_CODE (X) == REG \
- && (STRICT ? REG_OK_FOR_BASE_P_STRICT (X) : REG_OK_FOR_BASE_P (X))) \
- || (GET_CODE (X) == SUBREG \
- && GET_CODE (SUBREG_REG (X)) == REG \
- && (STRICT ? REG_OK_FOR_BASE_P_STRICT (SUBREG_REG (X)) \
- : REG_OK_FOR_BASE_P (SUBREG_REG (X)))))
-
-#define RTX_OK_FOR_INDEX_P(X, STRICT) \
- ((GET_CODE (X) == REG \
- && (STRICT ? REG_OK_FOR_INDEX_P_STRICT (X) : REG_OK_FOR_INDEX_P (X)))\
- || (GET_CODE (X) == SUBREG \
- && GET_CODE (SUBREG_REG (X)) == REG \
- && (STRICT ? REG_OK_FOR_INDEX_P_STRICT (SUBREG_REG (X)) \
- : REG_OK_FOR_INDEX_P (SUBREG_REG (X)))))
-
-int
-legitimate_address_p (mode, addr, strict)
- enum machine_mode mode ATTRIBUTE_UNUSED;
- register rtx addr;
- int strict;
-{
- if (RTX_OK_FOR_BASE_P (addr, strict))
- return 1;
- else if (CONSTANT_P (addr))
- return 1;
- else if (GET_CODE (addr) == PLUS)
- {
- rtx op0, op1;
-
- if (! TARGET_COMPLEX_ADDR && ! reload_completed)
- return 0;
-
- op0 = XEXP (addr, 0);
- op1 = XEXP (addr, 1);
-
- if (RTX_OK_FOR_BASE_P (op0, strict))
- {
- if (RTX_OK_FOR_INDEX_P (op1, strict))
- return 1;
- else if (CONSTANT_P (op1))
- return 1;
- else
- return 0;
- }
- else if (GET_CODE (op0) == PLUS)
- {
- if (GET_CODE (XEXP (op0, 0)) == MULT)
- {
- if (! (RTX_OK_FOR_INDEX_P (XEXP (XEXP (op0, 0), 0), strict)
- && SCALE_TERM_P (XEXP (XEXP (op0, 0), 1))))
- return 0;
-
- if (RTX_OK_FOR_BASE_P (XEXP (op0, 1), strict)
- && CONSTANT_P (op1))
- return 1;
- else
- return 0;
- }
- else if (RTX_OK_FOR_BASE_P (XEXP (op0, 0), strict))
- {
- if (RTX_OK_FOR_INDEX_P (XEXP (op0, 1), strict)
- && CONSTANT_P (op1))
- return 1;
- else
- return 0;
- }
- else
- return 0;
- }
- else if (GET_CODE (op0) == MULT)
- {
- if (! (RTX_OK_FOR_INDEX_P (XEXP (op0, 0), strict)
- && SCALE_TERM_P (XEXP (op0, 1))))
- return 0;
-
- if (RTX_OK_FOR_BASE_P (op1, strict))
- return 1;
- else if (CONSTANT_P (op1))
- return 1;
- else
- return 0;
- }
- else
- return 0;
- }
- else if (GET_CODE (addr) == MULT)
- {
- if (! TARGET_COMPLEX_ADDR && ! reload_completed)
- return 0;
-
- return (RTX_OK_FOR_INDEX_P (XEXP (addr, 0), strict)
- && SCALE_TERM_P (XEXP (addr, 1)));
- }
- else
- return 0;
-}
-
-/* Try machine-dependent ways of modifying an illegitimate address
- to be legitimate. If we find one, return the new, valid address.
- This macro is used in only one place: `memory_address' in explow.c.
-
- This converts some non-canonical addresses to canonical form so they
- can be recognized. */
-
-rtx
-legitimize_address (x, oldx, mode)
- register rtx x;
- register rtx oldx ATTRIBUTE_UNUSED;
- enum machine_mode mode ATTRIBUTE_UNUSED;
-{
- if (GET_CODE (x) == SYMBOL_REF)
- {
- abort ();
- x = copy_to_reg (x);
- }
-
- if (! TARGET_COMPLEX_ADDR && ! reload_completed)
- return x;
-
- /* Canonicalize (plus (mult (reg) (const)) (plus (reg) (const)))
- into (plus (plus (mult (reg) (const)) (reg)) (const)). This can be
- created by virtual register instantiation, register elimination, and
- similar optimizations. */
- if (GET_CODE (x) == PLUS && GET_CODE (XEXP (x, 0)) == MULT
- && GET_CODE (XEXP (x, 1)) == PLUS)
- x = gen_rtx_PLUS (Pmode,
- gen_rtx_PLUS (Pmode, XEXP (x, 0), XEXP (XEXP (x, 1), 0)),
- XEXP (XEXP (x, 1), 1));
-
- /* Canonicalize (plus (plus (mult (reg) (const)) (plus (reg) (const))) const)
- into (plus (plus (mult (reg) (const)) (reg)) (const)). */
- else if (GET_CODE (x) == PLUS && GET_CODE (XEXP (x, 0)) == PLUS
- && GET_CODE (XEXP (XEXP (x, 0), 0)) == MULT
- && GET_CODE (XEXP (XEXP (x, 0), 1)) == PLUS
- && CONSTANT_P (XEXP (x, 1)))
- {
- rtx constant, other;
-
- if (GET_CODE (XEXP (x, 1)) == CONST_INT)
- {
- constant = XEXP (x, 1);
- other = XEXP (XEXP (XEXP (x, 0), 1), 1);
- }
- else if (GET_CODE (XEXP (XEXP (XEXP (x, 0), 1), 1)) == CONST_INT)
- {
- constant = XEXP (XEXP (XEXP (x, 0), 1), 1);
- other = XEXP (x, 1);
- }
- else
- constant = 0, other = 0;
-
- if (constant)
- x = gen_rtx_PLUS (Pmode,
- gen_rtx_PLUS (Pmode, XEXP (XEXP (x, 0), 0),
- XEXP (XEXP (XEXP (x, 0), 1), 0)),
- plus_constant (other, INTVAL (constant)));
- }
-
- return x;
-}
-\f
-#if 0
-/* Return the most stringent alignment that we are willing to consider
- objects of size SIZE and known alignment ALIGN as having. */
-
-int
-i960_alignment (size, align)
- int size;
- int align;
-{
- int i;
-
- if (! TARGET_STRICT_ALIGN)
- if (TARGET_IC_COMPAT2_0 || align >= 4)
- {
- i = i960_object_bytes_bitalign (size) / BITS_PER_UNIT;
- if (i > align)
- align = i;
- }
-
- return align;
-}
-#endif
-\f
-
-int
-hard_regno_mode_ok (regno, mode)
- int regno;
- enum machine_mode mode;
-{
- if (regno < 32)
- {
- switch (mode)
- {
- case CCmode: case CC_UNSmode: case CC_CHKmode:
- return 0;
-
- case DImode: case DFmode:
- return (regno & 1) == 0;
-
- case TImode: case TFmode:
- return (regno & 3) == 0;
-
- default:
- return 1;
- }
- }
- else if (regno >= 32 && regno < 36)
- {
- switch (mode)
- {
- case SFmode: case DFmode: case TFmode:
- case SCmode: case DCmode:
- return 1;
-
- default:
- return 0;
- }
- }
- else if (regno == 36)
- {
- switch (mode)
- {
- case CCmode: case CC_UNSmode: case CC_CHKmode:
- return 1;
-
- default:
- return 0;
- }
- }
- else if (regno == 37)
- return 0;
-
- abort ();
-}
-
-\f
-/* Return the minimum alignment of an expression rtx X in bytes. This takes
- advantage of machine specific facts, such as knowing that the frame pointer
- is always 16 byte aligned. */
-
-int
-i960_expr_alignment (x, size)
- rtx x;
- int size;
-{
- int align = 1;
-
- if (x == 0)
- return 1;
-
- switch (GET_CODE(x))
- {
- case CONST_INT:
- align = INTVAL(x);
-
- if ((align & 0xf) == 0)
- align = 16;
- else if ((align & 0x7) == 0)
- align = 8;
- else if ((align & 0x3) == 0)
- align = 4;
- else if ((align & 0x1) == 0)
- align = 2;
- else
- align = 1;
- break;
-
- case PLUS:
- align = MIN (i960_expr_alignment (XEXP (x, 0), size),
- i960_expr_alignment (XEXP (x, 1), size));
- break;
-
- case SYMBOL_REF:
- /* If this is a valid program, objects are guaranteed to be
- correctly aligned for whatever size the reference actually is. */
- align = i960_object_bytes_bitalign (size) / BITS_PER_UNIT;
- break;
-
- case REG:
- if (REGNO (x) == FRAME_POINTER_REGNUM)
- align = 16;
- break;
-
- case ASHIFT:
- align = i960_expr_alignment (XEXP (x, 0), size);
-
- if (GET_CODE (XEXP (x, 1)) == CONST_INT)
- {
- align = align << INTVAL (XEXP (x, 1));
- align = MIN (align, 16);
- }
- break;
-
- case MULT:
- align = (i960_expr_alignment (XEXP (x, 0), size) *
- i960_expr_alignment (XEXP (x, 1), size));
-
- align = MIN (align, 16);
- break;
- default:
- break;
- }
-
- return align;
-}
-
-/* Return true if it is possible to reference both BASE and OFFSET, which
- have alignment at least as great as 4 byte, as if they had alignment valid
- for an object of size SIZE. */
-
-int
-i960_improve_align (base, offset, size)
- rtx base;
- rtx offset;
- int size;
-{
- int i, j;
-
- /* We have at least a word reference to the object, so we know it has to
- be aligned at least to 4 bytes. */
-
- i = MIN (i960_expr_alignment (base, 4),
- i960_expr_alignment (offset, 4));
-
- i = MAX (i, 4);
-
- /* We know the size of the request. If strict align is not enabled, we
- can guess that the alignment is OK for the requested size. */
-
- if (! TARGET_STRICT_ALIGN)
- if ((j = (i960_object_bytes_bitalign (size) / BITS_PER_UNIT)) > i)
- i = j;
-
- return (i >= size);
-}
-
-/* Return true if it is possible to access BASE and OFFSET, which have 4 byte
- (SImode) alignment as if they had 16 byte (TImode) alignment. */
-
-int
-i960_si_ti (base, offset)
- rtx base;
- rtx offset;
-{
- return i960_improve_align (base, offset, 16);
-}
-
-/* Return true if it is possible to access BASE and OFFSET, which have 4 byte
- (SImode) alignment as if they had 8 byte (DImode) alignment. */
-
-int
-i960_si_di (base, offset)
- rtx base;
- rtx offset;
-{
- return i960_improve_align (base, offset, 8);
-}
-\f
-/* Return raw values of size and alignment (in words) for the data
- type being accessed. These values will be rounded by the caller. */
-
-static void
-i960_arg_size_and_align (mode, type, size_out, align_out)
- enum machine_mode mode;
- tree type;
- int *size_out;
- int *align_out;
-{
- int size, align;
-
- /* Use formal alignment requirements of type being passed, except make
- it at least a word. If we don't have a type, this is a library call,
- and the parm has to be of scalar type. In this case, consider its
- formal alignment requirement to be its size in words. */
-
- if (mode == BLKmode)
- size = (int_size_in_bytes (type) + UNITS_PER_WORD - 1) / UNITS_PER_WORD;
- else if (mode == VOIDmode)
- {
- /* End of parm list. */
- if (type == 0 || TYPE_MODE (type) != VOIDmode)
- abort ();
- size = 1;
- }
- else
- size = (GET_MODE_SIZE (mode) + UNITS_PER_WORD - 1) / UNITS_PER_WORD;
-
- if (type == 0)
- align = size;
- else if (TYPE_ALIGN (type) >= BITS_PER_WORD)
- align = TYPE_ALIGN (type) / BITS_PER_WORD;
- else
- align = 1;
-
- *size_out = size;
- *align_out = align;
-}
-
-/* On the 80960 the first 12 args are in registers and the rest are pushed.
- Any arg that is bigger than 4 words is placed on the stack and all
- subsequent arguments are placed on the stack.
-
- Additionally, parameters with an alignment requirement stronger than
- a word must be aligned appropriately. Note that this means that a
- 64 bit object with a 32 bit alignment is not 64 bit aligned and may be
- passed in an odd/even register pair. */
-
-/* Update CUM to advance past an argument described by MODE and TYPE. */
-
-void
-i960_function_arg_advance (cum, mode, type, named)
- CUMULATIVE_ARGS *cum;
- enum machine_mode mode;
- tree type;
- int named ATTRIBUTE_UNUSED;
-{
- int size, align;
-
- i960_arg_size_and_align (mode, type, &size, &align);
-
- if (size > 4 || cum->ca_nstackparms != 0
- || (size + ROUND_PARM (cum->ca_nregparms, align)) > NPARM_REGS
- || MUST_PASS_IN_STACK (mode, type))
- {
- /* Indicate that all the registers are in use, even if all are not,
- so va_start will compute the right value. */
- cum->ca_nregparms = NPARM_REGS;
- cum->ca_nstackparms = ROUND_PARM (cum->ca_nstackparms, align) + size;
- }
- else
- cum->ca_nregparms = ROUND_PARM (cum->ca_nregparms, align) + size;
-}
-
-/* Return the register that the argument described by MODE and TYPE is
- passed in, or else return 0 if it is passed on the stack. */
-
-rtx
-i960_function_arg (cum, mode, type, named)
- CUMULATIVE_ARGS *cum;
- enum machine_mode mode;
- tree type;
- int named ATTRIBUTE_UNUSED;
-{
- rtx ret;
- int size, align;
-
- if (mode == VOIDmode)
- return 0;
-
- i960_arg_size_and_align (mode, type, &size, &align);
-
- if (size > 4 || cum->ca_nstackparms != 0
- || (size + ROUND_PARM (cum->ca_nregparms, align)) > NPARM_REGS
- || MUST_PASS_IN_STACK (mode, type))
- {
- cum->ca_nstackparms = ROUND_PARM (cum->ca_nstackparms, align);
- ret = 0;
- }
- else
- {
- cum->ca_nregparms = ROUND_PARM (cum->ca_nregparms, align);
- ret = gen_rtx_REG (mode, cum->ca_nregparms);
- }
-
- return ret;
-}
-\f
-/* Return the number of bits that an object of size N bytes is aligned to. */
-
-int
-i960_object_bytes_bitalign (n)
- int n;
-{
- if (n > 8) n = 128;
- else if (n > 4) n = 64;
- else if (n > 2) n = 32;
- else if (n > 1) n = 16;
- else n = 8;
-
- return n;
-}
-
-/* Compute the alignment for an aggregate type TSIZE.
- Alignment is MAX (greatest member alignment,
- MIN (pragma align, structure size alignment)). */
-
-int
-i960_round_align (align, type)
- int align;
- tree type;
-{
- int new_align;
- tree tsize;
-
- if (TARGET_OLD_ALIGN || TYPE_PACKED (type))
- return align;
- if (TREE_CODE (type) != RECORD_TYPE)
- return align;
- tsize = TYPE_SIZE (type);
-
- if (! tsize || TREE_CODE (tsize) != INTEGER_CST)
- return align;
-
- new_align = i960_object_bytes_bitalign (TREE_INT_CST_LOW (tsize)
- / BITS_PER_UNIT);
- /* Handle #pragma align. */
- if (new_align > i960_maxbitalignment)
- new_align = i960_maxbitalignment;
-
- if (align < new_align)
- align = new_align;
-
- return align;
-}
-\f
-/* Do any needed setup for a varargs function. For the i960, we must
- create a register parameter block if one doesn't exist, and then copy
- all register parameters to memory. */
-
-void
-i960_setup_incoming_varargs (cum, mode, type, pretend_size, no_rtl)
- CUMULATIVE_ARGS *cum;
- enum machine_mode mode ATTRIBUTE_UNUSED;
- tree type ATTRIBUTE_UNUSED;
- int *pretend_size ATTRIBUTE_UNUSED;
- int no_rtl;
-{
- /* Note: for a varargs fn with only a va_alist argument, this is 0. */
- int first_reg = cum->ca_nregparms;
-
- /* Copy only unnamed register arguments to memory. If there are
- any stack parms, there are no unnamed arguments in registers, and
- an argument block was already allocated by the caller.
- Remember that any arg bigger than 4 words is passed on the stack as
- are all subsequent args.
-
- If there are no stack arguments but there are exactly NPARM_REGS
- registers, either there were no extra arguments or the caller
- allocated an argument block. */
-
- if (cum->ca_nstackparms == 0 && first_reg < NPARM_REGS && !no_rtl)
- {
- rtx label = gen_label_rtx ();
- rtx regblock, fake_arg_pointer_rtx;
-
- /* Use a different rtx than arg_pointer_rtx so that cse and friends
- can go on believing that the argument pointer can never be zero. */
- fake_arg_pointer_rtx = gen_raw_REG (Pmode, ARG_POINTER_REGNUM);
-
- /* If the argument pointer is 0, no arguments were passed on the stack
- and we need to allocate a chunk to save the registers (if any
- arguments were passed on the stack the caller would allocate the
- 48 bytes as well). We must allocate all 48 bytes (12*4) because
- va_start assumes it. */
- emit_insn (gen_cmpsi (fake_arg_pointer_rtx, const0_rtx));
- emit_jump_insn (gen_bne (label));
- emit_insn (gen_rtx_SET (VOIDmode, fake_arg_pointer_rtx,
- stack_pointer_rtx));
- emit_insn (gen_rtx_SET (VOIDmode, stack_pointer_rtx,
- memory_address (SImode,
- plus_constant (stack_pointer_rtx,
- 48))));
- emit_label (label);
-
- /* ??? Note that we unnecessarily store one extra register for stdarg
- fns. We could optimize this, but it's kept as for now. */
- regblock = gen_rtx_MEM (BLKmode,
- plus_constant (arg_pointer_rtx, first_reg * 4));
- set_mem_alias_set (regblock, get_varargs_alias_set ());
- set_mem_align (regblock, BITS_PER_WORD);
- move_block_from_reg (first_reg, regblock,
- NPARM_REGS - first_reg);
- }
-}
-
-/* Define the `__builtin_va_list' type for the ABI. */
-
-static tree
-i960_build_builtin_va_list ()
-{
- return build_array_type (unsigned_type_node,
- build_index_type (size_one_node));
-}
-
-/* Implement `va_start' for varargs and stdarg. */
-
-void
-i960_va_start (valist, nextarg)
- tree valist;
- rtx nextarg ATTRIBUTE_UNUSED;
-{
- tree s, t, base, num;
- rtx fake_arg_pointer_rtx;
-
- /* The array type always decays to a pointer before we get here, so we
- can't use ARRAY_REF. */
- base = build1 (INDIRECT_REF, unsigned_type_node, valist);
- num = build1 (INDIRECT_REF, unsigned_type_node,
- build (PLUS_EXPR, unsigned_type_node, valist,
- TYPE_SIZE_UNIT (TREE_TYPE (valist))));
-
- /* Use a different rtx than arg_pointer_rtx so that cse and friends
- can go on believing that the argument pointer can never be zero. */
- fake_arg_pointer_rtx = gen_raw_REG (Pmode, ARG_POINTER_REGNUM);
- s = make_tree (unsigned_type_node, fake_arg_pointer_rtx);
- t = build (MODIFY_EXPR, unsigned_type_node, base, s);
- TREE_SIDE_EFFECTS (t) = 1;
- expand_expr (t, const0_rtx, VOIDmode, EXPAND_NORMAL);
-
- s = build_int_2 ((current_function_args_info.ca_nregparms
- + current_function_args_info.ca_nstackparms) * 4, 0);
- t = build (MODIFY_EXPR, unsigned_type_node, num, s);
- TREE_SIDE_EFFECTS (t) = 1;
- expand_expr (t, const0_rtx, VOIDmode, EXPAND_NORMAL);
-}
-
-/* Implement `va_arg'. */
-
-rtx
-i960_va_arg (valist, type)
- tree valist, type;
-{
- HOST_WIDE_INT siz, ali;
- tree base, num, pad, next, this, t1, t2, int48;
- rtx addr_rtx;
-
- /* The array type always decays to a pointer before we get here, so we
- can't use ARRAY_REF. */
- base = build1 (INDIRECT_REF, unsigned_type_node, valist);
- num = build1 (INDIRECT_REF, unsigned_type_node,
- build (PLUS_EXPR, unsigned_type_node, valist,
- TYPE_SIZE_UNIT (TREE_TYPE (valist))));
-
- /* Round up sizeof(type) to a word. */
- siz = (int_size_in_bytes (type) + UNITS_PER_WORD - 1) & -UNITS_PER_WORD;
-
- /* Round up alignment to a word. */
- ali = TYPE_ALIGN (type);
- if (ali < BITS_PER_WORD)
- ali = BITS_PER_WORD;
- ali /= BITS_PER_UNIT;
-
- /* Align NUM appropriate for the argument. */
- pad = fold (build (PLUS_EXPR, unsigned_type_node, num,
- build_int_2 (ali - 1, 0)));
- pad = fold (build (BIT_AND_EXPR, unsigned_type_node, pad,
- build_int_2 (-ali, -1)));
- pad = save_expr (pad);
-
- /* Increment VPAD past this argument. */
- next = fold (build (PLUS_EXPR, unsigned_type_node, pad,
- build_int_2 (siz, 0)));
- next = save_expr (next);
-
- /* Find the offset for the current argument. Mind peculiar overflow
- from registers to stack. */
- int48 = build_int_2 (48, 0);
- if (siz > 16)
- t2 = integer_one_node;
- else
- t2 = fold (build (GT_EXPR, integer_type_node, next, int48));
- t1 = fold (build (LE_EXPR, integer_type_node, num, int48));
- t1 = fold (build (TRUTH_AND_EXPR, integer_type_node, t1, t2));
- this = fold (build (COND_EXPR, unsigned_type_node, t1, int48, pad));
-
- /* Find the address for the current argument. */
- t1 = fold (build (PLUS_EXPR, unsigned_type_node, base, this));
- t1 = build1 (NOP_EXPR, ptr_type_node, t1);
- addr_rtx = expand_expr (t1, NULL_RTX, Pmode, EXPAND_NORMAL);
-
- /* Increment NUM. */
- t1 = build (MODIFY_EXPR, unsigned_type_node, num, next);
- TREE_SIDE_EFFECTS (t1) = 1;
- expand_expr (t1, const0_rtx, VOIDmode, EXPAND_NORMAL);
-
- return addr_rtx;
-}
-
-/* Calculate the final size of the reg parm stack space for the current
- function, based on how many bytes would be allocated on the stack. */
-
-int
-i960_final_reg_parm_stack_space (const_size, var_size)
- int const_size;
- tree var_size;
-{
- if (var_size || const_size > 48)
- return 48;
- else
- return 0;
-}
-
-/* Calculate the size of the reg parm stack space. This is a bit complicated
- on the i960. */
-
-int
-i960_reg_parm_stack_space (fndecl)
- tree fndecl;
-{
- /* In this case, we are called from emit_library_call, and we don't need
- to pretend we have more space for parameters than what's apparent. */
- if (fndecl == 0)
- return 0;
-
- /* In this case, we are called from locate_and_pad_parms when we're
- not IN_REGS, so we have an arg block. */
- if (fndecl != current_function_decl)
- return 48;
-
- /* Otherwise, we have an arg block if the current function has more than
- 48 bytes of parameters. */
- if (current_function_args_size != 0 || VARARGS_STDARG_FUNCTION (fndecl))
- return 48;
- else
- return 0;
-}
-\f
-/* Return the register class of a scratch register needed to copy IN into
- or out of a register in CLASS in MODE. If it can be done directly,
- NO_REGS is returned. */
-
-enum reg_class
-secondary_reload_class (class, mode, in)
- enum reg_class class;
- enum machine_mode mode;
- rtx in;
-{
- int regno = -1;
-
- if (GET_CODE (in) == REG || GET_CODE (in) == SUBREG)
- regno = true_regnum (in);
-
- /* We can place anything into LOCAL_OR_GLOBAL_REGS and can put
- LOCAL_OR_GLOBAL_REGS into anything. */
- if (class == LOCAL_OR_GLOBAL_REGS || class == LOCAL_REGS
- || class == GLOBAL_REGS || (regno >= 0 && regno < 32))
- return NO_REGS;
-
- /* We can place any hard register, 0.0, and 1.0 into FP_REGS. */
- if (class == FP_REGS
- && ((regno >= 0 && regno < FIRST_PSEUDO_REGISTER)
- || in == CONST0_RTX (mode) || in == CONST1_RTX (mode)))
- return NO_REGS;
-
- return LOCAL_OR_GLOBAL_REGS;
-}
-\f
-/* Look at the opcode P, and set i96_last_insn_type to indicate which
- function unit it executed on. */
-
-/* ??? This would make more sense as an attribute. */
-
-void
-i960_scan_opcode (p)
- const char *p;
-{
- switch (*p)
- {
- case 'a':
- case 'd':
- case 'e':
- case 'm':
- case 'n':
- case 'o':
- case 'r':
- /* Ret is not actually of type REG, but it won't matter, because no
- insn will ever follow it. */
- case 'u':
- case 'x':
- i960_last_insn_type = I_TYPE_REG;
- break;
-
- case 'b':
- if (p[1] == 'x' || p[3] == 'x')
- i960_last_insn_type = I_TYPE_MEM;
- i960_last_insn_type = I_TYPE_CTRL;
- break;
-
- case 'f':
- case 't':
- i960_last_insn_type = I_TYPE_CTRL;
- break;
-
- case 'c':
- if (p[1] == 'a')
- {
- if (p[4] == 'x')
- i960_last_insn_type = I_TYPE_MEM;
- else
- i960_last_insn_type = I_TYPE_CTRL;
- }
- else if (p[1] == 'm')
- {
- if (p[3] == 'd')
- i960_last_insn_type = I_TYPE_REG;
- else if (p[4] == 'b' || p[4] == 'j')
- i960_last_insn_type = I_TYPE_CTRL;
- else
- i960_last_insn_type = I_TYPE_REG;
- }
- else
- i960_last_insn_type = I_TYPE_REG;
- break;
-
- case 'l':
- i960_last_insn_type = I_TYPE_MEM;
- break;
-
- case 's':
- if (p[1] == 't')
- i960_last_insn_type = I_TYPE_MEM;
- else
- i960_last_insn_type = I_TYPE_REG;
- break;
- }
-}
-
-static void
-i960_output_mi_thunk (file, thunk, delta, vcall_offset, function)
- FILE *file;
- tree thunk ATTRIBUTE_UNUSED;
- HOST_WIDE_INT delta;
- HOST_WIDE_INT vcall_offset ATTRIBUTE_UNUSED;
- tree function;
-{
- int d = delta;
- if (d < 0 && d > -32)
- fprintf (file, "\tsubo %d,g0,g0\n", -d);
- else if (d > 0 && d < 32)
- fprintf (file, "\taddo %d,g0,g0\n", d);
- else
- {
- fprintf (file, "\tldconst %d,r5\n", d);
- fprintf (file, "\taddo r5,g0,g0\n");
- }
- fprintf (file, "\tbx ");
- assemble_name (file, XSTR (XEXP (DECL_RTL (function), 0), 0));
- fprintf (file, "\n");
-}
-
-static bool
-i960_rtx_costs (x, code, outer_code, total)
- rtx x;
- int code, outer_code;
- int *total;
-{
- switch (code)
- {
- /* Constants that can be (non-ldconst) insn operands are cost 0.
- Constants that can be non-ldconst operands in rare cases are cost 1.
- Other constants have higher costs.
-
- Must check for OUTER_CODE of SET for power2_operand, because
- reload_cse_move2add calls us with OUTER_CODE of PLUS to decide
- when to replace set with add. */
-
- case CONST_INT:
- if ((INTVAL (x) >= 0 && INTVAL (x) < 32)
- || (outer_code == SET && power2_operand (x, VOIDmode)))
- {
- *total = 0;
- return true;
- }
- else if (INTVAL (x) >= -31 && INTVAL (x) < 0)
- {
- *total = 1;
- return true;
- }
- /* FALLTHRU */
-
- case CONST:
- case LABEL_REF:
- case SYMBOL_REF:
- *total = (TARGET_C_SERIES ? 6 : 8);
- return true;
-
- case CONST_DOUBLE:
- if (x == CONST0_RTX (DFmode) || x == CONST0_RTX (SFmode)
- || x == CONST1_RTX (DFmode) || x == CONST1_RTX (SFmode))
- *total = 1;
- else
- *total = 12;
- return true;
-
- default:
- return false;
- }
-}
+++ /dev/null
-/* Definitions of target machine for GNU compiler, for Intel 80960
- Copyright (C) 1992, 1993, 1995, 1996, 1998, 1999, 2000, 2001, 2002
- Free Software Foundation, Inc.
- Contributed by Steven McGeady, Intel Corp.
- Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
- Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* Note that some other tm.h files may include this one and then override
- many of the definitions that relate to assembler syntax. */
-
-/* Target CPU builtins. */
-#define TARGET_CPU_CPP_BUILTINS() \
- do \
- { \
- builtin_define_std ("i960"); \
- builtin_define_std ("I960"); \
- builtin_define_std ("i80960"); \
- builtin_define_std ("I80960"); \
- builtin_assert ("cpu=i960"); \
- builtin_assert ("machine=i960"); \
- } \
- while (0)
-
-#define MULTILIB_DEFAULTS { "mnumerics" }
-
-/* Name to predefine in the preprocessor for processor variations.
- -mic* options make characters signed by default. */
-#define CPP_SPEC "%{mic*:-D__i960 -fsigned-char\
- %{mka:-D__i960KA}%{mkb:-D__i960KB}\
- %{mja:-D__i960JA}%{mjd:-D__i960JD}%{mjf:-D__i960JF}\
- %{mrp:-D__i960RP}\
- %{msa:-D__i960SA}%{msb:-D__i960SB}\
- %{mmc:-D__i960MC}\
- %{mca:-D__i960CA}%{mcc:-D__i960CC}\
- %{mcf:-D__i960CF}}\
- %{msoft-float:-D_SOFT_FLOAT}\
- %{mka:-D__i960KA__ -D__i960_KA__}\
- %{mkb:-D__i960KB__ -D__i960_KB__}\
- %{msa:-D__i960SA__ -D__i960_SA__}\
- %{msb:-D__i960SB__ -D__i960_SB__}\
- %{mmc:-D__i960MC__ -D__i960_MC__}\
- %{mca:-D__i960CA__ -D__i960_CA__}\
- %{mcc:-D__i960CC__ -D__i960_CC__}\
- %{mcf:-D__i960CF__ -D__i960_CF__}\
- %{!mka:%{!mkb:%{!msa:%{!msb:%{!mmc:%{!mca:\
- %{!mcc:%{!mcf:-D__i960_KB -D__i960KB__ %{mic*:-D__i960KB}}}}}}}}}\
- %{mlong-double-64:-D__LONG_DOUBLE_64__}"
-
-/* Specs for the compiler, to handle processor variations.
- If the user gives an explicit -gstabs or -gcoff option, then do not
- try to add an implicit one, as this will fail.
- -mic* options make characters signed by default. */
-#define CC1_SPEC \
- "%{mic*:-fsigned-char}\
-%{!mka:%{!mkb:%{!msa:%{!msb:%{!mmc:%{!mca:%{!mcc:%{!mcf:%{!mja:%{!mjd:%{!mjf:%{!mrp:-mka}}}}}}}}}}}}\
- %{!gs*:%{!gc*:%{mbout:%{g*:-gstabs}}\
- %{mcoff:%{g*:-gcoff}}\
- %{!mbout:%{!mcoff:%{g*:-gstabs}}}}}"
-
-/* Specs for the assembler, to handle processor variations.
- For compatibility with Intel's gnu960 tool chain, pass -A options to
- the assembler. */
-#define ASM_SPEC \
- "%{mka:-AKA}%{mkb:-AKB}%{msa:-ASA}%{msb:-ASB}\
- %{mmc:-AMC}%{mca:-ACA}%{mcc:-ACC}%{mcf:-ACF}\
- %{mja:-AJX}%{mjd:-AJX}%{mjf:-AJX}%{mrp:-AJX}\
- %{!mka:%{!mkb:%{!msa:%{!msb:%{!mmc:%{!mca:%{!mcc:%{!mcf:%{!mja:%{!mjd:%{!mjf:%{!mrp:-AKB}}}}}}}}}}}}\
- %{mlink-relax:-linkrelax}"
-
-/* Specs for the linker, to handle processor variations.
- For compatibility with Intel's gnu960 tool chain, pass -F and -A options
- to the linker. */
-#define LINK_SPEC \
- "%{mka:-AKA}%{mkb:-AKB}%{msa:-ASA}%{msb:-ASB}\
- %{mmc:-AMC}%{mca:-ACA}%{mcc:-ACC}%{mcf:-ACF}\
- %{mja:-AJX}%{mjd:-AJX}%{mjf:-AJX}%{mrp:-AJX}\
- %{mbout:-Fbout}%{mcoff:-Fcoff}\
- %{mlink-relax:-relax}"
-
-/* Specs for the libraries to link with, to handle processor variations.
- Compatible with Intel's gnu960 tool chain. */
-#define LIB_SPEC "%{!nostdlib:-lcg %{p:-lprof}%{pg:-lgprof}\
- %{mka:-lfpg}%{msa:-lfpg}%{mca:-lfpg}%{mcf:-lfpg} -lgnu}"
-
-/* Defining the macro shows we can debug even without a frame pointer.
- Actually, we can debug without FP. But defining the macro results in
- that -O means FP elimination. Addressing through sp requires
- negative offset and more one word addressing in the most cases
- (offsets except for 0-4095 require one more word). Therefore we've
- not defined the macro. */
-/*#define CAN_DEBUG_WITHOUT_FP*/
-
-/* Do leaf procedure and tail call optimizations for -O2 and higher. */
-#define OPTIMIZATION_OPTIONS(LEVEL,SIZE) \
-{ \
- if ((LEVEL) >= 2) \
- { \
- target_flags |= TARGET_FLAG_LEAFPROC; \
- target_flags |= TARGET_FLAG_TAILCALL; \
- } \
-}
-
-/* Print subsidiary information on the compiler version in use. */
-#define TARGET_VERSION fprintf (stderr," (intel 80960)");
-
-/* Generate DBX debugging information. */
-#define DBX_DEBUGGING_INFO 1
-
-/* Generate SDB style debugging information. */
-#define SDB_DEBUGGING_INFO 1
-#define EXTENDED_SDB_BASIC_TYPES
-
-/* Generate DBX_DEBUGGING_INFO by default. */
-#define PREFERRED_DEBUGGING_TYPE DBX_DEBUG
-
-/* Redefine this to print in hex. No value adjustment is necessary
- anymore. */
-#define PUT_SDB_TYPE(A) \
- fprintf (asm_out_file, "\t.type\t0x%x;", A)
-
-/* Handle pragmas for compatibility with Intel's compilers. */
-
-extern int i960_maxbitalignment;
-extern int i960_last_maxbitalignment;
-
-#define REGISTER_TARGET_PRAGMAS() do { \
- c_register_pragma (0, "align", i960_pr_align); \
- c_register_pragma (0, "noalign", i960_pr_noalign); \
-} while (0)
-
-/* Run-time compilation parameters selecting different hardware subsets. */
-
-/* 960 architecture with floating-point. */
-#define TARGET_FLAG_NUMERICS 0x01
-#define TARGET_NUMERICS (target_flags & TARGET_FLAG_NUMERICS)
-
-/* 960 architecture with memory management. */
-/* ??? Not used currently. */
-#define TARGET_FLAG_PROTECTED 0x02
-#define TARGET_PROTECTED (target_flags & TARGET_FLAG_PROTECTED)
-
-/* The following three are mainly used to provide a little sanity checking
- against the -mARCH flags given. The Jx series, for the purposes of
- gcc, is a Kx with a data cache. */
-
-/* Nonzero if we should generate code for the KA and similar processors.
- No FPU, no microcode instructions. */
-#define TARGET_FLAG_K_SERIES 0x04
-#define TARGET_K_SERIES (target_flags & TARGET_FLAG_K_SERIES)
-
-/* Nonzero if we should generate code for the MC processor.
- Not really different from KB for our purposes. */
-#define TARGET_FLAG_MC 0x08
-#define TARGET_MC (target_flags & TARGET_FLAG_MC)
-
-/* Nonzero if we should generate code for the CA processor.
- Enables different optimization strategies. */
-#define TARGET_FLAG_C_SERIES 0x10
-#define TARGET_C_SERIES (target_flags & TARGET_FLAG_C_SERIES)
-
-/* Nonzero if we should generate leaf-procedures when we find them.
- You may not want to do this because leaf-proc entries are
- slower when not entered via BAL - this would be true when
- a linker not supporting the optimization is used. */
-#define TARGET_FLAG_LEAFPROC 0x20
-#define TARGET_LEAFPROC (target_flags & TARGET_FLAG_LEAFPROC)
-
-/* Nonzero if we should perform tail-call optimizations when we find them.
- You may not want to do this because the detection of cases where
- this is not valid is not totally complete. */
-#define TARGET_FLAG_TAILCALL 0x40
-#define TARGET_TAILCALL (target_flags & TARGET_FLAG_TAILCALL)
-
-/* Nonzero if use of a complex addressing mode is a win on this implementation.
- Complex addressing modes are probably not worthwhile on the K-series,
- but they definitely are on the C-series. */
-#define TARGET_FLAG_COMPLEX_ADDR 0x80
-#define TARGET_COMPLEX_ADDR (target_flags & TARGET_FLAG_COMPLEX_ADDR)
-
-/* Align code to 8 byte boundaries for faster fetching. */
-#define TARGET_FLAG_CODE_ALIGN 0x100
-#define TARGET_CODE_ALIGN (target_flags & TARGET_FLAG_CODE_ALIGN)
-
-/* Append branch prediction suffixes to branch opcodes. */
-/* ??? Not used currently. */
-#define TARGET_FLAG_BRANCH_PREDICT 0x200
-#define TARGET_BRANCH_PREDICT (target_flags & TARGET_FLAG_BRANCH_PREDICT)
-
-/* Forces prototype and return promotions. */
-/* ??? This does not work. */
-#define TARGET_FLAG_CLEAN_LINKAGE 0x400
-#define TARGET_CLEAN_LINKAGE (target_flags & TARGET_FLAG_CLEAN_LINKAGE)
-
-/* For compatibility with iC960 v3.0. */
-#define TARGET_FLAG_IC_COMPAT3_0 0x800
-#define TARGET_IC_COMPAT3_0 (target_flags & TARGET_FLAG_IC_COMPAT3_0)
-
-/* For compatibility with iC960 v2.0. */
-#define TARGET_FLAG_IC_COMPAT2_0 0x1000
-#define TARGET_IC_COMPAT2_0 (target_flags & TARGET_FLAG_IC_COMPAT2_0)
-
-/* If no unaligned accesses are to be permitted. */
-#define TARGET_FLAG_STRICT_ALIGN 0x2000
-#define TARGET_STRICT_ALIGN (target_flags & TARGET_FLAG_STRICT_ALIGN)
-
-/* For compatibility with iC960 assembler. */
-#define TARGET_FLAG_ASM_COMPAT 0x4000
-#define TARGET_ASM_COMPAT (target_flags & TARGET_FLAG_ASM_COMPAT)
-
-/* For compatibility with the gcc960 v1.2 compiler. Use the old structure
- alignment rules. Also, turns on STRICT_ALIGNMENT. */
-#define TARGET_FLAG_OLD_ALIGN 0x8000
-#define TARGET_OLD_ALIGN (target_flags & TARGET_FLAG_OLD_ALIGN)
-
-/* Nonzero if long doubles are to be 64 bits. Useful for soft-float targets
- if 80 bit long double support is missing. */
-#define TARGET_FLAG_LONG_DOUBLE_64 0x10000
-#define TARGET_LONG_DOUBLE_64 (target_flags & TARGET_FLAG_LONG_DOUBLE_64)
-
-extern int target_flags;
-
-/* Macro to define tables used to set the flags.
- This is a list in braces of pairs in braces,
- each pair being { "NAME", VALUE }
- where VALUE is the bits to set or minus the bits to clear.
- An empty string NAME is used to identify the default VALUE. */
-
-/* ??? Not all ten of these architecture variations actually exist, but I
- am not sure which are real and which aren't. */
-
-#define TARGET_SWITCHES \
- { {"sa", (TARGET_FLAG_K_SERIES|TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate SA code")}, \
- {"sb", (TARGET_FLAG_NUMERICS|TARGET_FLAG_K_SERIES| \
- TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate SB code")}, \
-/* {"sc", (TARGET_FLAG_NUMERICS|TARGET_FLAG_PROTECTED| \
- TARGET_FLAG_MC|TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate SC code")}, */ \
- {"ka", (TARGET_FLAG_K_SERIES|TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate KA code")}, \
- {"kb", (TARGET_FLAG_NUMERICS|TARGET_FLAG_K_SERIES| \
- TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate KB code")}, \
-/* {"kc", (TARGET_FLAG_NUMERICS|TARGET_FLAG_PROTECTED| \
- TARGET_FLAG_MC|TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate KC code")}, */ \
- {"ja", (TARGET_FLAG_K_SERIES|TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate JA code")}, \
- {"jd", (TARGET_FLAG_K_SERIES|TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate JD code")}, \
- {"jf", (TARGET_FLAG_NUMERICS|TARGET_FLAG_K_SERIES| \
- TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate JF code")}, \
- {"rp", (TARGET_FLAG_K_SERIES|TARGET_FLAG_COMPLEX_ADDR), \
- N_("generate RP code")}, \
- {"mc", (TARGET_FLAG_NUMERICS|TARGET_FLAG_PROTECTED| \
- TARGET_FLAG_MC|TARGET_FLAG_COMPLEX_ADDR), \
- N_("Generate MC code")}, \
- {"ca", (TARGET_FLAG_C_SERIES|TARGET_FLAG_BRANCH_PREDICT| \
- TARGET_FLAG_CODE_ALIGN|TARGET_FLAG_COMPLEX_ADDR),\
- N_("Generate CA code")}, \
-/* {"cb", (TARGET_FLAG_NUMERICS|TARGET_FLAG_C_SERIES| \
- TARGET_FLAG_BRANCH_PREDICT|TARGET_FLAG_CODE_ALIGN),\
- N_("Generate CB code")}, \
- {"cc", (TARGET_FLAG_NUMERICS|TARGET_FLAG_PROTECTED| \
- TARGET_FLAG_C_SERIES|TARGET_FLAG_BRANCH_PREDICT|\
- TARGET_FLAG_CODE_ALIGN), \
- N_("Generate CC code")}, */ \
- {"cf", (TARGET_FLAG_C_SERIES|TARGET_FLAG_BRANCH_PREDICT| \
- TARGET_FLAG_CODE_ALIGN|TARGET_FLAG_COMPLEX_ADDR),\
- N_("Generate CF code")}, \
- {"numerics", (TARGET_FLAG_NUMERICS), \
- N_("Use hardware floating point instructions")}, \
- {"soft-float", -(TARGET_FLAG_NUMERICS), \
- N_("Use software floating point")}, \
- {"leaf-procedures", TARGET_FLAG_LEAFPROC, \
- N_("Use alternate leaf function entries")}, \
- {"no-leaf-procedures", -(TARGET_FLAG_LEAFPROC), \
- N_("Do not use alternate leaf function entries")}, \
- {"tail-call", TARGET_FLAG_TAILCALL, \
- N_("Perform tail call optimization")}, \
- {"no-tail-call", -(TARGET_FLAG_TAILCALL), \
- N_("Do not perform tail call optimization")}, \
- {"complex-addr", TARGET_FLAG_COMPLEX_ADDR, \
- N_("Use complex addressing modes")}, \
- {"no-complex-addr", -(TARGET_FLAG_COMPLEX_ADDR), \
- N_("Do not use complex addressing modes")}, \
- {"code-align", TARGET_FLAG_CODE_ALIGN, \
- N_("Align code to 8 byte boundary")}, \
- {"no-code-align", -(TARGET_FLAG_CODE_ALIGN), \
- N_("Do not align code to 8 byte boundary")}, \
-/* {"clean-linkage", (TARGET_FLAG_CLEAN_LINKAGE), \
- N_("Force use of prototypes")}, \
- {"no-clean-linkage", -(TARGET_FLAG_CLEAN_LINKAGE), \
- N_("Do not force use of prototypes")}, */ \
- {"ic-compat", TARGET_FLAG_IC_COMPAT2_0, \
- N_("Enable compatibility with iC960 v2.0")}, \
- {"ic2.0-compat", TARGET_FLAG_IC_COMPAT2_0, \
- N_("Enable compatibility with iC960 v2.0")}, \
- {"ic3.0-compat", TARGET_FLAG_IC_COMPAT3_0, \
- N_("Enable compatibility with iC960 v3.0")}, \
- {"asm-compat", TARGET_FLAG_ASM_COMPAT, \
- N_("Enable compatibility with ic960 assembler")}, \
- {"intel-asm", TARGET_FLAG_ASM_COMPAT, \
- N_("Enable compatibility with ic960 assembler")}, \
- {"strict-align", TARGET_FLAG_STRICT_ALIGN, \
- N_("Do not permit unaligned accesses")}, \
- {"no-strict-align", -(TARGET_FLAG_STRICT_ALIGN), \
- N_("Permit unaligned accesses")}, \
- {"old-align", (TARGET_FLAG_OLD_ALIGN|TARGET_FLAG_STRICT_ALIGN), \
- N_("Layout types like Intel's v1.3 gcc")}, \
- {"no-old-align", -(TARGET_FLAG_OLD_ALIGN|TARGET_FLAG_STRICT_ALIGN), \
- N_("Do not layout types like Intel's v1.3 gcc")}, \
- {"long-double-64", TARGET_FLAG_LONG_DOUBLE_64, \
- N_("Use 64 bit long doubles")}, \
- {"link-relax", 0, \
- N_("Enable linker relaxation")}, \
- {"no-link-relax", 0, \
- N_("Do not enable linker relaxation")}, \
- SUBTARGET_SWITCHES \
- { "", TARGET_DEFAULT, \
- NULL}}
-
-/* This are meant to be redefined in the host dependent files */
-#define SUBTARGET_SWITCHES
-
-/* Override conflicting target switch options.
- Doesn't actually detect if more than one -mARCH option is given, but
- does handle the case of two blatantly conflicting -mARCH options. */
-#define OVERRIDE_OPTIONS i960_initialize ()
-
-/* Don't enable anything by default. The user is expected to supply a -mARCH
- option. If none is given, then -mka is added by CC1_SPEC. */
-#define TARGET_DEFAULT 0
-\f
-/* Target machine storage layout. */
-
-/* Define this if most significant bit is lowest numbered
- in instructions that operate on numbered bit-fields. */
-#define BITS_BIG_ENDIAN 0
-
-/* Define this if most significant byte of a word is the lowest numbered.
- The i960 case be either big endian or little endian. We only support
- little endian, which is the most common. */
-#define BYTES_BIG_ENDIAN 0
-
-/* Define this if most significant word of a multiword number is lowest
- numbered. */
-#define WORDS_BIG_ENDIAN 0
-
-/* Bitfields cannot cross word boundaries. */
-#define BITFIELD_NBYTES_LIMITED 1
-
-/* Width of a word, in units (bytes). */
-#define UNITS_PER_WORD 4
-
-/* Width in bits of a long double. */
-#define LONG_DOUBLE_TYPE_SIZE (TARGET_LONG_DOUBLE_64 ? 64 : 128)
-#define MAX_LONG_DOUBLE_TYPE_SIZE 128
-
-/* Define this to set long double type size to use in libgcc2.c, which can
- not depend on target_flags. */
-#if defined(__LONG_DOUBLE_64__)
-#define LIBGCC2_LONG_DOUBLE_TYPE_SIZE 64
-#else
-#define LIBGCC2_LONG_DOUBLE_TYPE_SIZE 128
-#endif
-
-/* Allocation boundary (in *bits*) for storing pointers in memory. */
-#define POINTER_BOUNDARY 32
-
-/* Allocation boundary (in *bits*) for storing arguments in argument list. */
-#define PARM_BOUNDARY 32
-
-/* Boundary (in *bits*) on which stack pointer should be aligned. */
-#define STACK_BOUNDARY 128
-
-/* Allocation boundary (in *bits*) for the code of a function. */
-#define FUNCTION_BOUNDARY 128
-
-/* Alignment of field after `int : 0' in a structure. */
-#define EMPTY_FIELD_BOUNDARY 32
-
-/* This makes zero-length anonymous fields lay the next field
- at a word boundary. It also makes the whole struct have
- at least word alignment if there are any bitfields at all. */
-#define PCC_BITFIELD_TYPE_MATTERS 1
-
-/* Every structure's size must be a multiple of this. */
-#define STRUCTURE_SIZE_BOUNDARY 8
-
-/* No data type wants to be aligned rounder than this.
- Extended precision floats gets 4-word alignment. */
-#define BIGGEST_ALIGNMENT 128
-
-/* Define this if move instructions will actually fail to work
- when given unaligned data.
- 80960 will work even with unaligned data, but it is slow. */
-#define STRICT_ALIGNMENT TARGET_STRICT_ALIGN
-
-/* Specify alignment for string literals (which might be higher than the
- base type's minimal alignment requirement. This allows strings to be
- aligned on word boundaries, and optimizes calls to the str* and mem*
- library functions. */
-#define CONSTANT_ALIGNMENT(EXP, ALIGN) \
- (TREE_CODE (EXP) == STRING_CST \
- && i960_object_bytes_bitalign (int_size_in_bytes (TREE_TYPE (EXP))) > (int)(ALIGN) \
- ? i960_object_bytes_bitalign (int_size_in_bytes (TREE_TYPE (EXP))) \
- : (int)(ALIGN))
-
-/* Macros to determine size of aggregates (structures and unions
- in C). Normally, these may be defined to simply return the maximum
- alignment and simple rounded-up size, but on some machines (like
- the i960), the total size of a structure is based on a non-trivial
- rounding method. */
-
-#define ROUND_TYPE_ALIGN(TYPE, COMPUTED, SPECIFIED) \
- i960_round_align (MAX ((COMPUTED), (SPECIFIED)), TYPE)
-\f
-/* Standard register usage. */
-
-/* Number of actual hardware registers.
- The hardware registers are assigned numbers for the compiler
- from 0 to just below FIRST_PSEUDO_REGISTER.
- All registers that the compiler knows about must be given numbers,
- even those that are not normally considered general registers.
-
- Registers 0-15 are the global registers (g0-g15).
- Registers 16-31 are the local registers (r0-r15).
- Register 32-35 are the fp registers (fp0-fp3).
- Register 36 is the condition code register.
- Register 37 is unused. */
-
-#define FIRST_PSEUDO_REGISTER 38
-
-/* 1 for registers that have pervasive standard uses and are not available
- for the register allocator. On 80960, this includes the frame pointer
- (g15), the previous FP (r0), the stack pointer (r1), the return
- instruction pointer (r2), and the argument pointer (g14). */
-#define FIXED_REGISTERS \
- {0, 0, 0, 0, 0, 0, 0, 0, \
- 0, 0, 0, 0, 0, 0, 1, 1, \
- 1, 1, 1, 0, 0, 0, 0, 0, \
- 0, 0, 0, 0, 0, 0, 0, 0, \
- 0, 0, 0, 0, 1, 1}
-
-/* 1 for registers not available across function calls.
- These must include the FIXED_REGISTERS and also any
- registers that can be used without being saved.
- The latter must include the registers where values are returned
- and the register where structure-value addresses are passed.
- Aside from that, you can include as many other registers as you like. */
-
-/* On the 80960, note that:
- g0..g3 are used for return values,
- g0..g7 may always be used for parameters,
- g8..g11 may be used for parameters, but are preserved if they aren't,
- g12 is the static chain if needed, otherwise is preserved
- g13 is the struct return ptr if used, or temp, but may be trashed,
- g14 is the leaf return ptr or the arg block ptr otherwise zero,
- must be reset to zero before returning if it was used,
- g15 is the frame pointer,
- r0 is the previous FP,
- r1 is the stack pointer,
- r2 is the return instruction pointer,
- r3-r15 are always available,
- r3 is clobbered by calls in functions that use the arg pointer
- r4-r11 may be clobbered by the mcount call when profiling
- r4-r15 if otherwise unused may be used for preserving global registers
- fp0..fp3 are never available. */
-#define CALL_USED_REGISTERS \
- {1, 1, 1, 1, 1, 1, 1, 1, \
- 0, 0, 0, 0, 0, 1, 1, 1, \
- 1, 1, 1, 0, 0, 0, 0, 0, \
- 0, 0, 0, 0, 0, 0, 0, 0, \
- 1, 1, 1, 1, 1, 1}
-
-/* If no fp unit, make all of the fp registers fixed so that they can't
- be used. */
-#define CONDITIONAL_REGISTER_USAGE \
- if (! TARGET_NUMERICS) { \
- fixed_regs[32] = fixed_regs[33] = fixed_regs[34] = fixed_regs[35] = 1;\
- } \
-
-/* Return number of consecutive hard regs needed starting at reg REGNO
- to hold something of mode MODE.
- This is ordinarily the length in words of a value of mode MODE
- but can be less for certain modes in special long registers.
-
- On 80960, ordinary registers hold 32 bits worth, but can be ganged
- together to hold double or extended precision floating point numbers,
- and the floating point registers hold any size floating point number */
-#define HARD_REGNO_NREGS(REGNO, MODE) \
- ((REGNO) < 32 \
- ? (((MODE) == VOIDmode) \
- ? 1 : ((GET_MODE_SIZE (MODE) + UNITS_PER_WORD - 1) / UNITS_PER_WORD)) \
- : ((REGNO) < FIRST_PSEUDO_REGISTER) ? 1 : 0)
-
-/* Value is 1 if hard register REGNO can hold a value of machine-mode MODE.
- On 80960, the cpu registers can hold any mode but the float registers
- can only hold SFmode, DFmode, or TFmode. */
-#define HARD_REGNO_MODE_OK(REGNO, MODE) hard_regno_mode_ok ((REGNO), (MODE))
-
-/* Value is 1 if it is a good idea to tie two pseudo registers
- when one has mode MODE1 and one has mode MODE2.
- If HARD_REGNO_MODE_OK could produce different values for MODE1 and MODE2,
- for any hard reg, then this must be 0 for correct output. */
-
-#define MODES_TIEABLE_P(MODE1, MODE2) \
- ((MODE1) == (MODE2) || GET_MODE_CLASS (MODE1) == GET_MODE_CLASS (MODE2))
-
-/* Specify the registers used for certain standard purposes.
- The values of these macros are register numbers. */
-
-/* 80960 pc isn't overloaded on a register that the compiler knows about. */
-/* #define PC_REGNUM */
-
-/* Register to use for pushing function arguments. */
-#define STACK_POINTER_REGNUM 17
-
-/* Actual top-of-stack address is same as
- the contents of the stack pointer register. */
-#define STACK_POINTER_OFFSET (-current_function_outgoing_args_size)
-
-/* Base register for access to local variables of the function. */
-#define FRAME_POINTER_REGNUM 15
-
-/* Value should be nonzero if functions must have frame pointers.
- Zero means the frame pointer need not be set up (and parms
- may be accessed via the stack pointer) in functions that seem suitable.
- This is computed in `reload', in reload1.c. */
-/* ??? It isn't clear to me why this is here. Perhaps because of a bug (since
- fixed) in the definition of INITIAL_FRAME_POINTER_OFFSET which would have
- caused this to fail. */
-/* ??? Must check current_function_has_nonlocal_goto, otherwise frame pointer
- elimination messes up nonlocal goto sequences. I think this works for other
- targets because they use indirect jumps for the return which disables fp
- elimination. */
-#define FRAME_POINTER_REQUIRED \
- (! leaf_function_p () || current_function_has_nonlocal_goto)
-
-/* Definitions for register eliminations.
-
- This is an array of structures. Each structure initializes one pair
- of eliminable registers. The "from" register number is given first,
- followed by "to". Eliminations of the same "from" register are listed
- in order of preference.. */
-
-#define ELIMINABLE_REGS {{FRAME_POINTER_REGNUM, STACK_POINTER_REGNUM}}
-
-/* Given FROM and TO register numbers, say whether this elimination is allowed.
- Frame pointer elimination is automatically handled. */
-#define CAN_ELIMINATE(FROM, TO) 1
-
-/* Define the offset between two registers, one to be eliminated, and
- the other its replacement, at the start of a routine.
-
- Since the stack grows upward on the i960, this must be a negative number.
- This includes the 64 byte hardware register save area and the size of
- the frame. */
-
-#define INITIAL_ELIMINATION_OFFSET(FROM, TO, OFFSET) \
- do { (OFFSET) = - (64 + compute_frame_size (get_frame_size ())); } while (0)
-
-/* Base register for access to arguments of the function. */
-#define ARG_POINTER_REGNUM 14
-
-/* Register in which static-chain is passed to a function.
- On i960, we use g12. We can't use any local register, because we need
- a register that can be set before a call or before a jump. */
-#define STATIC_CHAIN_REGNUM 12
-
-/* Functions which return large structures get the address
- to place the wanted value at in g13. */
-
-#define STRUCT_VALUE_REGNUM 13
-
-/* The order in which to allocate registers. */
-
-#define REG_ALLOC_ORDER \
-{ 4, 5, 6, 7, 0, 1, 2, 3, 13, /* g4, g5, g6, g7, g0, g1, g2, g3, g13 */ \
- 20, 21, 22, 23, 24, 25, 26, 27,/* r4, r5, r6, r7, r8, r9, r10, r11 */ \
- 28, 29, 30, 31, 19, 8, 9, 10, /* r12, r13, r14, r15, r3, g8, g9, g10 */ \
- 11, 12, /* g11, g12 */ \
- 32, 33, 34, 35, /* fp0, fp1, fp2, fp3 */ \
- /* We can't actually allocate these. */ \
- 16, 17, 18, 14, 15, 36, 37} /* r0, r1, r2, g14, g15, cc */
-\f
-/* Define the classes of registers for register constraints in the
- machine description. Also define ranges of constants.
-
- One of the classes must always be named ALL_REGS and include all hard regs.
- If there is more than one class, another class must be named NO_REGS
- and contain no registers.
-
- The name GENERAL_REGS must be the name of a class (or an alias for
- another name such as ALL_REGS). This is the class of registers
- that is allowed by "g" or "r" in a register constraint.
- Also, registers outside this class are allocated only when
- instructions express preferences for them.
-
- The classes must be numbered in nondecreasing order; that is,
- a larger-numbered class must never be contained completely
- in a smaller-numbered class.
-
- For any two classes, it is very desirable that there be another
- class that represents their union. */
-
-/* The 80960 has four kinds of registers, global, local, floating point,
- and condition code. The cc register is never allocated, so no class
- needs to be defined for it. */
-
-enum reg_class { NO_REGS, GLOBAL_REGS, LOCAL_REGS, LOCAL_OR_GLOBAL_REGS,
- FP_REGS, ALL_REGS, LIM_REG_CLASSES };
-
-/* 'r' includes floating point registers if TARGET_NUMERICS. 'd' never
- does. */
-#define GENERAL_REGS ((TARGET_NUMERICS) ? ALL_REGS : LOCAL_OR_GLOBAL_REGS)
-
-#define N_REG_CLASSES (int) LIM_REG_CLASSES
-
-/* Give names of register classes as strings for dump file. */
-
-#define REG_CLASS_NAMES \
-{ "NO_REGS", "GLOBAL_REGS", "LOCAL_REGS", "LOCAL_OR_GLOBAL_REGS", \
- "FP_REGS", "ALL_REGS" }
-
-/* Define which registers fit in which classes.
- This is an initializer for a vector of HARD_REG_SET
- of length N_REG_CLASSES. */
-
-#define REG_CLASS_CONTENTS \
-{ {0, 0}, {0x0ffff, 0}, {0xffff0000, 0}, {-1,0}, {0, -1}, {-1,-1}}
-
-/* The same information, inverted:
- Return the class number of the smallest class containing
- reg number REGNO. This could be a conditional expression
- or could index an array. */
-
-#define REGNO_REG_CLASS(REGNO) \
- ((REGNO) < 16 ? GLOBAL_REGS \
- : (REGNO) < 32 ? LOCAL_REGS \
- : (REGNO) < 36 ? FP_REGS \
- : NO_REGS)
-
-/* The class value for index registers, and the one for base regs.
- There is currently no difference between base and index registers on the
- i960, but this distinction may one day be useful. */
-#define INDEX_REG_CLASS LOCAL_OR_GLOBAL_REGS
-#define BASE_REG_CLASS LOCAL_OR_GLOBAL_REGS
-
-/* Get reg_class from a letter such as appears in the machine description.
- 'f' is a floating point register (fp0..fp3)
- 'l' is a local register (r0-r15)
- 'b' is a global register (g0-g15)
- 'd' is any local or global register
- 'r' or 'g' are pre-defined to the class GENERAL_REGS. */
-/* 'l' and 'b' are probably never used. Note that 'd' and 'r' are *not*
- the same thing, since 'r' may include the fp registers. */
-#define REG_CLASS_FROM_LETTER(C) \
- (((C) == 'f') && (TARGET_NUMERICS) ? FP_REGS : ((C) == 'l' ? LOCAL_REGS : \
- (C) == 'b' ? GLOBAL_REGS : ((C) == 'd' ? LOCAL_OR_GLOBAL_REGS : NO_REGS)))
-
-/* The letters I, J, K, L and M in a register constraint string
- can be used to stand for particular ranges of immediate operands.
- This macro defines what the ranges are.
- C is the letter, and VALUE is a constant value.
- Return 1 if VALUE is in the range specified by C.
-
- For 80960:
- 'I' is used for literal values 0..31
- 'J' means literal 0
- 'K' means 0..-31. */
-
-#define CONST_OK_FOR_LETTER_P(VALUE, C) \
- ((C) == 'I' ? (((unsigned) (VALUE)) <= 31) \
- : (C) == 'J' ? ((VALUE) == 0) \
- : (C) == 'K' ? ((VALUE) >= -31 && (VALUE) <= 0) \
- : (C) == 'M' ? ((VALUE) >= -32 && (VALUE) <= 0) \
- : 0)
-
-/* Similar, but for floating constants, and defining letters G and H.
- Here VALUE is the CONST_DOUBLE rtx itself.
- For the 80960, G is 0.0 and H is 1.0. */
-
-#define CONST_DOUBLE_OK_FOR_LETTER_P(VALUE, C) \
- ((TARGET_NUMERICS) && \
- (((C) == 'G' && (VALUE) == CONST0_RTX (GET_MODE (VALUE))) \
- || ((C) == 'H' && ((VALUE) == CONST1_RTX (GET_MODE (VALUE))))))
-
-/* Given an rtx X being reloaded into a reg required to be
- in class CLASS, return the class of reg to actually use.
- In general this is just CLASS; but on some machines
- in some cases it is preferable to use a more restrictive class. */
-
-/* On 960, can't load constant into floating-point reg except
- 0.0 or 1.0.
-
- Any hard reg is ok as a src operand of a reload insn. */
-
-#define PREFERRED_RELOAD_CLASS(X,CLASS) \
- (GET_CODE (X) == REG && REGNO (X) < FIRST_PSEUDO_REGISTER \
- ? (CLASS) \
- : ((CLASS) == FP_REGS && CONSTANT_P (X) \
- && (X) != CONST0_RTX (DFmode) && (X) != CONST1_RTX (DFmode)\
- && (X) != CONST0_RTX (SFmode) && (X) != CONST1_RTX (SFmode)\
- ? NO_REGS \
- : (CLASS) == ALL_REGS ? LOCAL_OR_GLOBAL_REGS : (CLASS)))
-
-#define SECONDARY_RELOAD_CLASS(CLASS,MODE,IN) \
- secondary_reload_class (CLASS, MODE, IN)
-
-/* Return the maximum number of consecutive registers
- needed to represent mode MODE in a register of class CLASS. */
-/* On 80960, this is the size of MODE in words,
- except in the FP regs, where a single reg is always enough. */
-#define CLASS_MAX_NREGS(CLASS, MODE) \
- ((CLASS) == FP_REGS ? 1 : HARD_REGNO_NREGS (0, (MODE)))
-\f
-/* Stack layout; function entry, exit and calling. */
-
-/* Define this if pushing a word on the stack
- makes the stack pointer a smaller address. */
-/* #define STACK_GROWS_DOWNWARD */
-
-/* Define this if the nominal address of the stack frame
- is at the high-address end of the local variables;
- that is, each additional local variable allocated
- goes at a more negative offset in the frame. */
-/* #define FRAME_GROWS_DOWNWARD */
-
-/* Offset within stack frame to start allocating local variables at.
- If FRAME_GROWS_DOWNWARD, this is the offset to the END of the
- first local allocated. Otherwise, it is the offset to the BEGINNING
- of the first local allocated.
-
- The i960 has a 64 byte register save area, plus possibly some extra
- bytes allocated for varargs functions. */
-#define STARTING_FRAME_OFFSET 64
-
-/* If we generate an insn to push BYTES bytes,
- this says how many the stack pointer really advances by.
- On 80960, don't define this because there are no push insns. */
-/* #define PUSH_ROUNDING(BYTES) BYTES */
-
-/* Offset of first parameter from the argument pointer register value. */
-#define FIRST_PARM_OFFSET(FNDECL) 0
-
-/* When a parameter is passed in a register, no stack space is
- allocated for it. However, when args are passed in the
- stack, space is allocated for every register parameter. */
-#define MAYBE_REG_PARM_STACK_SPACE 48
-#define FINAL_REG_PARM_STACK_SPACE(CONST_SIZE, VAR_SIZE) \
- i960_final_reg_parm_stack_space (CONST_SIZE, VAR_SIZE);
-#define REG_PARM_STACK_SPACE(DECL) i960_reg_parm_stack_space (DECL)
-#define OUTGOING_REG_PARM_STACK_SPACE
-
-/* Keep the stack pointer constant throughout the function. */
-#define ACCUMULATE_OUTGOING_ARGS 1
-
-/* Value is 1 if returning from a function call automatically
- pops the arguments described by the number-of-args field in the call.
- FUNDECL is the declaration node of the function (as a tree),
- FUNTYPE is the data type of the function (as a tree),
- or for a library call it is an identifier node for the subroutine name. */
-
-#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0
-
-/* Define how to find the value returned by a library function
- assuming the value has mode MODE. */
-
-#define LIBCALL_VALUE(MODE) gen_rtx_REG ((MODE), 0)
-
-/* 1 if N is a possible register number for a function value
- as seen by the caller.
- On 80960, returns are in g0..g3 */
-
-#define FUNCTION_VALUE_REGNO_P(N) ((N) == 0)
-
-/* 1 if N is a possible register number for function argument passing.
- On 80960, parameters are passed in g0..g11 */
-
-#define FUNCTION_ARG_REGNO_P(N) ((N) < 12)
-
-/* Perform any needed actions needed for a function that is receiving a
- variable number of arguments.
-
- CUM is as above.
-
- MODE and TYPE are the mode and type of the current parameter.
-
- PRETEND_SIZE is a variable that should be set to the amount of stack
- that must be pushed by the prolog to pretend that our caller pushed
- it.
-
- Normally, this macro will push all remaining incoming registers on the
- stack and set PRETEND_SIZE to the length of the registers pushed. */
-
-#define SETUP_INCOMING_VARARGS(CUM,MODE,TYPE,PRETEND_SIZE,NO_RTL) \
- i960_setup_incoming_varargs(&CUM,MODE,TYPE,&PRETEND_SIZE,NO_RTL)
-
-/* Implement `va_start' for varargs and stdarg. */
-#define EXPAND_BUILTIN_VA_START(valist, nextarg) \
- i960_va_start (valist, nextarg)
-
-/* Implement `va_arg'. */
-#define EXPAND_BUILTIN_VA_ARG(valist, type) \
- i960_va_arg (valist, type)
-\f
-/* Define a data type for recording info about an argument list
- during the scan of that argument list. This data type should
- hold all necessary information about the function itself
- and about the args processed so far, enough to enable macros
- such as FUNCTION_ARG to determine where the next arg should go.
-
- On 80960, this is two integers, which count the number of register
- parameters and the number of stack parameters seen so far. */
-
-struct cum_args { int ca_nregparms; int ca_nstackparms; };
-
-#define CUMULATIVE_ARGS struct cum_args
-
-/* Define the number of registers that can hold parameters.
- This macro is used only in macro definitions below and/or i960.c. */
-#define NPARM_REGS 12
-
-/* Define how to round to the next parameter boundary.
- This macro is used only in macro definitions below and/or i960.c. */
-#define ROUND_PARM(X, MULTIPLE_OF) \
- ((((X) + (MULTIPLE_OF) - 1) / (MULTIPLE_OF)) * MULTIPLE_OF)
-
-/* Initialize a variable CUM of type CUMULATIVE_ARGS
- for a call to a function whose data type is FNTYPE.
- For a library call, FNTYPE is 0.
-
- On 80960, the offset always starts at 0; the first parm reg is g0. */
-
-#define INIT_CUMULATIVE_ARGS(CUM, FNTYPE, LIBNAME, INDIRECT, N_NAMED_ARGS) \
- ((CUM).ca_nregparms = 0, (CUM).ca_nstackparms = 0)
-
-/* Update the data in CUM to advance over an argument
- of mode MODE and data type TYPE.
- CUM should be advanced to align with the data type accessed and
- also the size of that data type in # of regs.
- (TYPE is null for libcalls where that information may not be available.) */
-
-#define FUNCTION_ARG_ADVANCE(CUM, MODE, TYPE, NAMED) \
- i960_function_arg_advance(&CUM, MODE, TYPE, NAMED)
-
-/* Indicate the alignment boundary for an argument of the specified mode and
- type. */
-#define FUNCTION_ARG_BOUNDARY(MODE, TYPE) \
- (((TYPE) != 0) \
- ? ((TYPE_ALIGN (TYPE) <= PARM_BOUNDARY) \
- ? PARM_BOUNDARY \
- : TYPE_ALIGN (TYPE)) \
- : ((GET_MODE_ALIGNMENT (MODE) <= PARM_BOUNDARY) \
- ? PARM_BOUNDARY \
- : GET_MODE_ALIGNMENT (MODE)))
-
-/* Determine where to put an argument to a function.
- Value is zero to push the argument on the stack,
- or a hard register in which to store the argument.
-
- MODE is the argument's machine mode.
- TYPE is the data type of the argument (as a tree).
- This is null for libcalls where that information may
- not be available.
- CUM is a variable of type CUMULATIVE_ARGS which gives info about
- the preceding args and about the function being called.
- NAMED is nonzero if this argument is a named parameter
- (otherwise it is an extra parameter matching an ellipsis). */
-
-#define FUNCTION_ARG(CUM, MODE, TYPE, NAMED) \
- i960_function_arg(&CUM, MODE, TYPE, NAMED)
-
-/* Define how to find the value returned by a function.
- VALTYPE is the data type of the value (as a tree).
- If the precise function being called is known, FUNC is its FUNCTION_DECL;
- otherwise, FUNC is 0. */
-
-#define FUNCTION_VALUE(TYPE, FUNC) \
- gen_rtx_REG (TYPE_MODE (TYPE), 0)
-
-/* Force aggregates and objects larger than 16 bytes to be returned in memory,
- since we only have 4 registers available for return values. */
-
-#define RETURN_IN_MEMORY(TYPE) \
- (TYPE_MODE (TYPE) == BLKmode || int_size_in_bytes (TYPE) > 16)
-
-/* Don't default to pcc-struct-return, because we have already specified
- exactly how to return structures in the RETURN_IN_MEMORY macro. */
-#define DEFAULT_PCC_STRUCT_RETURN 0
-
-/* For an arg passed partly in registers and partly in memory,
- this is the number of registers used.
- This never happens on 80960. */
-
-#define FUNCTION_ARG_PARTIAL_NREGS(CUM, MODE, TYPE, NAMED) 0
-\f
-/* Output the label for a function definition.
- This handles leaf functions and a few other things for the i960. */
-
-#define ASM_DECLARE_FUNCTION_NAME(FILE, NAME, DECL) \
- i960_function_name_declare (FILE, NAME, DECL)
-
-/* Output assembler code to FILE to increment profiler label # LABELNO
- for profiling a function entry. */
-
-#define FUNCTION_PROFILER(FILE, LABELNO) \
- output_function_profiler ((FILE), (LABELNO));
-
-/* EXIT_IGNORE_STACK should be nonzero if, when returning from a function,
- the stack pointer does not matter. The value is tested only in
- functions that have frame pointers.
- No definition is equivalent to always zero. */
-
-#define EXIT_IGNORE_STACK 1
-\f
-/* Addressing modes, and classification of registers for them. */
-
-/* Macros to check register numbers against specific register classes. */
-
-/* These assume that REGNO is a hard or pseudo reg number.
- They give nonzero only if REGNO is a hard reg of the suitable class
- or a pseudo reg currently allocated to a suitable hard reg.
- Since they use reg_renumber, they are safe only once reg_renumber
- has been allocated, which happens in local-alloc.c. */
-
-#define REGNO_OK_FOR_INDEX_P(REGNO) \
- ((REGNO) < 32 || (unsigned) reg_renumber[REGNO] < 32)
-#define REGNO_OK_FOR_BASE_P(REGNO) \
- ((REGNO) < 32 || (unsigned) reg_renumber[REGNO] < 32)
-#define REGNO_OK_FOR_FP_P(REGNO) \
- ((REGNO) < 36 || (unsigned) reg_renumber[REGNO] < 36)
-
-/* Now macros that check whether X is a register and also,
- strictly, whether it is in a specified class.
-
- These macros are specific to the 960, and may be used only
- in code for printing assembler insns and in conditions for
- define_optimization. */
-
-/* 1 if X is an fp register. */
-
-#define FP_REG_P(X) (REGNO (X) >= 32 && REGNO (X) < 36)
-
-/* Maximum number of registers that can appear in a valid memory address. */
-#define MAX_REGS_PER_ADDRESS 2
-
-#define CONSTANT_ADDRESS_P(X) \
- (GET_CODE (X) == LABEL_REF || GET_CODE (X) == SYMBOL_REF \
- || GET_CODE (X) == CONST_INT || GET_CODE (X) == CONST \
- || GET_CODE (X) == HIGH)
-
-/* LEGITIMATE_CONSTANT_P is nonzero if the constant value X
- is a legitimate general operand.
- It is given that X satisfies CONSTANT_P.
-
- Anything but a CONST_DOUBLE can be made to work, excepting 0.0 and 1.0.
-
- ??? This probably should be defined to 1. */
-
-#define LEGITIMATE_CONSTANT_P(X) \
- ((GET_CODE (X) != CONST_DOUBLE) || fp_literal ((X), GET_MODE (X)))
-
-/* The macros REG_OK_FOR..._P assume that the arg is a REG rtx
- and check its validity for a certain class.
- We have two alternate definitions for each of them.
- The usual definition accepts all pseudo regs; the other rejects
- them unless they have been allocated suitable hard regs.
- The symbol REG_OK_STRICT causes the latter definition to be used.
-
- Most source files want to accept pseudo regs in the hope that
- they will get allocated to the class that the insn wants them to be in.
- Source files for reload pass need to be strict.
- After reload, it makes no difference, since pseudo regs have
- been eliminated by then. */
-
-#ifndef REG_OK_STRICT
-
-/* Nonzero if X is a hard reg that can be used as an index
- or if it is a pseudo reg. */
-#define REG_OK_FOR_INDEX_P(X) \
- (REGNO (X) < 32 || REGNO (X) >= FIRST_PSEUDO_REGISTER)
-/* Nonzero if X is a hard reg that can be used as a base reg
- or if it is a pseudo reg. */
-#define REG_OK_FOR_BASE_P(X) \
- (REGNO (X) < 32 || REGNO (X) >= FIRST_PSEUDO_REGISTER)
-
-#define REG_OK_FOR_INDEX_P_STRICT(X) REGNO_OK_FOR_INDEX_P (REGNO (X))
-#define REG_OK_FOR_BASE_P_STRICT(X) REGNO_OK_FOR_BASE_P (REGNO (X))
-
-#else
-
-/* Nonzero if X is a hard reg that can be used as an index. */
-#define REG_OK_FOR_INDEX_P(X) REGNO_OK_FOR_INDEX_P (REGNO (X))
-/* Nonzero if X is a hard reg that can be used as a base reg. */
-#define REG_OK_FOR_BASE_P(X) REGNO_OK_FOR_BASE_P (REGNO (X))
-
-#endif
-\f
-/* GO_IF_LEGITIMATE_ADDRESS recognizes an RTL expression
- that is a valid memory address for an instruction.
- The MODE argument is the machine mode for the MEM expression
- that wants to use this address.
-
- On 80960, legitimate addresses are:
- base ld (g0),r0
- disp (12 or 32 bit) ld foo,r0
- base + index ld (g0)[g1*1],r0
- base + displ ld 0xf00(g0),r0
- base + index*scale + displ ld 0xf00(g0)[g1*4],r0
- index*scale + base ld (g0)[g1*4],r0
- index*scale + displ ld 0xf00[g1*4],r0
- index*scale ld [g1*4],r0
- index + base + displ ld 0xf00(g0)[g1*1],r0
-
- In each case, scale can be 1, 2, 4, 8, or 16. */
-
-/* Returns 1 if the scale factor of an index term is valid. */
-#define SCALE_TERM_P(X) \
- (GET_CODE (X) == CONST_INT \
- && (INTVAL (X) == 1 || INTVAL (X) == 2 || INTVAL (X) == 4 \
- || INTVAL(X) == 8 || INTVAL (X) == 16))
-
-
-#ifdef REG_OK_STRICT
-#define GO_IF_LEGITIMATE_ADDRESS(MODE, X, ADDR) \
- { if (legitimate_address_p (MODE, X, 1)) goto ADDR; }
-#else
-#define GO_IF_LEGITIMATE_ADDRESS(MODE, X, ADDR) \
- { if (legitimate_address_p (MODE, X, 0)) goto ADDR; }
-#endif
-\f
-/* Try machine-dependent ways of modifying an illegitimate address
- to be legitimate. If we find one, return the new, valid address.
- This macro is used in only one place: `memory_address' in explow.c.
-
- OLDX is the address as it was before break_out_memory_refs was called.
- In some cases it is useful to look at this to decide what needs to be done.
-
- MODE and WIN are passed so that this macro can use
- GO_IF_LEGITIMATE_ADDRESS.
-
- It is always safe for this macro to do nothing. It exists to recognize
- opportunities to optimize the output. */
-
-/* On 80960, convert non-canonical addresses to canonical form. */
-
-#define LEGITIMIZE_ADDRESS(X, OLDX, MODE, WIN) \
-{ rtx orig_x = (X); \
- (X) = legitimize_address (X, OLDX, MODE); \
- if ((X) != orig_x && memory_address_p (MODE, X)) \
- goto WIN; }
-
-/* Go to LABEL if ADDR (a legitimate address expression)
- has an effect that depends on the machine mode it is used for.
- On the 960 this is never true. */
-
-#define GO_IF_MODE_DEPENDENT_ADDRESS(ADDR,LABEL)
-\f
-/* Specify the machine mode that this machine uses
- for the index in the tablejump instruction. */
-#define CASE_VECTOR_MODE SImode
-
-/* Define as C expression which evaluates to nonzero if the tablejump
- instruction expects the table to contain offsets from the address of the
- table.
- Do not define this if the table should contain absolute addresses. */
-/* #define CASE_VECTOR_PC_RELATIVE 1 */
-
-/* Define this as 1 if `char' should by default be signed; else as 0. */
-#define DEFAULT_SIGNED_CHAR 0
-
-/* Max number of bytes we can move from memory to memory
- in one reasonably fast instruction. */
-#define MOVE_MAX 16
-
-/* Define if operations between registers always perform the operation
- on the full register even if a narrower mode is specified. */
-#define WORD_REGISTER_OPERATIONS
-
-/* Define if loading in MODE, an integral mode narrower than BITS_PER_WORD
- will either zero-extend or sign-extend. The value of this macro should
- be the code that says which one of the two operations is implicitly
- done, NIL if none. */
-#define LOAD_EXTEND_OP(MODE) ZERO_EXTEND
-
-/* Nonzero if access to memory by bytes is no faster than for words.
- Value changed to 1 after reports of poor bit-field code with g++.
- Indications are that code is usually as good, sometimes better. */
-
-#define SLOW_BYTE_ACCESS 1
-
-/* Define this to be nonzero if shift instructions ignore all but the low-order
- few bits. */
-#define SHIFT_COUNT_TRUNCATED 0
-
-/* Value is 1 if truncating an integer of INPREC bits to OUTPREC bits
- is done just by pretending it is already truncated. */
-#define TRULY_NOOP_TRUNCATION(OUTPREC, INPREC) 1
-
-/* Specify the machine mode that pointers have.
- After generation of rtl, the compiler makes no further distinction
- between pointers and any other objects of this machine mode. */
-#define Pmode SImode
-
-/* Specify the widest mode that BLKmode objects can be promoted to */
-#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (TImode)
-\f
-/* These global variables are used to pass information between
- cc setter and cc user at insn emit time. */
-
-extern struct rtx_def *i960_compare_op0, *i960_compare_op1;
-
-/* Given a comparison code (EQ, NE, etc.) and the first operand of a COMPARE,
- return the mode to be used for the comparison. For floating-point, CCFPmode
- should be used. CC_NOOVmode should be used when the first operand is a
- PLUS, MINUS, or NEG. CCmode should be used when no special processing is
- needed. */
-#define SELECT_CC_MODE(OP,X,Y) select_cc_mode (OP, X)
-
-/* A function address in a call instruction is a byte address
- (for indexing purposes) so give the MEM rtx a byte's mode. */
-#define FUNCTION_MODE SImode
-
-/* Define this if addresses of constant functions
- shouldn't be put through pseudo regs where they can be cse'd.
- Desirable on machines where ordinary constants are expensive
- but a CALL with constant address is cheap. */
-#define NO_FUNCTION_CSE
-
-/* Use memcpy, etc. instead of bcopy. */
-
-#ifndef WIND_RIVER
-#define TARGET_MEM_FUNCTIONS 1
-#endif
-\f
-/* Control the assembler format that we output. */
-
-/* Output to assembler file text saying following lines
- may contain character constants, extra white space, comments, etc. */
-
-#define ASM_APP_ON ""
-
-/* Output to assembler file text saying following lines
- no longer contain unusual constructs. */
-
-#define ASM_APP_OFF ""
-
-/* Output before read-only data. */
-
-#define TEXT_SECTION_ASM_OP "\t.text"
-
-/* Output before writable data. */
-
-#define DATA_SECTION_ASM_OP "\t.data"
-
-/* How to refer to registers in assembler output.
- This sequence is indexed by compiler's hard-register-number (see above). */
-
-#define REGISTER_NAMES { \
- "g0", "g1", "g2", "g3", "g4", "g5", "g6", "g7", \
- "g8", "g9", "g10", "g11", "g12", "g13", "g14", "fp", \
- "pfp","sp", "rip", "r3", "r4", "r5", "r6", "r7", \
- "r8", "r9", "r10", "r11", "r12", "r13", "r14", "r15", \
- "fp0","fp1","fp2", "fp3", "cc", "fake" }
-
-/* How to renumber registers for dbx and gdb.
- In the 960 encoding, g0..g15 are registers 16..31. */
-
-#define DBX_REGISTER_NUMBER(REGNO) \
- (((REGNO) < 16) ? (REGNO) + 16 \
- : (((REGNO) > 31) ? (REGNO) : (REGNO) - 16))
-
-/* Don't emit dbx records longer than this. This is an arbitrary value. */
-#define DBX_CONTIN_LENGTH 1500
-
-/* This is how to output a note to DBX telling it the line number
- to which the following sequence of instructions corresponds. */
-
-#define ASM_OUTPUT_SOURCE_LINE(FILE, LINE, COUNTER) \
-{ if (write_symbols == SDB_DEBUG) { \
- fprintf ((FILE), "\t.ln %d\n", \
- (sdb_begin_function_line \
- ? (LINE) - sdb_begin_function_line : 1)); \
- } else if (write_symbols == DBX_DEBUG) { \
- fprintf((FILE),"\t.stabd 68,0,%d\n",(LINE)); \
- } }
-
-/* Globalizing directive for a label. */
-#define GLOBAL_ASM_OP "\t.globl "
-
-/* The prefix to add to user-visible assembler symbols. */
-
-#define USER_LABEL_PREFIX "_"
-
-/* This is how to store into the string LABEL
- the symbol_ref name of an internal numbered label where
- PREFIX is the class of label and NUM is the number within the class.
- This is suitable for output with `assemble_name'. */
-
-#define ASM_GENERATE_INTERNAL_LABEL(LABEL,PREFIX,NUM) \
- sprintf (LABEL, "*%s%lu", PREFIX, (unsigned long)(NUM))
-
-#define ASM_OUTPUT_REG_PUSH(FILE,REGNO) \
- fprintf (FILE, "\tst\t%s,(sp)\n\taddo\t4,sp,sp\n", reg_names[REGNO])
-
-/* This is how to output an insn to pop a register from the stack.
- It need not be very fast code. */
-
-#define ASM_OUTPUT_REG_POP(FILE,REGNO) \
- fprintf (FILE, "\tsubo\t4,sp,sp\n\tld\t(sp),%s\n", reg_names[REGNO])
-
-/* This is how to output an element of a case-vector that is absolute. */
-
-#define ASM_OUTPUT_ADDR_VEC_ELT(FILE, VALUE) \
- fprintf (FILE, "\t.word L%d\n", VALUE)
-
-/* This is how to output an element of a case-vector that is relative. */
-
-#define ASM_OUTPUT_ADDR_DIFF_ELT(FILE, BODY, VALUE, REL) \
- fprintf (FILE, "\t.word L%d-L%d\n", VALUE, REL)
-
-/* This is how to output an assembler line that says to advance the
- location counter to a multiple of 2**LOG bytes. */
-
-#define ASM_OUTPUT_ALIGN(FILE,LOG) \
- fprintf (FILE, "\t.align %d\n", (LOG))
-
-#define ASM_OUTPUT_SKIP(FILE,SIZE) \
- fprintf (FILE, "\t.space %d\n", (int)(SIZE))
-
-/* This says how to output an assembler line
- to define a global common symbol. */
-
-/* For common objects, output unpadded size... gld960 & lnk960 both
- have code to align each common object at link time. Also, if size
- is 0, treat this as a declaration, not a definition - i.e.,
- do nothing at all. */
-
-#define ASM_OUTPUT_COMMON(FILE, NAME, SIZE, ROUNDED) \
-{ if ((SIZE) != 0) \
- { \
- fputs (".globl ", (FILE)), \
- assemble_name ((FILE), (NAME)), \
- fputs ("\n.comm ", (FILE)), \
- assemble_name ((FILE), (NAME)), \
- fprintf ((FILE), ",%d\n", (int)(SIZE)); \
- } \
-}
-
-/* This says how to output an assembler line to define a local common symbol.
- Output unpadded size, with request to linker to align as requested.
- 0 size should not be possible here. */
-
-#define ASM_OUTPUT_ALIGNED_LOCAL(FILE, NAME, SIZE, ALIGN) \
-( fputs (".bss\t", (FILE)), \
- assemble_name ((FILE), (NAME)), \
- fprintf ((FILE), ",%d,%d\n", (int)(SIZE), \
- (floor_log2 ((ALIGN) / BITS_PER_UNIT))))
-
-/* A C statement (sans semicolon) to output to the stdio stream
- FILE the assembler definition of uninitialized global DECL named
- NAME whose size is SIZE bytes and alignment is ALIGN bytes.
- Try to use asm_output_aligned_bss to implement this macro. */
-
-#define ASM_OUTPUT_ALIGNED_BSS(FILE, DECL, NAME, SIZE, ALIGN) \
- do { \
- ASM_OUTPUT_ALIGNED_LOCAL (FILE, NAME, SIZE, ALIGN); \
- } while (0)
-
-/* Output text for an #ident directive. */
-#define ASM_OUTPUT_IDENT(FILE, STR) fprintf(FILE, "\t# %s\n", STR);
-
-/* Align code to 8 byte boundary if TARGET_CODE_ALIGN is true. */
-
-#define LABEL_ALIGN_AFTER_BARRIER(LABEL) (TARGET_CODE_ALIGN ? 3 : 0)
-
-\f
-/* Print operand X (an rtx) in assembler syntax to file FILE.
- CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified.
- For `%' followed by punctuation, CODE is the punctuation and X is null. */
-
-#define PRINT_OPERAND(FILE, X, CODE) \
- i960_print_operand (FILE, X, CODE);
-
-/* Print a memory address as an operand to reference that memory location. */
-
-#define PRINT_OPERAND_ADDRESS(FILE, ADDR) \
- i960_print_operand_addr (FILE, ADDR)
-
-/* Determine which codes are valid without a following integer. These must
- not be alphabetic (the characters are chosen so that
- PRINT_OPERAND_PUNCT_VALID_P translates into a simple range change when
- using ASCII). */
-
-#define PRINT_OPERAND_PUNCT_VALID_P(CODE) ((CODE) == '+')
-\f
-/* Output assembler code for a block containing the constant parts
- of a trampoline, leaving space for the variable parts. */
-
-/* On the i960, the trampoline contains three instructions:
- ldconst _function, r4
- ldconst static addr, g12
- jump (r4) */
-
-#define TRAMPOLINE_TEMPLATE(FILE) \
-{ \
- assemble_aligned_integer (UNITS_PER_WORD, GEN_INT (0x8C203000)); \
- assemble_aligned_integer (UNITS_PER_WORD, GEN_INT (0x00000000)); \
- assemble_aligned_integer (UNITS_PER_WORD, GEN_INT (0x8CE03000)); \
- assemble_aligned_integer (UNITS_PER_WORD, GEN_INT (0x00000000)); \
- assemble_aligned_integer (UNITS_PER_WORD, GEN_INT (0x84212000)); \
-}
-
-/* Length in units of the trampoline for entering a nested function. */
-
-#define TRAMPOLINE_SIZE 20
-
-/* Emit RTL insns to initialize the variable parts of a trampoline.
- FNADDR is an RTX for the address of the function's pure code.
- CXT is an RTX for the static chain value for the function. */
-
-#define INITIALIZE_TRAMPOLINE(TRAMP, FNADDR, CXT) \
-{ \
- emit_move_insn (gen_rtx_MEM (SImode, plus_constant (TRAMP, 4)), FNADDR); \
- emit_move_insn (gen_rtx_MEM (SImode, plus_constant (TRAMP, 12)), CXT); \
-}
-
-/* Generate RTL to flush the register windows so as to make arbitrary frames
- available. */
-#define SETUP_FRAME_ADDRESSES() \
- emit_insn (gen_flush_register_windows ())
-
-#define BUILTIN_SETJMP_FRAME_VALUE hard_frame_pointer_rtx
-
-#if 0
-/* Promote char and short arguments to ints, when want compatibility with
- the iC960 compilers. */
-
-/* ??? In order for this to work, all users would need to be changed
- to test the value of the macro at run time. */
-#define PROMOTE_PROTOTYPES TARGET_CLEAN_LINKAGE
-/* ??? This does not exist. */
-#define PROMOTE_RETURN TARGET_CLEAN_LINKAGE
-#endif
-
-/* Instruction type definitions. Used to alternate instructions types for
- better performance on the C series chips. */
-
-enum insn_types { I_TYPE_REG, I_TYPE_MEM, I_TYPE_CTRL };
-
-/* Holds the insn type of the last insn output to the assembly file. */
-
-extern enum insn_types i960_last_insn_type;
-
-/* Parse opcodes, and set the insn last insn type based on them. */
-
-#define ASM_OUTPUT_OPCODE(FILE, INSN) i960_scan_opcode (INSN)
-
-/* Table listing what rtl codes each predicate in i960.c will accept. */
-
-#define PREDICATE_CODES \
- {"fpmove_src_operand", {CONST_INT, CONST_DOUBLE, CONST, SYMBOL_REF, \
- LABEL_REF, SUBREG, REG, MEM}}, \
- {"arith_operand", {SUBREG, REG, CONST_INT}}, \
- {"logic_operand", {SUBREG, REG, CONST_INT}}, \
- {"fp_arith_operand", {SUBREG, REG, CONST_DOUBLE}}, \
- {"signed_arith_operand", {SUBREG, REG, CONST_INT}}, \
- {"literal", {CONST_INT}}, \
- {"fp_literal_one", {CONST_DOUBLE}}, \
- {"fp_literal_double", {CONST_DOUBLE}}, \
- {"fp_literal", {CONST_DOUBLE}}, \
- {"signed_literal", {CONST_INT}}, \
- {"symbolic_memory_operand", {SUBREG, MEM}}, \
- {"eq_or_neq", {EQ, NE}}, \
- {"arith32_operand", {SUBREG, REG, LABEL_REF, SYMBOL_REF, CONST_INT, \
- CONST_DOUBLE, CONST}}, \
- {"power2_operand", {CONST_INT}}, \
- {"cmplpower2_operand", {CONST_INT}},
-
-/* Defined in reload.c, and used in insn-recog.c. */
-
-extern int rtx_equal_function_value_matters;
+++ /dev/null
-;;- Machine description for Intel 80960 chip for GNU C compiler
-;; Copyright (C) 1992, 1995, 1998, 2001 Free Software Foundation, Inc.
-;; Contributed by Steven McGeady, Intel Corp.
-;; Additional work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
-;; Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
-
-;; This file is part of GCC.
-
-;; GCC is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GCC is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GCC; see the file COPYING. If not, write to
-;; the Free Software Foundation, 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;- See file "rtl.def" for documentation on define_insn, match_*, et. al.
-\f
-;; There are very few (4) 'f' registers, they can't be loaded/stored from/to
-;; memory, and some instructions explicitly require them, so we get better
-;; code by discouraging pseudo-registers from being allocated to them.
-;; However, we do want to allow all patterns which can store to them to
-;; include them in their constraints, so we always use '*f' in a destination
-;; constraint except when 'f' is the only alternative.
-\f
-;; Insn attributes which describe the i960.
-
-;; Modscan is not used, since the compiler never emits any of these insns.
-(define_attr "type"
- "move,arith,alu2,mult,div,modscan,load,store,branch,call,address,compare,fpload,fpstore,fpmove,fpcvt,fpcc,fpadd,fpmul,fpdiv,multi,misc"
- (const_string "arith"))
-
-;; Length (in # of insns).
-(define_attr "length" ""
- (cond [(eq_attr "type" "load,fpload")
- (if_then_else (match_operand 1 "symbolic_memory_operand" "")
- (const_int 2)
- (const_int 1))
- (eq_attr "type" "store,fpstore")
- (if_then_else (match_operand 0 "symbolic_memory_operand" "")
- (const_int 2)
- (const_int 1))
- (eq_attr "type" "address")
- (const_int 2)]
- (const_int 1)))
-
-(define_asm_attributes
- [(set_attr "length" "1")
- (set_attr "type" "multi")])
-
-;; (define_function_unit {name} {num-units} {n-users} {test}
-;; {ready-delay} {issue-delay} [{conflict-list}])
-
-;; The integer ALU
-(define_function_unit "alu" 2 0 (eq_attr "type" "arith,compare,move,address") 1 0)
-(define_function_unit "alu" 2 0 (eq_attr "type" "alu2") 2 0)
-(define_function_unit "alu" 2 0 (eq_attr "type" "mult") 5 0)
-(define_function_unit "alu" 2 0 (eq_attr "type" "div") 35 0)
-(define_function_unit "alu" 2 0 (eq_attr "type" "modscan") 3 0)
-
-;; Memory with load-delay of 1 (i.e., 2 cycle load).
-(define_function_unit "memory" 1 0 (eq_attr "type" "load,fpload") 2 0)
-
-;; Floating point operations.
-(define_function_unit "fp" 1 2 (eq_attr "type" "fpmove") 5 0)
-(define_function_unit "fp" 1 2 (eq_attr "type" "fpcvt") 35 0)
-(define_function_unit "fp" 1 2 (eq_attr "type" "fpcc") 10 0)
-(define_function_unit "fp" 1 2 (eq_attr "type" "fpadd") 10 0)
-(define_function_unit "fp" 1 2 (eq_attr "type" "fpmul") 20 0)
-(define_function_unit "fp" 1 2 (eq_attr "type" "fpdiv") 35 0)
-\f
-;; Compare instructions.
-;; This controls RTL generation and register allocation.
-
-;; We generate RTL for comparisons and branches by having the cmpxx
-;; patterns store away the operands. Then, the scc and bcc patterns
-;; emit RTL for both the compare and the branch.
-;;
-;; We start with the DEFINE_EXPANDs, then DEFINE_INSNs to match
-;; the patterns. Finally, we have the DEFINE_SPLITs for some of the scc
-;; insns that actually require more than one machine instruction.
-
-;; Put cmpsi first because it is expected to be the most common.
-
-(define_expand "cmpsi"
- [(set (reg:CC 36)
- (compare:CC (match_operand:SI 0 "nonimmediate_operand" "")
- (match_operand:SI 1 "general_operand" "")))]
- ""
- "
-{
- i960_compare_op0 = operands[0];
- i960_compare_op1 = operands[1];
- DONE;
-}")
-
-(define_expand "cmpdf"
- [(set (reg:CC 36)
- (compare:CC (match_operand:DF 0 "register_operand" "r")
- (match_operand:DF 1 "nonmemory_operand" "rGH")))]
- "TARGET_NUMERICS"
- "
-{
- i960_compare_op0 = operands[0];
- i960_compare_op1 = operands[1];
- DONE;
-}")
-
-(define_expand "cmpsf"
- [(set (reg:CC 36)
- (compare:CC (match_operand:SF 0 "register_operand" "r")
- (match_operand:SF 1 "nonmemory_operand" "rGH")))]
- "TARGET_NUMERICS"
- "
-{
- i960_compare_op0 = operands[0];
- i960_compare_op1 = operands[1];
- DONE;
-}")
-
-;; Now the DEFINE_INSNs for the compare and scc cases. First the compares.
-
-(define_insn ""
- [(set (reg:CC 36)
- (compare:CC (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "arith_operand" "dI")))]
- ""
- "cmpi %0,%1"
- [(set_attr "type" "compare")])
-
-(define_insn ""
- [(set (reg:CC_UNS 36)
- (compare:CC_UNS (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "arith_operand" "dI")))]
- ""
- "cmpo %0,%1"
- [(set_attr "type" "compare")])
-
-(define_insn ""
- [(set (reg:CC 36)
- (compare:CC (match_operand:DF 0 "register_operand" "r")
- (match_operand:DF 1 "nonmemory_operand" "rGH")))]
- "TARGET_NUMERICS"
- "cmprl %0,%1"
- [(set_attr "type" "fpcc")])
-
-(define_insn ""
- [(set (reg:CC 36)
- (compare:CC (match_operand:SF 0 "register_operand" "r")
- (match_operand:SF 1 "nonmemory_operand" "rGH")))]
- "TARGET_NUMERICS"
- "cmpr %0,%1"
- [(set_attr "type" "fpcc")])
-
-;; Instruction definitions for branch-on-bit-set and clear insns.
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (ne (sign_extract:SI (match_operand:SI 0 "register_operand" "d")
- (const_int 1)
- (match_operand:SI 1 "arith_operand" "dI"))
- (const_int 0))
- (label_ref (match_operand 2 "" ""))
- (pc)))]
- ""
- "bbs%+ %1,%0,%l2"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (eq (sign_extract:SI (match_operand:SI 0 "register_operand" "d")
- (const_int 1)
- (match_operand:SI 1 "arith_operand" "dI"))
- (const_int 0))
- (label_ref (match_operand 2 "" ""))
- (pc)))]
- ""
- "bbc%+ %1,%0,%l2"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (ne (zero_extract:SI (match_operand:SI 0 "register_operand" "d")
- (const_int 1)
- (match_operand:SI 1 "arith_operand" "dI"))
- (const_int 0))
- (label_ref (match_operand 2 "" ""))
- (pc)))]
- ""
- "bbs%+ %1,%0,%l2"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (eq (zero_extract:SI (match_operand:SI 0 "register_operand" "d")
- (const_int 1)
- (match_operand:SI 1 "arith_operand" "dI"))
- (const_int 0))
- (label_ref (match_operand 2 "" ""))
- (pc)))]
- ""
- "bbc%+ %1,%0,%l2"
- [(set_attr "type" "branch")])
-
-;; ??? These will never match. The LOG_LINKs necessary to make these match
-;; are not created by flow. These remain as a reminder to make this work
-;; some day.
-
-(define_insn ""
- [(set (reg:CC 36)
- (compare (match_operand:SI 0 "arith_operand" "d")
- (match_operand:SI 1 "arith_operand" "+d")))
- (set (match_dup 1) (plus:SI (match_dup 1) (const_int 1)))]
- "0"
- "cmpinci %0,%1"
- [(set_attr "type" "compare")])
-
-(define_insn ""
- [(set (reg:CC_UNS 36)
- (compare (match_operand:SI 0 "arith_operand" "d")
- (match_operand:SI 1 "arith_operand" "+d")))
- (set (match_dup 1) (plus:SI (match_dup 1) (const_int 1)))]
- "0"
- "cmpinco %0,%1"
- [(set_attr "type" "compare")])
-
-(define_insn ""
- [(set (reg:CC 36)
- (compare (match_operand:SI 0 "arith_operand" "d")
- (match_operand:SI 1 "arith_operand" "+d")))
- (set (match_dup 1) (minus:SI (match_dup 1) (const_int 1)))]
- "0"
- "cmpdeci %0,%1"
- [(set_attr "type" "compare")])
-
-(define_insn ""
- [(set (reg:CC_UNS 36)
- (compare (match_operand:SI 0 "arith_operand" "d")
- (match_operand:SI 1 "arith_operand" "+d")))
- (set (match_dup 1) (minus:SI (match_dup 1) (const_int 1)))]
- "0"
- "cmpdeco %0,%1"
- [(set_attr "type" "compare")])
-\f
-;; Templates to store result of condition.
-;; '1' is stored if condition is true.
-;; '0' is stored if condition is false.
-;; These should use predicate "general_operand", since
-;; gcc seems to be creating mem references which use these
-;; templates.
-
-(define_expand "seq"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (eq:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (EQ, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sne"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (ne:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (NE, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sgt"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (gt:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (GT, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sgtu"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (gtu:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (GTU, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "slt"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (lt:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (LT, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sltu"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (ltu:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (LTU, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sge"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (ge:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (GE, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sgeu"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (geu:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (GEU, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sle"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (le:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (LE, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_expand "sleu"
- [(set (match_operand:SI 0 "general_operand" "=d")
- (leu:SI (match_dup 1) (const_int 0)))]
- ""
- "
-{
- operands[1] = gen_compare_reg (LEU, i960_compare_op0, i960_compare_op1);
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d")
- (eq:SI (match_operand:SI 1 "register_operand" "d") (const_int 0)))]
- ""
- "shro %1,1,%0"
- [(set_attr "type" "alu2")])
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d")
- (match_operator:SI 1 "comparison_operator" [(reg:CC 36) (const_int 0)]))]
- ""
- "test%C1 %0"
- [(set_attr "type" "compare")])
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d")
- (match_operator:SI 1 "comparison_operator" [(reg:CC_UNS 36) (const_int 0)]))]
- ""
- "test%C1 %0"
- [(set_attr "type" "compare")])
-\f
-;; These control RTL generation for conditional jump insns
-;; and match them for register allocation.
-
-(define_expand "beq"
- [(set (pc)
- (if_then_else (eq (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (EQ, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "bne"
- [(set (pc)
- (if_then_else (ne (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (NE, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "bgt"
- [(set (pc)
- (if_then_else (gt (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (GT, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "bgtu"
- [(set (pc)
- (if_then_else (gtu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (GTU, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "blt"
- [(set (pc)
- (if_then_else (lt (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (LT, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "bltu"
- [(set (pc)
- (if_then_else (ltu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (LTU, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "bge"
- [(set (pc)
- (if_then_else (ge (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (GE, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "bgeu"
- [(set (pc)
- (if_then_else (geu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (GEU, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "ble"
- [(set (pc)
- (if_then_else (le (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (LE, i960_compare_op0, i960_compare_op1); }")
-
-(define_expand "bleu"
- [(set (pc)
- (if_then_else (leu (match_dup 1)
- (const_int 0))
- (label_ref (match_operand 0 "" ""))
- (pc)))]
- ""
- "
-{ operands[1] = gen_compare_reg (LEU, i960_compare_op0, i960_compare_op1); }")
-\f
-;; Now the normal branch insns (forward and reverse).
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 0 "comparison_operator"
- [(reg:CC 36) (const_int 0)])
- (label_ref (match_operand 1 "" ""))
- (pc)))]
- ""
- "b%C0%+ %l1"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 0 "comparison_operator"
- [(reg:CC 36) (const_int 0)])
- (pc)
- (label_ref (match_operand 1 "" ""))))]
- ""
- "b%I0%+ %l1"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 0 "comparison_operator"
- [(reg:CC_UNS 36) (const_int 0)])
- (label_ref (match_operand 1 "" ""))
- (pc)))]
- ""
- "b%C0%+ %l1"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else (match_operator 0 "comparison_operator"
- [(reg:CC_UNS 36) (const_int 0)])
- (pc)
- (label_ref (match_operand 1 "" ""))))]
- ""
- "b%I0%+ %l1"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (match_operator 0 "comparison_operator"
- [(match_operand:SI 1 "arith_operand" "d")
- (match_operand:SI 2 "arith_operand" "dI")])
- (label_ref (match_operand 3 "" ""))
- (pc)))]
- ""
- "cmp%S0%B0%R0%+ %2,%1,%l3"
- [(set_attr "type" "branch")])
-
-(define_insn ""
- [(set (pc)
- (if_then_else
- (match_operator 0 "comparison_operator"
- [(match_operand:SI 1 "arith_operand" "d")
- (match_operand:SI 2 "arith_operand" "dI")])
- (pc)
- (label_ref (match_operand 3 "" ""))))]
- ""
- "cmp%S0%B0%X0%+ %2,%1,%l3"
- [(set_attr "type" "branch")])
-\f
-;; Now the trap instructions. The i960 appears to only have conditional
-;; traps...
-
-(define_insn ("trap")
- [(trap_if (const_int 1) (const_int 0))]
- ""
- "cmpo g0,g0 ; faulte.t")
-
-(define_expand "conditional_trap"
- [(trap_if (match_operator 0 "comparison_operator"
- [(match_dup 2) (const_int 0)])
- (match_operand 1 "const_int_operand" "i"))]
- ""
- "
-{
- operands[2] = gen_compare_reg (GET_CODE (operands[0]),
- i960_compare_op0, i960_compare_op1);
-}")
-
-(define_insn ""
- [(trap_if (match_operator 0 "comparison_operator"
- [(reg:CC 36) (const_int 0)])
- (match_operand 1 "const_int_operand" "i"))]
- ""
- "fault%C0.f")
-
-(define_insn ""
- [(trap_if (match_operator 0 "comparison_operator"
- [(reg:CC_UNS 36) (const_int 0)])
- (match_operand 1 "const_int_operand" "i"))]
- ""
- "fault%C0.f")
-\f
-;; Normal move instructions.
-;; This code is based on the sparc machine description.
-
-(define_expand "movsi"
- [(set (match_operand:SI 0 "general_operand" "")
- (match_operand:SI 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, SImode))
- DONE;
-}")
-
-;; The store case can not be separate, because reload may convert a register
-;; to register move insn to a store (or load) insn without rerecognizing
-;; the insn.
-
-;; The i960 does not have any store constant to memory instruction. However,
-;; the calling convention is defined so that the arg pointer when it is not
-;; overwise being used is zero. Thus, we can handle store zero to memory
-;; by storing an unused arg pointer. The arg pointer will be unused if
-;; current_function_args_size is zero and this is not a stdarg
-;; function. This value of the former variable is not valid until after
-;; all rtl generation is complete, including function inlining (because a
-;; function that doesn't need an arg pointer may be inlined into a function
-;; that does need an arg pointer), so we must also check that
-;; rtx_equal_function_value_matters is zero.
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d,d,d,m")
- (match_operand:SI 1 "general_operand" "dI,i,m,dJ"))]
- "(current_function_args_size == 0
- && current_function_stdarg == 0
- && rtx_equal_function_value_matters == 0)
- && (register_operand (operands[0], SImode)
- || register_operand (operands[1], SImode)
- || operands[1] == const0_rtx)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- {
- if (GET_CODE (operands[1]) == REG)
- return \"lda (%1),%0\";
- else
- return \"lda %1,%0\";
- }
- return \"mov %1,%0\";
- case 1:
- return i960_output_ldconst (operands[0], operands[1]);
- case 2:
- return \"ld %1,%0\";
- case 3:
- if (operands[1] == const0_rtx)
- return \"st g14,%0\";
- return \"st %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,address,load,store")
- (set_attr "length" "*,3,*,*")])
-
-(define_insn ""
- [(set (match_operand:SI 0 "general_operand" "=d,d,d,m")
- (match_operand:SI 1 "general_operand" "dI,i,m,d"))]
- "(current_function_args_size != 0
- || current_function_stdarg != 0
- || rtx_equal_function_value_matters != 0)
- && (register_operand (operands[0], SImode)
- || register_operand (operands[1], SImode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- {
- if (GET_CODE (operands[1]) == REG)
- return \"lda (%1),%0\";
- else
- return \"lda %1,%0\";
- }
- return \"mov %1,%0\";
- case 1:
- return i960_output_ldconst (operands[0], operands[1]);
- case 2:
- return \"ld %1,%0\";
- case 3:
- return \"st %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,address,load,store")
- (set_attr "length" "*,3,*,*")])
-
-(define_expand "movhi"
- [(set (match_operand:HI 0 "general_operand" "")
- (match_operand:HI 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, HImode))
- DONE;
-}")
-
-;; Special pattern for zero stores to memory for functions which don't use
-;; the arg pointer.
-
-;; The store case can not be separate. See above.
-(define_insn ""
- [(set (match_operand:HI 0 "general_operand" "=d,d,d,m")
- (match_operand:HI 1 "general_operand" "dI,i,m,dJ"))]
- "(current_function_args_size == 0
- && current_function_stdarg == 0
- && rtx_equal_function_value_matters == 0)
- && (register_operand (operands[0], HImode)
- || register_operand (operands[1], HImode)
- || operands[1] == const0_rtx)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- {
- if (GET_CODE (operands[1]) == REG)
- return \"lda (%1),%0\";
- else
- return \"lda %1,%0\";
- }
- return \"mov %1,%0\";
- case 1:
- return i960_output_ldconst (operands[0], operands[1]);
- case 2:
- return \"ldos %1,%0\";
- case 3:
- if (operands[1] == const0_rtx)
- return \"stos g14,%0\";
- return \"stos %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,misc,load,store")
- (set_attr "length" "*,3,*,*")])
-
-;; The store case can not be separate. See above.
-(define_insn ""
- [(set (match_operand:HI 0 "general_operand" "=d,d,d,m")
- (match_operand:HI 1 "general_operand" "dI,i,m,d"))]
- "(current_function_args_size != 0
- || current_function_stdarg != 0
- || rtx_equal_function_value_matters != 0)
- && (register_operand (operands[0], HImode)
- || register_operand (operands[1], HImode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- {
- if (GET_CODE (operands[1]) == REG)
- return \"lda (%1),%0\";
- else
- return \"lda %1,%0\";
- }
- return \"mov %1,%0\";
- case 1:
- return i960_output_ldconst (operands[0], operands[1]);
- case 2:
- return \"ldos %1,%0\";
- case 3:
- return \"stos %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,misc,load,store")
- (set_attr "length" "*,3,*,*")])
-
-(define_expand "movqi"
- [(set (match_operand:QI 0 "general_operand" "")
- (match_operand:QI 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, QImode))
- DONE;
-}")
-
-;; The store case can not be separate. See comment above.
-(define_insn ""
- [(set (match_operand:QI 0 "general_operand" "=d,d,d,m")
- (match_operand:QI 1 "general_operand" "dI,i,m,dJ"))]
- "(current_function_args_size == 0
- && current_function_stdarg == 0
- && rtx_equal_function_value_matters == 0)
- && (register_operand (operands[0], QImode)
- || register_operand (operands[1], QImode)
- || operands[1] == const0_rtx)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- {
- if (GET_CODE (operands[1]) == REG)
- return \"lda (%1),%0\";
- else
- return \"lda %1,%0\";
- }
- return \"mov %1,%0\";
- case 1:
- return i960_output_ldconst (operands[0], operands[1]);
- case 2:
- return \"ldob %1,%0\";
- case 3:
- if (operands[1] == const0_rtx)
- return \"stob g14,%0\";
- return \"stob %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,misc,load,store")
- (set_attr "length" "*,3,*,*")])
-
-;; The store case can not be separate. See comment above.
-(define_insn ""
- [(set (match_operand:QI 0 "general_operand" "=d,d,d,m")
- (match_operand:QI 1 "general_operand" "dI,i,m,d"))]
- "(current_function_args_size != 0
- || current_function_stdarg != 0
- || rtx_equal_function_value_matters != 0)
- && (register_operand (operands[0], QImode)
- || register_operand (operands[1], QImode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (i960_last_insn_type == I_TYPE_REG && TARGET_C_SERIES)
- {
- if (GET_CODE (operands[1]) == REG)
- return \"lda (%1),%0\";
- else
- return \"lda %1,%0\";
- }
- return \"mov %1,%0\";
- case 1:
- return i960_output_ldconst (operands[0], operands[1]);
- case 2:
- return \"ldob %1,%0\";
- case 3:
- return \"stob %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,misc,load,store")
- (set_attr "length" "*,3,*,*")])
-
-(define_expand "movdi"
- [(set (match_operand:DI 0 "general_operand" "")
- (match_operand:DI 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, DImode))
- DONE;
-}")
-
-;; The store case can not be separate. See comment above.
-(define_insn ""
- [(set (match_operand:DI 0 "general_operand" "=d,d,d,d,m,o")
- (match_operand:DI 1 "general_operand" "d,I,i,m,d,J"))]
- "(current_function_args_size == 0
- && current_function_stdarg == 0
- && rtx_equal_function_value_matters == 0)
- && (register_operand (operands[0], DImode)
- || register_operand (operands[1], DImode)
- || operands[1] == const0_rtx)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- case 1:
- case 3:
- case 4:
- return i960_output_move_double (operands[0], operands[1]);
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- case 5:
- return i960_output_move_double_zero (operands[0]);
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,load,store,store")])
-
-;; The store case can not be separate. See comment above.
-(define_insn ""
- [(set (match_operand:DI 0 "general_operand" "=d,d,d,d,m")
- (match_operand:DI 1 "general_operand" "d,I,i,m,d"))]
- "(current_function_args_size != 0
- || current_function_stdarg != 0
- || rtx_equal_function_value_matters != 0)
- && (register_operand (operands[0], DImode)
- || register_operand (operands[1], DImode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- case 1:
- case 3:
- case 4:
- return i960_output_move_double (operands[0], operands[1]);
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,load,store")])
-
-(define_insn "*store_unaligned_di_reg"
- [(set (match_operand:DI 0 "general_operand" "=d,m")
- (match_operand:DI 1 "register_operand" "d,d"))
- (clobber (match_scratch:SI 2 "=X,&d"))]
- ""
- "*
-{
- if (which_alternative == 0)
- return i960_output_move_double (operands[0], operands[1]);
-
- operands[3] = gen_rtx_MEM (word_mode, operands[2]);
- operands[4] = adjust_address (operands[3], word_mode, UNITS_PER_WORD);
- return \"lda %0,%2\;st %1,%3\;st %D1,%4\";
-}"
- [(set_attr "type" "move,store")])
-
-(define_expand "movti"
- [(set (match_operand:TI 0 "general_operand" "")
- (match_operand:TI 1 "general_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, TImode))
- DONE;
-}")
-
-;; The store case can not be separate. See comment above.
-(define_insn ""
- [(set (match_operand:TI 0 "general_operand" "=d,d,d,d,m,o")
- (match_operand:TI 1 "general_operand" "d,I,i,m,d,J"))]
- "(current_function_args_size == 0
- && current_function_stdarg == 0
- && rtx_equal_function_value_matters == 0)
- && (register_operand (operands[0], TImode)
- || register_operand (operands[1], TImode)
- || operands[1] == const0_rtx)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- case 1:
- case 3:
- case 4:
- return i960_output_move_quad (operands[0], operands[1]);
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- case 5:
- return i960_output_move_quad_zero (operands[0]);
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,load,store,store")])
-
-;; The store case can not be separate. See comment above.
-(define_insn ""
- [(set (match_operand:TI 0 "general_operand" "=d,d,d,d,m")
- (match_operand:TI 1 "general_operand" "d,I,i,m,d"))]
- "(current_function_args_size != 0
- || current_function_stdarg != 0
- || rtx_equal_function_value_matters != 0)
- && (register_operand (operands[0], TImode)
- || register_operand (operands[1], TImode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- case 1:
- case 3:
- case 4:
- return i960_output_move_quad (operands[0], operands[1]);
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,load,store")])
-
-(define_insn "*store_unaligned_ti_reg"
- [(set (match_operand:TI 0 "general_operand" "=d,m")
- (match_operand:TI 1 "register_operand" "d,d"))
- (clobber (match_scratch:SI 2 "=X,&d"))]
- ""
- "*
-{
- if (which_alternative == 0)
- return i960_output_move_quad (operands[0], operands[1]);
-
- operands[3] = gen_rtx_MEM (word_mode, operands[2]);
- operands[4] = adjust_address (operands[3], word_mode, UNITS_PER_WORD);
- operands[5] = adjust_address (operands[4], word_mode, UNITS_PER_WORD);
- operands[6] = adjust_address (operands[5], word_mode, UNITS_PER_WORD);
- return \"lda %0,%2\;st %1,%3\;st %D1,%4\;st %E1,%5\;st %F1,%6\";
-}"
- [(set_attr "type" "move,store")])
-
-(define_expand "store_multiple"
- [(set (match_operand:SI 0 "" "") ;;- dest
- (match_operand:SI 1 "" "")) ;;- src
- (use (match_operand:SI 2 "" ""))] ;;- nregs
- ""
- "
-{
- int regno;
- int count;
- int offset = 0;
-
- if (GET_CODE (operands[0]) != MEM
- || GET_CODE (operands[1]) != REG
- || GET_CODE (operands[2]) != CONST_INT)
- FAIL;
-
- count = INTVAL (operands[2]);
- if (count > 12)
- FAIL;
-
- regno = REGNO (operands[1]);
- while (count >= 4 && ((regno & 3) == 0))
- {
- emit_move_insn (adjust_address (operands[0], TImode, offset),
- gen_rtx_REG (TImode, regno));
- count -= 4;
- regno += 4;
- offset += 16;
- }
- while (count >= 2 && ((regno & 1) == 0))
- {
- emit_move_insn (adjust_address (operands[0], DImode, offset),
- gen_rtx_REG (DImode, regno));
- count -= 2;
- regno += 2;
- offset += 8;
- }
- while (count > 0)
- {
- emit_move_insn (adjust_address (operands[0], SImode, offset),
- gen_rtx_REG (SImode, regno));
- count -= 1;
- regno += 1;
- offset += 4;
- }
- DONE;
-}")
-\f
-;; Floating point move insns
-
-(define_expand "movdf"
- [(set (match_operand:DF 0 "general_operand" "")
- (match_operand:DF 1 "fpmove_src_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, DFmode))
- DONE;
-}")
-
-(define_insn ""
- [(set (match_operand:DF 0 "general_operand" "=r,*f,d,d,m,o")
- (match_operand:DF 1 "fpmove_src_operand" "r,GH,F,m,d,G"))]
- "(current_function_args_size == 0
- && current_function_stdarg == 0
- && rtx_equal_function_value_matters == 0)
- && (register_operand (operands[0], DFmode)
- || register_operand (operands[1], DFmode)
- || operands[1] == CONST0_RTX (DFmode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (FP_REG_P (operands[0]) || FP_REG_P (operands[1]))
- return \"movrl %1,%0\";
- else
- return \"movl %1,%0\";
- case 1:
- return \"movrl %1,%0\";
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- case 3:
- return \"ldl %1,%0\";
- case 4:
- return \"stl %1,%0\";
- case 5:
- operands[1] = adjust_address (operands[0], VOIDmode, 4);
- return \"st g14,%0\;st g14,%1\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,fpload,fpstore,fpstore")])
-
-(define_insn ""
- [(set (match_operand:DF 0 "general_operand" "=r,*f,d,d,m")
- (match_operand:DF 1 "fpmove_src_operand" "r,GH,F,m,d"))]
- "(current_function_args_size != 0
- || current_function_stdarg != 0
- || rtx_equal_function_value_matters != 0)
- && (register_operand (operands[0], DFmode)
- || register_operand (operands[1], DFmode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (FP_REG_P (operands[0]) || FP_REG_P (operands[1]))
- return \"movrl %1,%0\";
- else
- return \"movl %1,%0\";
- case 1:
- return \"movrl %1,%0\";
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- case 3:
- return \"ldl %1,%0\";
- case 4:
- return \"stl %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,fpload,fpstore")])
-
-(define_expand "movsf"
- [(set (match_operand:SF 0 "general_operand" "")
- (match_operand:SF 1 "fpmove_src_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, SFmode))
- DONE;
-}")
-
-(define_insn ""
- [(set (match_operand:SF 0 "general_operand" "=r,*f,d,d,m")
- (match_operand:SF 1 "fpmove_src_operand" "r,GH,F,m,dG"))]
- "(current_function_args_size == 0
- && current_function_stdarg == 0
- && rtx_equal_function_value_matters == 0)
- && (register_operand (operands[0], SFmode)
- || register_operand (operands[1], SFmode)
- || operands[1] == CONST0_RTX (SFmode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (FP_REG_P (operands[0]) || FP_REG_P (operands[1]))
- return \"movr %1,%0\";
- else
- return \"mov %1,%0\";
- case 1:
- return \"movr %1,%0\";
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- case 3:
- return \"ld %1,%0\";
- case 4:
- if (operands[1] == CONST0_RTX (SFmode))
- return \"st g14,%0\";
- return \"st %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,fpload,fpstore")])
-
-(define_insn ""
- [(set (match_operand:SF 0 "general_operand" "=r,*f,d,d,m")
- (match_operand:SF 1 "fpmove_src_operand" "r,GH,F,m,d"))]
- "(current_function_args_size != 0
- || current_function_stdarg != 0
- || rtx_equal_function_value_matters != 0)
- && (register_operand (operands[0], SFmode)
- || register_operand (operands[1], SFmode))"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (FP_REG_P (operands[0]) || FP_REG_P (operands[1]))
- return \"movr %1,%0\";
- else
- return \"mov %1,%0\";
- case 1:
- return \"movr %1,%0\";
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- case 3:
- return \"ld %1,%0\";
- case 4:
- return \"st %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,fpload,fpstore")])
-\f
-;; Mixed-mode moves with sign and zero-extension.
-
-;; Note that the one starting from HImode comes before those for QImode
-;; so that a constant operand will match HImode, not QImode.
-
-(define_expand "extendhisi2"
- [(set (match_operand:SI 0 "register_operand" "")
- (sign_extend:SI
- (match_operand:HI 1 "nonimmediate_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operand1) == REG
- || (GET_CODE (operand1) == SUBREG
- && GET_CODE (XEXP (operand1, 0)) == REG))
- {
- rtx temp = gen_reg_rtx (SImode);
- rtx shift_16 = GEN_INT (16);
- int op1_subreg_byte = 0;
-
- if (GET_CODE (operand1) == SUBREG)
- {
- op1_subreg_byte = SUBREG_BYTE (operand1);
- op1_subreg_byte /= GET_MODE_SIZE (SImode);
- op1_subreg_byte *= GET_MODE_SIZE (SImode);
- operand1 = SUBREG_REG (operand1);
- }
- if (GET_MODE (operand1) != SImode)
- operand1 = gen_rtx (SUBREG, SImode, operand1, op1_subreg_byte);
-
- emit_insn (gen_ashlsi3 (temp, operand1, shift_16));
- emit_insn (gen_ashrsi3 (operand0, temp, shift_16));
- DONE;
- }
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (sign_extend:SI (match_operand:HI 1 "memory_operand" "m")))]
- ""
- "ldis %1,%0"
- [(set_attr "type" "load")])
-
-(define_expand "extendqisi2"
- [(set (match_operand:SI 0 "register_operand" "")
- (sign_extend:SI (match_operand:QI 1 "nonimmediate_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operand1) == REG
- || (GET_CODE (operand1) == SUBREG
- && GET_CODE (XEXP (operand1, 0)) == REG))
- {
- rtx temp = gen_reg_rtx (SImode);
- rtx shift_24 = GEN_INT (24);
- int op1_subreg_byte = 0;
-
- if (GET_CODE (operand1) == SUBREG)
- {
- op1_subreg_byte = SUBREG_BYTE (operand1);
- op1_subreg_byte /= GET_MODE_SIZE (SImode);
- op1_subreg_byte *= GET_MODE_SIZE (SImode);
- operand1 = SUBREG_REG (operand1);
- }
- if (GET_MODE (operand1) != SImode)
- operand1 = gen_rtx (SUBREG, SImode, operand1, op1_subreg_byte);
-
- emit_insn (gen_ashlsi3 (temp, operand1, shift_24));
- emit_insn (gen_ashrsi3 (operand0, temp, shift_24));
- DONE;
- }
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (sign_extend:SI (match_operand:QI 1 "memory_operand" "m")))]
- ""
- "ldib %1,%0"
- [(set_attr "type" "load")])
-
-(define_expand "extendqihi2"
- [(set (match_operand:HI 0 "register_operand" "")
- (sign_extend:HI
- (match_operand:QI 1 "nonimmediate_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operand1) == REG
- || (GET_CODE (operand1) == SUBREG
- && GET_CODE (XEXP (operand1, 0)) == REG))
- {
- rtx temp = gen_reg_rtx (SImode);
- rtx shift_24 = GEN_INT (24);
- int op0_subreg_byte = 0;
- int op1_subreg_byte = 0;
-
- if (GET_CODE (operand1) == SUBREG)
- {
- op1_subreg_byte = SUBREG_BYTE (operand1);
- op1_subreg_byte /= GET_MODE_SIZE (SImode);
- op1_subreg_byte *= GET_MODE_SIZE (SImode);
- operand1 = SUBREG_REG (operand1);
- }
- if (GET_MODE (operand1) != SImode)
- operand1 = gen_rtx (SUBREG, SImode, operand1, op1_subreg_byte);
-
- if (GET_CODE (operand0) == SUBREG)
- {
- op0_subreg_byte = SUBREG_BYTE (operand0);
- op0_subreg_byte /= GET_MODE_SIZE (SImode);
- op0_subreg_byte *= GET_MODE_SIZE (SImode);
- operand0 = SUBREG_REG (operand0);
- }
- if (GET_MODE (operand0) != SImode)
- operand0 = gen_rtx_SUBREG (SImode, operand0, op0_subreg_byte);
-
- emit_insn (gen_ashlsi3 (temp, operand1, shift_24));
- emit_insn (gen_ashrsi3 (operand0, temp, shift_24));
- DONE;
- }
-}")
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=d")
- (sign_extend:HI (match_operand:QI 1 "memory_operand" "m")))]
- ""
- "ldib %1,%0"
- [(set_attr "type" "load")])
-
-(define_expand "zero_extendhisi2"
- [(set (match_operand:SI 0 "register_operand" "")
- (zero_extend:SI
- (match_operand:HI 1 "nonimmediate_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operand1) == REG
- || (GET_CODE (operand1) == SUBREG
- && GET_CODE (XEXP (operand1, 0)) == REG))
- {
- rtx temp = gen_reg_rtx (SImode);
- rtx shift_16 = GEN_INT (16);
- int op1_subreg_byte = 0;
-
- if (GET_CODE (operand1) == SUBREG)
- {
- op1_subreg_byte = SUBREG_BYTE (operand1);
- op1_subreg_byte /= GET_MODE_SIZE (SImode);
- op1_subreg_byte *= GET_MODE_SIZE (SImode);
- operand1 = SUBREG_REG (operand1);
- }
- if (GET_MODE (operand1) != SImode)
- operand1 = gen_rtx (SUBREG, SImode, operand1, op1_subreg_byte);
-
- emit_insn (gen_ashlsi3 (temp, operand1, shift_16));
- emit_insn (gen_lshrsi3 (operand0, temp, shift_16));
- DONE;
- }
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (zero_extend:SI (match_operand:HI 1 "memory_operand" "m")))]
- ""
- "ldos %1,%0"
- [(set_attr "type" "load")])
-
-;; Using shifts here generates much better code than doing an `and 255'.
-;; This is mainly because the `and' requires loading the constant separately,
-;; the constant is likely to get optimized, and then the compiler can't
-;; optimize the `and' because it doesn't know that one operand is a constant.
-
-(define_expand "zero_extendqisi2"
- [(set (match_operand:SI 0 "register_operand" "")
- (zero_extend:SI (match_operand:QI 1 "nonimmediate_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operand1) == REG
- || (GET_CODE (operand1) == SUBREG
- && GET_CODE (XEXP (operand1, 0)) == REG))
- {
- rtx temp = gen_reg_rtx (SImode);
- rtx shift_24 = GEN_INT (24);
- int op1_subreg_byte = 0;
-
- if (GET_CODE (operand1) == SUBREG)
- {
- op1_subreg_byte = SUBREG_BYTE (operand1);
- op1_subreg_byte /= GET_MODE_SIZE (SImode);
- op1_subreg_byte *= GET_MODE_SIZE (SImode);
- operand1 = SUBREG_REG (operand1);
- }
- if (GET_MODE (operand1) != SImode)
- operand1 = gen_rtx (SUBREG, SImode, operand1, op1_subreg_byte);
-
- emit_insn (gen_ashlsi3 (temp, operand1, shift_24));
- emit_insn (gen_lshrsi3 (operand0, temp, shift_24));
- DONE;
- }
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (zero_extend:SI (match_operand:QI 1 "memory_operand" "m")))]
- ""
- "ldob %1,%0"
- [(set_attr "type" "load")])
-
-(define_expand "zero_extendqihi2"
- [(set (match_operand:HI 0 "register_operand" "")
- (zero_extend:HI
- (match_operand:QI 1 "nonimmediate_operand" "")))]
- ""
- "
-{
- if (GET_CODE (operand1) == REG
- || (GET_CODE (operand1) == SUBREG
- && GET_CODE (XEXP (operand1, 0)) == REG))
- {
- rtx temp = gen_reg_rtx (SImode);
- rtx shift_24 = GEN_INT (24);
- int op0_subreg_byte = 0;
- int op1_subreg_byte = 0;
-
- if (GET_CODE (operand1) == SUBREG)
- {
- op1_subreg_byte = SUBREG_BYTE (operand1);
- operand1 = SUBREG_REG (operand1);
- }
- if (GET_MODE (operand1) != SImode)
- operand1 = gen_rtx (SUBREG, SImode, operand1, op1_subreg_byte);
-
- if (GET_CODE (operand0) == SUBREG)
- {
- op0_subreg_byte = SUBREG_BYTE (operand0);
- operand0 = SUBREG_REG (operand0);
- }
- if (GET_MODE (operand0) != SImode)
- operand0 = gen_rtx_SUBREG (SImode, operand0, op0_subreg_byte);
-
- emit_insn (gen_ashlsi3 (temp, operand1, shift_24));
- emit_insn (gen_lshrsi3 (operand0, temp, shift_24));
- DONE;
- }
-}")
-
-(define_insn ""
- [(set (match_operand:HI 0 "register_operand" "=d")
- (zero_extend:HI (match_operand:QI 1 "memory_operand" "m")))]
- ""
- "ldob %1,%0"
- [(set_attr "type" "load")])
-\f
-;; Conversions between float and double.
-
-(define_insn "extendsfdf2"
- [(set (match_operand:DF 0 "register_operand" "=*f,d")
- (float_extend:DF (match_operand:SF 1 "fp_arith_operand" "dGH,fGH")))]
- "TARGET_NUMERICS"
- "@
- movr %1,%0
- movrl %1,%0"
- [(set_attr "type" "fpmove")])
-
-(define_insn "truncdfsf2"
- [(set (match_operand:SF 0 "register_operand" "=d")
- (float_truncate:SF
- (match_operand:DF 1 "fp_arith_operand" "fGH")))]
- "TARGET_NUMERICS"
- "movr %1,%0"
- [(set_attr "type" "fpmove")])
-
-;; Conversion between fixed point and floating point.
-
-(define_insn "floatsidf2"
- [(set (match_operand:DF 0 "register_operand" "=f")
- (float:DF (match_operand:SI 1 "register_operand" "d")))]
- "TARGET_NUMERICS"
- "cvtir %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_insn "floatsisf2"
- [(set (match_operand:SF 0 "register_operand" "=d*f")
- (float:SF (match_operand:SI 1 "register_operand" "d")))]
- "TARGET_NUMERICS"
- "cvtir %1,%0"
- [(set_attr "type" "fpcvt")])
-
-;; Convert a float to an actual integer.
-;; Truncation is performed as part of the conversion.
-;; The i960 requires conversion from DFmode to DImode to make
-;; unsigned conversions work properly.
-
-(define_insn "fixuns_truncdfdi2"
- [(set (match_operand:DI 0 "register_operand" "=d")
- (unsigned_fix:DI (fix:DF (match_operand:DF 1 "fp_arith_operand" "fGH"))))]
- "TARGET_NUMERICS"
- "cvtzril %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_insn "fixuns_truncsfdi2"
- [(set (match_operand:DI 0 "register_operand" "=d")
- (unsigned_fix:DI (fix:SF (match_operand:SF 1 "fp_arith_operand" "fGH"))))]
- "TARGET_NUMERICS"
- "cvtzril %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_insn "fix_truncdfsi2"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (fix:SI (fix:DF (match_operand:DF 1 "fp_arith_operand" "fGH"))))]
- "TARGET_NUMERICS"
- "cvtzri %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_expand "fixuns_truncdfsi2"
- [(set (match_operand:SI 0 "register_operand" "")
- (unsigned_fix:SI (fix:DF (match_operand:DF 1 "fp_arith_operand" ""))))]
- "TARGET_NUMERICS"
- "
-{
- rtx temp = gen_reg_rtx (DImode);
- emit_insn (gen_rtx_SET (VOIDmode, temp,
- gen_rtx_UNSIGNED_FIX (DImode,
- gen_rtx_FIX (DFmode,
- operands[1]))));
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_SUBREG (SImode, temp, 0)));
- DONE;
-}")
-
-(define_insn "fix_truncsfsi2"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (fix:SI (fix:SF (match_operand:SF 1 "fp_arith_operand" "dfGH"))))]
- "TARGET_NUMERICS"
- "cvtzri %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_expand "fixuns_truncsfsi2"
- [(set (match_operand:SI 0 "register_operand" "")
- (unsigned_fix:SI (fix:SF (match_operand:SF 1 "fp_arith_operand" ""))))]
- "TARGET_NUMERICS"
- "
-{
- rtx temp = gen_reg_rtx (DImode);
- emit_insn (gen_rtx_SET (VOIDmode, temp,
- gen_rtx_UNSIGNED_FIX (DImode,
- gen_rtx_FIX (SFmode,
- operands[1]))));
- emit_insn (gen_rtx_SET (VOIDmode, operands[0],
- gen_rtx_SUBREG (SImode, temp, 0)));
- DONE;
-}")
-\f
-;; Arithmetic instructions.
-
-(define_insn "subsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (minus:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "subo %2,%1,%0")
-
-;; Try to generate an lda instruction when it would be faster than an
-;; add instruction.
-;; Some assemblers apparently won't accept two addresses added together.
-
-;; ??? The condition should be improved to reject the case of two
-;; symbolic constants.
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d,d,d")
- (plus:SI (match_operand:SI 1 "arith32_operand" "%dn,i,dn")
- (match_operand:SI 2 "arith32_operand" "dn,dn,i")))]
- "(TARGET_C_SERIES) && (CONSTANT_P (operands[1]) || CONSTANT_P (operands[2]))"
- "*
-{
- if (GET_CODE (operands[1]) == CONST_INT)
- {
- rtx tmp = operands[1];
- operands[1] = operands[2];
- operands[2] = tmp;
- }
- if (GET_CODE (operands[2]) == CONST_INT
- && GET_CODE (operands[1]) == REG
- && i960_last_insn_type != I_TYPE_REG)
- {
- if (INTVAL (operands[2]) < 0 && INTVAL (operands[2]) > -32)
- return \"subo %n2,%1,%0\";
- else if (INTVAL (operands[2]) >= 0 && INTVAL (operands[2]) < 32)
- return \"addo %1,%2,%0\";
- }
- /* Non-canonical results (op1 == const, op2 != const) have been seen
- in reload output when both operands were symbols before reload, so
- we deal with it here. This may be a fault of the constraints above. */
- if (CONSTANT_P (operands[1]))
- {
- if (CONSTANT_P (operands[2]))
- return \"lda %1+%2,%0\";
- else
- return \"lda %1(%2),%0\";
- }
- return \"lda %2(%1),%0\";
-}")
-
-(define_insn "addsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (plus:SI (match_operand:SI 1 "signed_arith_operand" "%dI")
- (match_operand:SI 2 "signed_arith_operand" "dIK")))]
- ""
- "*
-{
- if (GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) < 0)
- return \"subo %n2,%1,%0\";
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"addo %2,%1,%0\";
- return \"addo %1,%2,%0\";
-}")
-
-(define_insn "mulsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (mult:SI (match_operand:SI 1 "arith_operand" "%dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "*
-{
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"mulo %2,%1,%0\";
- return \"mulo %1,%2,%0\";
-}"
- [(set_attr "type" "mult")])
-
-(define_insn "umulsidi3"
- [(set (match_operand:DI 0 "register_operand" "=d")
- (mult:DI (zero_extend:DI (match_operand:SI 1 "register_operand" "d"))
- (zero_extend:DI (match_operand:SI 2 "register_operand" "d"))))]
- ""
- "*
-{
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"emul %2,%1,%0\";
- return \"emul %1,%2,%0\";
-}"
- [(set_attr "type" "mult")])
-
-(define_insn ""
- [(set (match_operand:DI 0 "register_operand" "=d")
- (mult:DI (zero_extend:DI (match_operand:SI 1 "register_operand" "%d"))
- (match_operand:SI 2 "literal" "I")))]
- ""
- "*
-{
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"emul %2,%1,%0\";
- return \"emul %1,%2,%0\";
-}"
- [(set_attr "type" "mult")])
-
-;; This goes after the move/add/sub/mul instructions
-;; because those instructions are better when they apply.
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (match_operand:SI 1 "address_operand" "p"))]
- ""
- "lda %a1,%0"
- [(set_attr "type" "load")])
-
-;; This will never be selected because of an "optimization" that GCC does.
-;; It always converts divides by a power of 2 into a sequence of instructions
-;; that does a right shift, and then corrects the result if it was negative.
-
-;; (define_insn ""
-;; [(set (match_operand:SI 0 "register_operand" "=d")
-;; (div:SI (match_operand:SI 1 "arith_operand" "dI")
-;; (match_operand:SI 2 "power2_operand" "nI")))]
-;; ""
-;; "*{
-;; operands[2] = GEN_INT (bitpos (INTVAL (operands[2])));
-;; return \"shrdi %2,%1,%0\";
-;; }"
-
-(define_insn "divsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (div:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "divi %2,%1,%0"
- [(set_attr "type" "div")])
-
-(define_insn "udivsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (udiv:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "divo %2,%1,%0"
- [(set_attr "type" "div")])
-
-;; We must use `remi' not `modi' here, to ensure that `%' has the effects
-;; specified by the ANSI C standard.
-
-(define_insn "modsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (mod:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "remi %2,%1,%0"
- [(set_attr "type" "div")])
-
-(define_insn "umodsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (umod:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "remo %2,%1,%0"
- [(set_attr "type" "div")])
-
-;; And instructions (with complement also).
-
-(define_insn "andsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (and:SI (match_operand:SI 1 "register_operand" "%d")
- (match_operand:SI 2 "logic_operand" "dIM")))]
- ""
- "*
-{
- if (GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) < 0)
- return \"andnot %C2,%1,%0\";
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"and %2,%1,%0\";
- return \"and %1,%2,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (and:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "cmplpower2_operand" "n")))]
- ""
- "*
-{
- operands[2] = GEN_INT (bitpos (~INTVAL (operands[2])));
- return \"clrbit %2,%1,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (and:SI (not:SI (match_operand:SI 1 "register_operand" "d"))
- (match_operand:SI 2 "logic_operand" "dIM")))]
- ""
- "*
-{
- if (GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) < 0)
- return \"nor %C2,%1,%0\";
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"notand %2,%1,%0\";
- return \"andnot %1,%2,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (ior:SI (not:SI (match_operand:SI 1 "register_operand" "%d"))
- (not:SI (match_operand:SI 2 "register_operand" "d"))))]
- ""
- "*
-{
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"nand %2,%1,%0\";
- return \"nand %1,%2,%0\";
-}")
-
-(define_insn "iorsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (ior:SI (match_operand:SI 1 "register_operand" "%d")
- (match_operand:SI 2 "logic_operand" "dIM")))]
- ""
- "*
-{
- if (GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) < 0)
- return \"ornot %C2,%1,%0\";
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"or %2,%1,%0\";
- return \"or %1,%2,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (ior:SI (match_operand:SI 1 "register_operand" "d")
- (match_operand:SI 2 "power2_operand" "n")))]
- ""
- "*
-{
- operands[2] = GEN_INT (bitpos (INTVAL (operands[2])));
- return \"setbit %2,%1,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (ior:SI (not:SI (match_operand:SI 1 "register_operand" "d"))
- (match_operand:SI 2 "logic_operand" "dIM")))]
- ""
- "*
-{
- if (GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) < 0)
- return \"nand %C2,%1,%0\";
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"notor %2,%1,%0\";
- return \"ornot %1,%2,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (and:SI (not:SI (match_operand:SI 1 "register_operand" "%d"))
- (not:SI (match_operand:SI 2 "register_operand" "d"))))]
- ""
- "*
-{
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"nor %2,%1,%0\";
- return \"nor %1,%2,%0\";
-}")
-
-(define_insn "xorsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (xor:SI (match_operand:SI 1 "register_operand" "%d")
- (match_operand:SI 2 "logic_operand" "dIM")))]
- ""
- "*
-{
- if (GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) < 0)
- return \"xnor %C2,%1,%0\";
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"xor %2,%1,%0\";
- return \"xor %1,%2,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (xor:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "power2_operand" "n")))]
- ""
- "*
-{
- operands[2] = GEN_INT (bitpos (INTVAL (operands[2])));
- return \"notbit %2,%1,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (not:SI (xor:SI (match_operand:SI 1 "register_operand" "%d")
- (match_operand:SI 2 "register_operand" "d"))))]
- ""
- "*
-{
- if (i960_bypass (insn, operands[1], operands[2], 0))
- return \"xnor %2,%1,%0\";
- return \"xnor %2,%1,%0\";
-}")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (ior:SI (ashift:SI (const_int 1)
- (match_operand:SI 1 "register_operand" "d"))
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "setbit %1,%2,%0")
-
-;; (not (ashift 1 reg)) canonicalizes to (rotate -2 reg)
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (and:SI (rotate:SI (const_int -2)
- (match_operand:SI 1 "register_operand" "d"))
- (match_operand:SI 2 "register_operand" "d")))]
- ""
- "clrbit %1,%2,%0")
-
-;; The above pattern canonicalizes to this when both the input and output
-;; are the same pseudo-register.
-(define_insn ""
- [(set (zero_extract:SI (match_operand:SI 0 "register_operand" "+d")
- (const_int 1)
- (match_operand:SI 1 "register_operand" "d"))
- (const_int 0))]
- ""
- "clrbit %1,%0,%0")
-
-(define_insn ""
- [(set (match_operand:SI 0 "register_operand" "=d")
- (xor:SI (ashift:SI (const_int 1)
- (match_operand:SI 1 "register_operand" "d"))
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "notbit %1,%2,%0")
-
-(define_insn "negsi2"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (neg:SI (match_operand:SI 1 "arith_operand" "dI")))]
- ""
- "subo %1,0,%0"
- [(set_attr "length" "1")])
-
-(define_insn "one_cmplsi2"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (not:SI (match_operand:SI 1 "arith_operand" "dI")))]
- ""
- "not %1,%0"
- [(set_attr "length" "1")])
-\f
-;; Floating point arithmetic instructions.
-
-(define_insn "adddf3"
- [(set (match_operand:DF 0 "register_operand" "=d*f")
- (plus:DF (match_operand:DF 1 "fp_arith_operand" "%rGH")
- (match_operand:DF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "addrl %1,%2,%0"
- [(set_attr "type" "fpadd")])
-
-(define_insn "addsf3"
- [(set (match_operand:SF 0 "register_operand" "=d*f")
- (plus:SF (match_operand:SF 1 "fp_arith_operand" "%rGH")
- (match_operand:SF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "addr %1,%2,%0"
- [(set_attr "type" "fpadd")])
-
-
-(define_insn "subdf3"
- [(set (match_operand:DF 0 "register_operand" "=d*f")
- (minus:DF (match_operand:DF 1 "fp_arith_operand" "rGH")
- (match_operand:DF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "subrl %2,%1,%0"
- [(set_attr "type" "fpadd")])
-
-(define_insn "subsf3"
- [(set (match_operand:SF 0 "register_operand" "=d*f")
- (minus:SF (match_operand:SF 1 "fp_arith_operand" "rGH")
- (match_operand:SF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "subr %2,%1,%0"
- [(set_attr "type" "fpadd")])
-
-
-(define_insn "muldf3"
- [(set (match_operand:DF 0 "register_operand" "=d*f")
- (mult:DF (match_operand:DF 1 "fp_arith_operand" "%rGH")
- (match_operand:DF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "mulrl %1,%2,%0"
- [(set_attr "type" "fpmul")])
-
-(define_insn "mulsf3"
- [(set (match_operand:SF 0 "register_operand" "=d*f")
- (mult:SF (match_operand:SF 1 "fp_arith_operand" "%rGH")
- (match_operand:SF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "mulr %1,%2,%0"
- [(set_attr "type" "fpmul")])
-
-
-(define_insn "divdf3"
- [(set (match_operand:DF 0 "register_operand" "=d*f")
- (div:DF (match_operand:DF 1 "fp_arith_operand" "rGH")
- (match_operand:DF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "divrl %2,%1,%0"
- [(set_attr "type" "fpdiv")])
-
-(define_insn "divsf3"
- [(set (match_operand:SF 0 "register_operand" "=d*f")
- (div:SF (match_operand:SF 1 "fp_arith_operand" "rGH")
- (match_operand:SF 2 "fp_arith_operand" "rGH")))]
- "TARGET_NUMERICS"
- "divr %2,%1,%0"
- [(set_attr "type" "fpdiv")])
-
-(define_insn "negdf2"
- [(set (match_operand:DF 0 "register_operand" "=d,d*f")
- (neg:DF (match_operand:DF 1 "register_operand" "d,r")))]
- ""
- "*
-{
- if (which_alternative == 0)
- {
- if (REGNO (operands[0]) == REGNO (operands[1]))
- return \"notbit 31,%D1,%D0\";
- return \"mov %1,%0\;notbit 31,%D1,%D0\";
- }
- return \"subrl %1,0f0.0,%0\";
-}"
- [(set_attr "type" "fpadd")])
-
-(define_insn "negsf2"
- [(set (match_operand:SF 0 "register_operand" "=d,d*f")
- (neg:SF (match_operand:SF 1 "register_operand" "d,r")))]
- ""
- "@
- notbit 31,%1,%0
- subr %1,0f0.0,%0"
- [(set_attr "type" "fpadd")])
-
-;;; The abs patterns also work even if the target machine doesn't have
-;;; floating point, because in that case dstreg and srcreg will always be
-;;; less than 32.
-
-(define_insn "absdf2"
- [(set (match_operand:DF 0 "register_operand" "=d*f")
- (abs:DF (match_operand:DF 1 "register_operand" "df")))]
- ""
- "*
-{
- int dstreg = REGNO (operands[0]);
- int srcreg = REGNO (operands[1]);
-
- if (dstreg < 32)
- {
- if (srcreg < 32)
- {
- if (dstreg != srcreg)
- output_asm_insn (\"mov %1,%0\", operands);
- return \"clrbit 31,%D1,%D0\";
- }
- /* Src is an fp reg. */
- return \"movrl %1,%0\;clrbit 31,%D1,%D0\";
- }
- if (srcreg >= 32)
- return \"cpysre %1,0f0.0,%0\";
- return \"movrl %1,%0\;cpysre %0,0f0.0,%0\";
-}"
- [(set_attr "type" "multi")])
-
-(define_insn "abssf2"
- [(set (match_operand:SF 0 "register_operand" "=d*f")
- (abs:SF (match_operand:SF 1 "register_operand" "df")))]
- ""
- "*
-{
- int dstreg = REGNO (operands[0]);
- int srcreg = REGNO (operands[1]);
-
- if (dstreg < 32 && srcreg < 32)
- return \"clrbit 31,%1,%0\";
-
- if (dstreg >= 32 && srcreg >= 32)
- return \"cpysre %1,0f0.0,%0\";
-
- if (dstreg < 32)
- return \"movr %1,%0\;clrbit 31,%0,%0\";
-
- return \"movr %1,%0\;cpysre %0,0f0.0,%0\";
-}"
- [(set_attr "type" "multi")])
-\f
-;; Tetra (16 byte) float support.
-
-(define_expand "cmptf"
- [(set (reg:CC 36)
- (compare:CC (match_operand:TF 0 "register_operand" "")
- (match_operand:TF 1 "nonmemory_operand" "")))]
- "TARGET_NUMERICS"
- "
-{
- i960_compare_op0 = operands[0];
- i960_compare_op1 = operands[1];
- DONE;
-}")
-
-(define_insn ""
- [(set (reg:CC 36)
- (compare:CC (match_operand:TF 0 "register_operand" "f")
- (match_operand:TF 1 "nonmemory_operand" "fGH")))]
- "TARGET_NUMERICS"
- "cmpr %0,%1"
- [(set_attr "type" "fpcc")])
-
-(define_expand "movtf"
- [(set (match_operand:TF 0 "general_operand" "")
- (match_operand:TF 1 "fpmove_src_operand" ""))]
- ""
- "
-{
- if (emit_move_sequence (operands, TFmode))
- DONE;
-}")
-
-(define_insn ""
- [(set (match_operand:TF 0 "general_operand" "=r,f,d,d,m")
- (match_operand:TF 1 "fpmove_src_operand" "r,GH,F,m,d"))]
- "register_operand (operands[0], TFmode)
- || register_operand (operands[1], TFmode)"
- "*
-{
- switch (which_alternative)
- {
- case 0:
- if (FP_REG_P (operands[0]) || FP_REG_P (operands[1]))
- return \"movre %1,%0\";
- else
- return \"movq %1,%0\";
- case 1:
- return \"movre %1,%0\";
- case 2:
- return i960_output_ldconst (operands[0], operands[1]);
- case 3:
- return \"ldt %1,%0\";
- case 4:
- return \"stt %1,%0\";
- default:
- abort();
- }
-}"
- [(set_attr "type" "move,move,load,fpload,fpstore")])
-
-(define_insn "extendsftf2"
- [(set (match_operand:TF 0 "register_operand" "=f,d")
- (float_extend:TF
- (match_operand:SF 1 "register_operand" "d,f")))]
- "TARGET_NUMERICS"
- "@
- movr %1,%0
- movre %1,%0"
- [(set_attr "type" "fpmove")])
-
-(define_insn "extenddftf2"
- [(set (match_operand:TF 0 "register_operand" "=f,d")
- (float_extend:TF
- (match_operand:DF 1 "register_operand" "d,f")))]
- "TARGET_NUMERICS"
- "@
- movrl %1,%0
- movre %1,%0"
- [(set_attr "type" "fpmove")])
-
-(define_insn "trunctfdf2"
- [(set (match_operand:DF 0 "register_operand" "=d")
- (float_truncate:DF
- (match_operand:TF 1 "register_operand" "f")))]
- "TARGET_NUMERICS"
- "movrl %1,%0"
- [(set_attr "type" "fpmove")])
-
-(define_insn "trunctfsf2"
- [(set (match_operand:SF 0 "register_operand" "=d")
- (float_truncate:SF
- (match_operand:TF 1 "register_operand" "f")))]
- "TARGET_NUMERICS"
- "movr %1,%0"
- [(set_attr "type" "fpmove")])
-
-(define_insn "floatsitf2"
- [(set (match_operand:TF 0 "register_operand" "=f")
- (float:TF (match_operand:SI 1 "register_operand" "d")))]
- "TARGET_NUMERICS"
- "cvtir %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_insn "fix_trunctfsi2"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (fix:SI (fix:TF (match_operand:TF 1 "register_operand" "f"))))]
- "TARGET_NUMERICS"
- "cvtzri %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_insn "fixuns_trunctfsi2"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (unsigned_fix:SI (fix:TF (match_operand:TF 1 "register_operand" "f"))))]
- "TARGET_NUMERICS"
- "cvtzri %1,%0"
- [(set_attr "type" "fpcvt")])
-
-(define_insn "addtf3"
- [(set (match_operand:TF 0 "register_operand" "=f")
- (plus:TF (match_operand:TF 1 "nonmemory_operand" "%fGH")
- (match_operand:TF 2 "nonmemory_operand" "fGH")))]
- "TARGET_NUMERICS"
- "addr %1,%2,%0"
- [(set_attr "type" "fpadd")])
-
-(define_insn "subtf3"
- [(set (match_operand:TF 0 "register_operand" "=f")
- (minus:TF (match_operand:TF 1 "nonmemory_operand" "fGH")
- (match_operand:TF 2 "nonmemory_operand" "fGH")))]
- "TARGET_NUMERICS"
- "subr %2,%1,%0"
- [(set_attr "type" "fpadd")])
-
-(define_insn "multf3"
- [(set (match_operand:TF 0 "register_operand" "=f")
- (mult:TF (match_operand:TF 1 "nonmemory_operand" "%fGH")
- (match_operand:TF 2 "nonmemory_operand" "fGH")))]
- "TARGET_NUMERICS"
- "mulr %1,%2,%0"
- [(set_attr "type" "fpmul")])
-
-(define_insn "divtf3"
- [(set (match_operand:TF 0 "register_operand" "=f")
- (div:TF (match_operand:TF 1 "nonmemory_operand" "fGH")
- (match_operand:TF 2 "nonmemory_operand" "fGH")))]
- "TARGET_NUMERICS"
- "divr %2,%1,%0"
- [(set_attr "type" "fpdiv")])
-
-(define_insn "negtf2"
- [(set (match_operand:TF 0 "register_operand" "=f")
- (neg:TF (match_operand:TF 1 "register_operand" "f")))]
- "TARGET_NUMERICS"
- "subr %1,0f0.0,%0"
- [(set_attr "type" "fpadd")])
-
-(define_insn "abstf2"
- [(set (match_operand:TF 0 "register_operand" "=f")
- (abs:TF (match_operand:TF 1 "register_operand" "f")))]
- "(TARGET_NUMERICS)"
- "cpysre %1,0f0.0,%0"
- [(set_attr "type" "fpmove")])
-\f
-;; Arithmetic shift instructions.
-
-;; The shli instruction generates an overflow fault if the sign changes.
-;; In the case of overflow, it does not give the natural result, it instead
-;; gives the last shift value before the overflow. We can not use this
-;; instruction because gcc thinks that arithmetic left shift and logical
-;; left shift are identical, and sometimes canonicalizes the logical left
-;; shift to an arithmetic left shift. Therefore we must always use the
-;; logical left shift instruction.
-
-(define_insn "ashlsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (ashift:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "shlo %2,%1,%0"
- [(set_attr "type" "alu2")])
-
-(define_insn "ashrsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (ashiftrt:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "shri %2,%1,%0"
- [(set_attr "type" "alu2")])
-
-(define_insn "lshrsi3"
- [(set (match_operand:SI 0 "register_operand" "=d")
- (lshiftrt:SI (match_operand:SI 1 "arith_operand" "dI")
- (match_operand:SI 2 "arith_operand" "dI")))]
- ""
- "shro %2,%1,%0"
- [(set_attr "type" "alu2")])
-\f
-;; Unconditional and other jump instructions.
-
-(define_insn "jump"
- [(set (pc)
- (label_ref (match_operand 0 "" "")))]
- ""
- "b %l0"
- [(set_attr "type" "branch")])
-
-(define_insn "indirect_jump"
- [(set (pc) (match_operand:SI 0 "address_operand" "p"))]
- ""
- "bx %a0"
- [(set_attr "type" "branch")])
-
-(define_insn "tablejump"
- [(set (pc) (match_operand:SI 0 "register_operand" "d"))
- (use (label_ref (match_operand 1 "" "")))]
- ""
- "*
-{
- if (flag_pic)
- return \"bx %l1(%0)\";
- else
- return \"bx (%0)\";
-}"
- [(set_attr "type" "branch")])
-
-;;- jump to subroutine
-
-(define_expand "call"
- [(call (match_operand:SI 0 "memory_operand" "m")
- (match_operand:SI 1 "immediate_operand" "i"))]
- ""
- "
-{
- emit_call_insn (gen_call_internal (operands[0], operands[1],
- virtual_outgoing_args_rtx));
- DONE;
-}")
-
-;; We need a call saved register allocated for the match_scratch, so we use
-;; 'l' because all local registers are call saved.
-
-;; ??? I would prefer to use a match_scratch here, but match_scratch allocated
-;; registers can't be used for spills. In a function with lots of calls,
-;; local-alloc may allocate all local registers to a match_scratch, leaving
-;; no local registers available for spills.
-
-(define_insn "call_internal"
- [(call (match_operand:SI 0 "memory_operand" "m")
- (match_operand:SI 1 "immediate_operand" "i"))
- (use (match_operand:SI 2 "address_operand" "p"))
- (clobber (reg:SI 19))]
- ""
- "* return i960_output_call_insn (operands[0], operands[1], operands[2],
- insn);"
- [(set_attr "type" "call")])
-
-(define_expand "call_value"
- [(set (match_operand 0 "register_operand" "=d")
- (call (match_operand:SI 1 "memory_operand" "m")
- (match_operand:SI 2 "immediate_operand" "i")))]
- ""
- "
-{
- emit_call_insn (gen_call_value_internal (operands[0], operands[1],
- operands[2],
- virtual_outgoing_args_rtx));
- DONE;
-}")
-
-;; We need a call saved register allocated for the match_scratch, so we use
-;; 'l' because all local registers are call saved.
-
-(define_insn "call_value_internal"
- [(set (match_operand 0 "register_operand" "=d")
- (call (match_operand:SI 1 "memory_operand" "m")
- (match_operand:SI 2 "immediate_operand" "i")))
- (use (match_operand:SI 3 "address_operand" "p"))
- (clobber (reg:SI 19))]
- ""
- "* return i960_output_call_insn (operands[1], operands[2], operands[3],
- insn);"
- [(set_attr "type" "call")])
-
-(define_insn "return"
- [(return)]
- ""
- "* return i960_output_ret_insn (insn);"
- [(set_attr "type" "branch")])
-
-;; A return instruction. Used only by nonlocal_goto to change the
-;; stack pointer, frame pointer, previous frame pointer and the return
-;; instruction pointer.
-(define_insn "ret"
- [(set (pc) (unspec_volatile [(reg:SI 16)] 3))]
- ""
- "ret"
- [(set_attr "type" "branch")
- (set_attr "length" "1")])
-
-(define_expand "nonlocal_goto"
- [(match_operand:SI 0 "" "")
- (match_operand:SI 1 "general_operand" "")
- (match_operand:SI 2 "general_operand" "")
- (match_operand:SI 3 "general_operand" "")]
- ""
- "
-{
- rtx chain = operands[0];
- rtx handler = operands[1];
- rtx stack = operands[2];
-
- /* We must restore the stack pointer, frame pointer, previous frame
- pointer and the return instruction pointer. Since the ret
- instruction does all this for us with one instruction, we arrange
- everything so that ret will do everything we need done. */
-
- /* First, we must flush the register windows, so that we can modify
- the saved local registers on the stack directly and because we
- are going to change the previous frame pointer. */
-
- emit_insn (gen_flush_register_windows ());
-
- /* Load the static chain value for the containing fn into fp. This is needed
- because STACK refers to fp. */
- emit_move_insn (hard_frame_pointer_rtx, chain);
-
- /* Now move the adjusted value into the pfp register for the following return
- instruction. */
- emit_move_insn (gen_rtx (REG, SImode, 16),
- plus_constant (hard_frame_pointer_rtx, -64));
-
- /* Next, we put the address that we want to transfer to, into the
- saved $rip value in the frame. Once we ret below, that value
- will be loaded into the pc (IP). */
-
- emit_move_insn (gen_rtx (MEM, SImode,
- plus_constant (hard_frame_pointer_rtx, -56)),
- handler);
-
- /* Next, we put stack into the saved $sp value in the frame. */
- emit_move_insn (gen_rtx (MEM, SImode,
- plus_constant (hard_frame_pointer_rtx, -60)),
- stack);
-
- /* And finally, we can now just ret to get all the values saved
- above into all the right registers, and also, all the local
- register that were in use in the function, are restored from
- their saved values (from the call instruction) on the stack
- because we are very careful to ret from the exact save area in
- use during the original call. */
-
- emit_jump_insn (gen_ret ());
- emit_barrier ();
- DONE;
-}")
-
-;; Special insn to flush register windows.
-(define_insn "flush_register_windows"
- [(unspec_volatile [(const_int 0)] 1)]
- ""
- "flushreg"
- [(set_attr "type" "misc")
- (set_attr "length" "1")])
-
-(define_insn "nop"
- [(const_int 0)]
- ""
- "")
-\f
-;; Various peephole optimizations for multiple-word moves, loads, and stores.
-;; Multiple register moves.
-
-;; Matched 5/28/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=r")
- (match_operand:SI 1 "register_operand" "r"))
- (set (match_operand:SI 2 "register_operand" "=r")
- (match_operand:SI 3 "register_operand" "r"))
- (set (match_operand:SI 4 "register_operand" "=r")
- (match_operand:SI 5 "register_operand" "r"))
- (set (match_operand:SI 6 "register_operand" "=r")
- (match_operand:SI 7 "register_operand" "r"))]
- "((REGNO (operands[0]) & 3) == 0)
- && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[0]) + 1 == REGNO (operands[2]))
- && (REGNO (operands[1]) + 1 == REGNO (operands[3]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[4]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[5]))
- && (REGNO (operands[0]) + 3 == REGNO (operands[6]))
- && (REGNO (operands[1]) + 3 == REGNO (operands[7]))"
- "movq %1,%0")
-
-;; Matched 4/17/92
-(define_peephole
- [(set (match_operand:DI 0 "register_operand" "=r")
- (match_operand:DI 1 "register_operand" "r"))
- (set (match_operand:DI 2 "register_operand" "=r")
- (match_operand:DI 3 "register_operand" "r"))]
- "((REGNO (operands[0]) & 3) == 0)
- && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[0]) + 2 == REGNO (operands[2]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[3]))"
- "movq %1,%0")
-
-;; Matched 4/17/92
-(define_peephole
- [(set (match_operand:DI 0 "register_operand" "=r")
- (match_operand:DI 1 "register_operand" "r"))
- (set (match_operand:SI 2 "register_operand" "=r")
- (match_operand:SI 3 "register_operand" "r"))
- (set (match_operand:SI 4 "register_operand" "=r")
- (match_operand:SI 5 "register_operand" "r"))]
- "((REGNO (operands[0]) & 3) == 0)
- && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[0]) + 2 == REGNO (operands[2]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[3]))
- && (REGNO (operands[0]) + 3 == REGNO (operands[4]))
- && (REGNO (operands[1]) + 3 == REGNO (operands[5]))"
- "movq %1,%0")
-
-;; Matched 4/17/92
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=r")
- (match_operand:SI 1 "register_operand" "r"))
- (set (match_operand:SI 2 "register_operand" "=r")
- (match_operand:SI 3 "register_operand" "r"))
- (set (match_operand:DI 4 "register_operand" "=r")
- (match_operand:DI 5 "register_operand" "r"))]
- "((REGNO (operands[0]) & 3) == 0)
- && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[0]) + 1 == REGNO (operands[2]))
- && (REGNO (operands[1]) + 1 == REGNO (operands[3]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[4]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[5]))"
- "movq %1,%0")
-
-;; Matched 4/17/92
-(define_peephole
- [(set (match_operand:DI 0 "register_operand" "=r")
- (match_operand:DI 1 "register_operand" "r"))
- (set (match_operand:SI 2 "register_operand" "=r")
- (match_operand:SI 3 "register_operand" "r"))]
- "((REGNO (operands[0]) & 3) == 0)
- && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[0]) + 2 == REGNO (operands[2]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[3]))"
- "movt %1,%0")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=r")
- (match_operand:SI 1 "register_operand" "r"))
- (set (match_operand:SI 2 "register_operand" "=r")
- (match_operand:SI 3 "register_operand" "r"))
- (set (match_operand:SI 4 "register_operand" "=r")
- (match_operand:SI 5 "register_operand" "r"))]
- "((REGNO (operands[0]) & 3) == 0)
- && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[0]) + 1 == REGNO (operands[2]))
- && (REGNO (operands[1]) + 1 == REGNO (operands[3]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[4]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[5]))"
- "movt %1,%0")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=r")
- (match_operand:SI 1 "register_operand" "r"))
- (set (match_operand:SI 2 "register_operand" "=r")
- (match_operand:SI 3 "register_operand" "r"))]
- "((REGNO (operands[0]) & 1) == 0)
- && ((REGNO (operands[1]) & 1) == 0)
- && (REGNO (operands[0]) + 1 == REGNO (operands[2]))
- && (REGNO (operands[1]) + 1 == REGNO (operands[3]))"
- "movl %1,%0")
-\f
-; Multiple register loads.
-
-;; Matched 6/15/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=r")
- (mem:SI (plus:SI (match_operand:SI 1 "register_operand" "r")
- (match_operand:SI 2 "immediate_operand" "n"))))
- (set (match_operand:SI 3 "register_operand" "=r")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 4 "immediate_operand" "n"))))
- (set (match_operand:SI 5 "register_operand" "=r")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 6 "immediate_operand" "n"))))
- (set (match_operand:SI 7 "register_operand" "=r")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 8 "immediate_operand" "n"))))]
- "(i960_si_ti (operands[1], operands[2]) && ((REGNO (operands[0]) & 3) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 1 == REGNO (operands[3]))
- && (REGNO (operands[1]) != REGNO (operands[3]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[5]))
- && (REGNO (operands[1]) != REGNO (operands[5]))
- && (REGNO (operands[0]) + 3 == REGNO (operands[7]))
- && (INTVAL (operands[2]) + 4 == INTVAL (operands[4]))
- && (INTVAL (operands[2]) + 8 == INTVAL (operands[6]))
- && (INTVAL (operands[2]) + 12 == INTVAL (operands[8])))"
- "ldq %2(%1),%0")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (match_operand:DF 0 "register_operand" "=d")
- (mem:DF (plus:SI (match_operand:SI 1 "register_operand" "d")
- (match_operand:SI 2 "immediate_operand" "n"))))
- (set (match_operand:DF 3 "register_operand" "=d")
- (mem:DF (plus:SI (match_dup 1)
- (match_operand:SI 4 "immediate_operand" "n"))))]
- "(i960_si_ti (operands[1], operands[2]) && ((REGNO (operands[0]) & 3) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[3]))
- && (REGNO (operands[1]) != REGNO (operands[3]))
- && (INTVAL (operands[2]) + 8 == INTVAL (operands[4])))"
- "ldq %2(%1),%0")
-
-;; Matched 1/24/92
-(define_peephole
- [(set (match_operand:DI 0 "register_operand" "=d")
- (mem:DI (plus:SI (match_operand:SI 1 "register_operand" "d")
- (match_operand:SI 2 "immediate_operand" "n"))))
- (set (match_operand:DI 3 "register_operand" "=d")
- (mem:DI (plus:SI (match_dup 1)
- (match_operand:SI 4 "immediate_operand" "n"))))]
- "(i960_si_ti (operands[1], operands[2]) && ((REGNO (operands[0]) & 3) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[3]))
- && (REGNO (operands[1]) != REGNO (operands[3]))
- && (INTVAL (operands[2]) + 8 == INTVAL (operands[4])))"
- "ldq %2(%1),%0")
-
-;; Matched 4/17/92
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=d")
- (mem:SI (match_operand:SI 1 "register_operand" "d")))
- (set (match_operand:SI 2 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 3 "immediate_operand" "n"))))
- (set (match_operand:SI 4 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 5 "immediate_operand" "n"))))
- (set (match_operand:SI 6 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 7 "immediate_operand" "n"))))]
- "(i960_si_ti (operands[1], 0) && ((REGNO (operands[0]) & 3) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 1 == REGNO (operands[2]))
- && (REGNO (operands[1]) != REGNO (operands[2]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[4]))
- && (REGNO (operands[1]) != REGNO (operands[4]))
- && (REGNO (operands[0]) + 3 == REGNO (operands[6]))
- && (INTVAL (operands[3]) == 4)
- && (INTVAL (operands[5]) == 8)
- && (INTVAL (operands[7]) == 12))"
- "ldq (%1),%0")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=d")
- (mem:SI (plus:SI (match_operand:SI 1 "register_operand" "d")
- (match_operand:SI 2 "immediate_operand" "n"))))
- (set (match_operand:SI 3 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 4 "immediate_operand" "n"))))
- (set (match_operand:SI 5 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 6 "immediate_operand" "n"))))]
- "(i960_si_ti (operands[1], operands[2]) && ((REGNO (operands[0]) & 3) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 1 == REGNO (operands[3]))
- && (REGNO (operands[1]) != REGNO (operands[3]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[5]))
- && (INTVAL (operands[2]) + 4 == INTVAL (operands[4]))
- && (INTVAL (operands[2]) + 8 == INTVAL (operands[6])))"
- "ldt %2(%1),%0")
-
-;; Matched 6/15/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=d")
- (mem:SI (match_operand:SI 1 "register_operand" "d")))
- (set (match_operand:SI 2 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 3 "immediate_operand" "n"))))
- (set (match_operand:SI 4 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 5 "immediate_operand" "n"))))]
- "(i960_si_ti (operands[1], 0) && ((REGNO (operands[0]) & 3) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 1 == REGNO (operands[2]))
- && (REGNO (operands[1]) != REGNO (operands[2]))
- && (REGNO (operands[0]) + 2 == REGNO (operands[4]))
- && (INTVAL (operands[3]) == 4)
- && (INTVAL (operands[5]) == 8))"
- "ldt (%1),%0")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=d")
- (mem:SI (plus:SI (match_operand:SI 1 "register_operand" "d")
- (match_operand:SI 2 "immediate_operand" "n"))))
- (set (match_operand:SI 3 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 4 "immediate_operand" "n"))))]
- "(i960_si_di (operands[1], operands[2]) && ((REGNO (operands[0]) & 1) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 1 == REGNO (operands[3]))
- && (INTVAL (operands[2]) + 4 == INTVAL (operands[4])))"
- "ldl %2(%1),%0")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (match_operand:SI 0 "register_operand" "=d")
- (mem:SI (match_operand:SI 1 "register_operand" "d")))
- (set (match_operand:SI 2 "register_operand" "=d")
- (mem:SI (plus:SI (match_dup 1)
- (match_operand:SI 3 "immediate_operand" "n"))))]
- "(i960_si_di (operands[1], 0) && ((REGNO (operands[0]) & 1) == 0)
- && (REGNO (operands[1]) != REGNO (operands[0]))
- && (REGNO (operands[0]) + 1 == REGNO (operands[2]))
- && (INTVAL (operands[3]) == 4))"
- "ldl (%1),%0")
-\f
-; Multiple register stores.
-
-;; Matched 5/28/91
-(define_peephole
- [(set (mem:SI (plus:SI (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "immediate_operand" "n")))
- (match_operand:SI 2 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 3 "immediate_operand" "n")))
- (match_operand:SI 4 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 5 "immediate_operand" "n")))
- (match_operand:SI 6 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 7 "immediate_operand" "n")))
- (match_operand:SI 8 "register_operand" "d"))]
- "(i960_si_ti (operands[0], operands[1]) && ((REGNO (operands[2]) & 3) == 0)
- && (REGNO (operands[2]) + 1 == REGNO (operands[4]))
- && (REGNO (operands[2]) + 2 == REGNO (operands[6]))
- && (REGNO (operands[2]) + 3 == REGNO (operands[8]))
- && (INTVAL (operands[1]) + 4 == INTVAL (operands[3]))
- && (INTVAL (operands[1]) + 8 == INTVAL (operands[5]))
- && (INTVAL (operands[1]) + 12 == INTVAL (operands[7])))"
- "stq %2,%1(%0)")
-
-;; Matched 6/16/91
-(define_peephole
- [(set (mem:DF (plus:SI (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "immediate_operand" "n")))
- (match_operand:DF 2 "register_operand" "d"))
- (set (mem:DF (plus:SI (match_dup 0)
- (match_operand:SI 3 "immediate_operand" "n")))
- (match_operand:DF 4 "register_operand" "d"))]
- "(i960_si_ti (operands[0], operands[1]) && ((REGNO (operands[2]) & 3) == 0)
- && (REGNO (operands[2]) + 2 == REGNO (operands[4]))
- && (INTVAL (operands[1]) + 8 == INTVAL (operands[3])))"
- "stq %2,%1(%0)")
-
-;; Matched 4/17/92
-(define_peephole
- [(set (mem:DI (plus:SI (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "immediate_operand" "n")))
- (match_operand:DI 2 "register_operand" "d"))
- (set (mem:DI (plus:SI (match_dup 0)
- (match_operand:SI 3 "immediate_operand" "n")))
- (match_operand:DI 4 "register_operand" "d"))]
- "(i960_si_ti (operands[0], operands[1]) && ((REGNO (operands[2]) & 3) == 0)
- && (REGNO (operands[2]) + 2 == REGNO (operands[4]))
- && (INTVAL (operands[1]) + 8 == INTVAL (operands[3])))"
- "stq %2,%1(%0)")
-
-;; Matched 1/23/92
-(define_peephole
- [(set (mem:SI (match_operand:SI 0 "register_operand" "d"))
- (match_operand:SI 1 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 2 "immediate_operand" "n")))
- (match_operand:SI 3 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 4 "immediate_operand" "n")))
- (match_operand:SI 5 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 6 "immediate_operand" "n")))
- (match_operand:SI 7 "register_operand" "d"))]
- "(i960_si_ti (operands[0], 0) && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[1]) + 1 == REGNO (operands[3]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[5]))
- && (REGNO (operands[1]) + 3 == REGNO (operands[7]))
- && (INTVAL (operands[2]) == 4)
- && (INTVAL (operands[4]) == 8)
- && (INTVAL (operands[6]) == 12))"
- "stq %1,(%0)")
-
-;; Matched 5/29/91
-(define_peephole
- [(set (mem:SI (plus:SI (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "immediate_operand" "n")))
- (match_operand:SI 2 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 3 "immediate_operand" "n")))
- (match_operand:SI 4 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 5 "immediate_operand" "n")))
- (match_operand:SI 6 "register_operand" "d"))]
- "(i960_si_ti (operands[0], operands[1]) && ((REGNO (operands[2]) & 3) == 0)
- && (REGNO (operands[2]) + 1 == REGNO (operands[4]))
- && (REGNO (operands[2]) + 2 == REGNO (operands[6]))
- && (INTVAL (operands[1]) + 4 == INTVAL (operands[3]))
- && (INTVAL (operands[1]) + 8 == INTVAL (operands[5])))"
- "stt %2,%1(%0)")
-
-;; Matched 5/29/91
-(define_peephole
- [(set (mem:SI (match_operand:SI 0 "register_operand" "d"))
- (match_operand:SI 1 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 2 "immediate_operand" "n")))
- (match_operand:SI 3 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 4 "immediate_operand" "n")))
- (match_operand:SI 5 "register_operand" "d"))]
- "(i960_si_ti (operands[0], 0) && ((REGNO (operands[1]) & 3) == 0)
- && (REGNO (operands[1]) + 1 == REGNO (operands[3]))
- && (REGNO (operands[1]) + 2 == REGNO (operands[5]))
- && (INTVAL (operands[2]) == 4)
- && (INTVAL (operands[4]) == 8))"
- "stt %1,(%0)")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (mem:SI (plus:SI (match_operand:SI 0 "register_operand" "d")
- (match_operand:SI 1 "immediate_operand" "n")))
- (match_operand:SI 2 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 3 "immediate_operand" "n")))
- (match_operand:SI 4 "register_operand" "d"))]
- "(i960_si_di (operands[0], operands[1]) && ((REGNO (operands[2]) & 1) == 0)
- && (REGNO (operands[2]) + 1 == REGNO (operands[4]))
- && (INTVAL (operands[1]) + 4 == INTVAL (operands[3])))"
- "stl %2,%1(%0)")
-
-;; Matched 5/28/91
-(define_peephole
- [(set (mem:SI (match_operand:SI 0 "register_operand" "d"))
- (match_operand:SI 1 "register_operand" "d"))
- (set (mem:SI (plus:SI (match_dup 0)
- (match_operand:SI 2 "immediate_operand" "n")))
- (match_operand:SI 3 "register_operand" "d"))]
- "(i960_si_di (operands[0], 0) && ((REGNO (operands[1]) & 1) == 0)
- && (REGNO (operands[1]) + 1 == REGNO (operands[3]))
- && (INTVAL (operands[2]) == 4))"
- "stl %1,(%0)")
+++ /dev/null
-/* Definitions for rtems targeting an Intel i960.
- Copyright (C) 1996, 1997, 2000, 2002 Free Software Foundation, Inc.
- Contributed by Joel Sherrill (joel@OARcorp.com).
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* Target OS builtins. */
-#define TARGET_OS_CPP_BUILTINS() \
- do \
- { \
- builtin_define ("__rtems__"); \
- builtin_assert ("system=rtems"); \
- } \
- while (0)
+++ /dev/null
-LIB2FUNCS_EXTRA = xp-bit.c
-
-# We want fine grained libraries, so use the new code to build the
-# floating point emulation libraries.
-FPBIT = fp-bit.c
-DPBIT = dp-bit.c
-
-dp-bit.c: $(srcdir)/config/fp-bit.c
- echo '#define FLOAT_BIT_ORDER_MISMATCH' > dp-bit.c
- cat $(srcdir)/config/fp-bit.c >> dp-bit.c
-
-fp-bit.c: $(srcdir)/config/fp-bit.c
- echo '#define FLOAT' > fp-bit.c
- echo '#define FLOAT_BIT_ORDER_MISMATCH' >> fp-bit.c
- cat $(srcdir)/config/fp-bit.c >> fp-bit.c
-
-xp-bit.c: $(srcdir)/config/fp-bit.c
- echo '#define EXTENDED_FLOAT_STUBS' > xp-bit.c
- cat $(srcdir)/config/fp-bit.c >> xp-bit.c
-
-i960-c.o: $(srcdir)/config/i960/i960-c.c $(CONFIG_H) $(SYSTEM_H) \
- coretypes.h $(TM_H) $(CPPLIB_H) $(TREE_H) c-pragma.h toplev.h $(GGC_H) $(TM_P_H)
- $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)/config/i960/i960-c.c
-
-MULTILIB_OPTIONS=mnumerics/msoft-float mlong-double-64
-MULTILIB_DIRNAMES=float soft-float ld64
-MULTILIB_MATCHES=mnumerics=msb mnumerics=msc mnumerics=mkb mnumerics=mkc mnumerics=mmc mnumerics=mcb mnumerics=mcc mnumerics=mjf msoft-float=msa msoft-float=mka msoft-float=mca msoft-float=mcf
-
-LIBGCC = stmp-multilib
-INSTALL_LIBGCC = install-multilib
+++ /dev/null
-2004-09-06 Release Manager
-
- * GCC 3.4.2 released.
-
-2004-09-02 Eric Botcazou <ebotcazou@libertysurf.fr>
-
- PR fortran/17180
- * malloc.c (MALLOC_ALIGNMENT): Rename into MAX_ALIGNMENT
- and use a host-based heuristics to determine it.
- (ROUNDED_AREA_SIZE): Adjust.
-
-2004-09-01 Eric Botcazou <ebotcazou@libertysurf.fr>
-
- PR fortran/17180
- * malloc.c (MALLOC_ALIGNMENT): New constant.
- (ROUNDED_AREA_SIZE): Likewise.
- (malloc_kill_area_): Use ROUNDED_AREA_SIZE.
- (malloc_find_inpool_): Likewise.
- (malloc_new_inpool_): Likewise.
- (malloc_resize_inpool_): Likewise.
-
-2004-07-12 Bud Davis <bdavis9659@comcast.net>
-
- * bld.c (ffebld_constant_new_character1, ffebld_constant_new_complex{1,2},
- ffebld_constant_new_hollerith, ffebld_constant_new_integer1,
- ffebld_constant_new_integer{1,2,3,4}_val, ffebld_constant_new_logical1,
- ffebld_constant_new_logical{1,2,3,4}_val, ffebld_constant_new_real{1,2},
- ffebld_constant_new_typeless_ov):
- Fill and use `rlink' and `llink' pointers in _ffebld_ struct.
- * bld.h (struct _ffebld_): remove 'next' pointer, add
- `rlink, llink' pointers; remove `negate' entry.
- * malloc.c (malloc_kill_area_): Adapt for new `mallocArea' pointer.
- (malloc_display_): Adapt.
- (malloc_new_inpool_): Set it.
- (malloc_resize_inpool_): Ditto.
-
-2004-07-01 Release Manager
-
- * GCC 3.4.1 released.
-
-2004-06-17 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Note that GCC 3.4.x is the last version
- of GCC to contain g77.
-
-2004-05-18 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * bugs.texi, news.texi: Don't reference mainline versions.
-
-2004-05-16 Gerald Pfeifer <gerald@pfeifer.com>
-
- * g77.texi (Floating-point Errors): Fix typo.
-
-2004-05-07 Gerald Pfeifer <gerald@pfeifer.com>
-
- * g77.texi (Floating-point Errors): Avoid referencing
- http://www.linuxsupportline.com/~billm/ which as has been hijacked;
- add a reference to the official IEEE 754 site.
-
-2004-04-18 Release Manager
-
- * GCC 3.4.0 released.
-
-2004-03-21 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * g77.texi: Update link to "G++ and GCC".
-
-2004-03-14 Gerald Pfeifer <gerald@pfeifer.com>
-
- * g77.texi (Aligned Data): Remove obsolete paragraph including a
- broken link.
- (Floating-point Errors): Remove links to http://www.validgh.com/
- which was "hijacked".
- (Language): Fix link to Fortran books.
- (Projects): Remove obsolete paragraph including a broken link to
- ftp://alpha.gnu.org/gnu/g77/projects/.
- (Trouble): Remove obsolete paragraph including a broken link to
- ftp://alpha.gnu.org/g77.plan.
-
- * invoke.texi (Overall Options): Remove broken reference to
- rat7.uue (which was of dubious copyright status anyways).
-
- * root.texi (www-burley): Fix URL.
-
-2004-03-06 Roger Sayle <roger@eyesopen.com>
-
- * parse.c (ffe_parse_file): Handle the case that main_input_filename
- is NULL.
-
-2004-02-24 Michael Matz <matz@suse.de>
-
- * Make-lang.in (sta.o-warn): Delete.
- * sta.c (ffesta_save_): Don't break aliasing rules.
-
-2004-02-20 Kazu Hirata <kazu@cs.umass.edu>
-
- * Make-lang.in (g77spec.o): Depend on intl.h.
- * g77spec.c: Include intl.h.
- (lang_specific_driver): Allow translation of the copyright
- symbol but not the rest of the copyright message. Allow
- translation of the message about warranty.
-
-2004-02-15 Roger Sayle <roger@eyesopen.com>
-
- PR fortran/14129
- * lex.c (ffelex_cfelex_): Avoid calling xrealloc on a local stack
- allocated array.
-
-2004-01-30 Kelley Cook <kcook@gcc.gnu.org>
-
- * Make-lang.in (doc/g77.dvi): Use $(abs_docdir).
-
-2004-01-20 Kelley Cook <kcook@gcc.gnu.org>
-
- * Make-lang.in: Replace $(docdir) with doc.
- (TEXI_G77_FILES): Define.
- (f77.rebuilt): Delete.
- (f77.srcextra): Add dependencies on f/BUGS and f/NEWS.
- (f77.srcman, f77.srcinfo, f77.man, f77.info): New rules.
- (doc/g77.info, doc/g77.dvi): Depend on TEXI_G77_FILES. Always build in
- doc directory. Use $(MAKEINFOFLAGS).
- (info, dvi, generated_manpages): Update to look in doc directory.
- (f/BUGS, f/NEWS): Generate in build directory.
- (f77.mostlyclean): Delete BUGS and NEWS from build directory.
- (f77.maintainer-clean): Adjust to delete from source directory.
- (f77.install-man): Revamp rule.
-
-2004-01-19 Kelley Cook <kcook@gcc.gnu.org>
-
- * Make-lang.in (G77_INSTALL_NAME): Define via a immediate $(shell)
- instead of deferred backquote.
-
-2004-01-15 Kelley Cook <kcook@gcc.gnu.org>
-
- * Make-lang.in (f77.srcextra): Dummy entry.
-
-2004-01-13 Ian Lance Taylor <ian@wasabisystems.com>
-
- PR fortran/6491
- * expr.c (ffeexpr_reduce_): When handling AND, OR, and XOR, and
- when using -fugly-logint, if both operands are logical, convert
- the result back to logical.
- (ffeexpr_reduced_ugly2log_): Add bothlogical parameter. Change
- all callers. Convert logical operands to integer.
-
-2004-01-12 Ian Lance Taylor <ian@wasabisystems.com>
-
- * README: Remove.
-
-2004-01-07 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * com.h (ffecom_gfrt_basictype): Correct return type.
-
-2003-12-29 Roger Sayle <roger@eyesopen.com>
-
- PR fortran/12632
- * com.c (ffecom_subscript_check_): Take as an extra argument the
- (possibly NULL) decl of the array. Don't create unnecessary tree
- nodes if the array index is known to be safe at compile-time.
- If the array index is unsafe, force the array decl into memory to
- avoid RTL expansion problems.
- (ffecom_array_ref_): Update calls to ffecom_subscript_check_.
- (ffecom_char_args_x_): Likewise.
-
-2003-12-06 Kelley Cook <kcook@gcc.gnu.org>
-
- * Make-lang.in (G77_CROSS_NAME): Delete.
- (g77.install_common, g77.install-man, g77.uninstall): Adjust for above.
-
-2003-11-30 Andreas Jaeger <aj@suse.de>
-
- * Make-lang.in (f77.rebuilt): Fix dependency on g77.info.
-
-2003-11-24 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/12633
- * expr.c (ffeexpr_reduced_ugly2log_): Revert
- change allowing logical .and. logical to be
- integer in expressions when -fugly-logint.
-
-2003-11-21 Kelley Cook <kcook@gcc.gnu.org>
-
- * .cvsignore: Delete.
-
-2003-11-20 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * Make-lang.in (f77.extraclean): Delete.
-
-2003-11-20 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * Make-lang.in (check-f77, lang_checks): Add.
-
-2003-11-16 Jason Merrill <jason@redhat.com>
-
- * Make-lang.in (f77.tags): Create TAGS.sub files in each directory
- and TAGS files that include them for each front end.
-
-2003-11-12 Andreas Jaeger <aj@suse.de>
-
- * intdoc.in (Signal Intrinsic (subroutine)): Fix texinfo warning
- using @code.
- * intdoc.texi: Regenerated.
-
-2003-11-03 Kelley Cook <kcook@gcc.gnu.org>
-
- * Make-lang.in (dvi): Move targets to $(docobjdir).
- (g77.dvi): Simplify rule.
- (g77.info): Sinplify rule.
- (g77.1): Delete.
- (g77.pod): New intermediate rule.
-
-2003-10-31 Jakub Jelinek <jakub@redhat.com>
-
- * com.c (ffecom_sym_transform_): Set tree type of offset
- to ssizetype.
-
-2003-10-21 Kelley Cook <kcook@gcc.gnu.org>
-
- * Make-lang.in (f/g77.1): Honor $(docobjdir).
- ($(docobjdir)/g77.info): Replace $(srcdir)/doc with $(docdir).
- (f/g77.dvi): Likewise.
-
-2003-10-21 Jan Hubicka <jh@suse.cz>
-
- * lex.c (ffelex_cfelex_): Initialize d.
-
-Mon Oct 20 23:15:46 2003 Mark Mitchell <mark@codesourcery.com>
-
- * Make-lang.in ($(docobjdir)/g77.info): Add dependency on
- stmp-docobjdir.
-
-Mon Oct 20 13:49:43 2003 Mark Mitchell <mark@codesourcery.com>
-
- * Make-lang.in (.PHONY): Remove f77.info, f77.install-info.
- (info): Update dependencies.
- ($(srcdir)/f/g77.info): Replace with ...
- ($(docobjdir)/g77.info): ... this.
- (f77.install-info): Remove.
- (install-info): New target.
-
-2003-10-06 Mark Mitchell <mark@codesourcery.com>
-
- * Make-lang.in (f77.info): Replace with ...
- (info): ... this.
- (f77.dvi): Replace with ...
- (dvi): ... this.
- (f77.generated-manpages): Replace with ...
- (generated-manpages): ... this.
-
-2003-09-29 Zack Weinberg <zack@codesourcery.com>
-
- * target.c (FFETARGET_ATOF_): Delete.
- (ffetarget_real1, ffetarget_real2): Use real_from_string directly.
- * target.h (FFETARGET_REAL_VALUE_FROM_INT_,
- FFETARGET_REAL_VALUE_FROM_LONGLONG_): Use mode_for_size,
- don't refer to SFmode or DFmode directly.
-
-2003-09-28 Richard Henderson <rth@redhat.com>
-
- * com.c (duplicate_decls): Copy DECL_SOURCE_LOCATION, not
- file and line separately.
-
-2003-09-21 Richard Henderson <rth@redhat.com>
-
- * com.c, ste.c: Revert.
-
-2003-09-21 Richard Henderson <rth@redhat.com>
-
- * com.c, ste.c: Update for DECL_SOURCE_LOCATION rename and
- change to const.
-
-2003-09-21 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Update with fixed PR's.
-
-2003-09-21 George Helffrich <bugzilla@w170.uklinux.net>
-
- * g77.texi: Remove ancient part about debugging COMMON
- and EQUIVALENCE not correctly.
-
-2003-09-18 Roger Sayle <roger@eyesopen.com>
-
- * com.c (ffecom_overlap_): Remove FFS_EXPR case.
- (ffecom_tree_canonize_ref_): Likewise.
- (ffe_truthvalue_conversion): Likewise.
-
-2003-09-01 Josef Zlomek <zlomekj@suse.cz>
-
- * com.c (ffecom_overlap_): Kill BIT_ANDTC_EXPR.
- (ffecom_tree_canonize_ref_): Kill BIT_ANDTC_EXPR.
-
-Thu Jul 31 01:47:27 2003 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_init_0): Use `dconsthalf'.
-
-Sat Jul 19 12:03:03 2003 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c data.c expr.c fini.c g77spec.c global.c lab.c lex.c name.c
- sta.c stc.c std.c storag.c stt.c stw.c symbol.c target.c type.c:
- Remove unnecessary casts.
-
-Thu Jul 17 06:34:41 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * lang-options.h: Remove.
- * lang.opt: Document most options.
-
-2003-07-14 Geoffrey Keating <geoffk@apple.com>
-
- * lang-specs.h (f77-cpp-input): Use -o to specify the CPP output file.
-
-2003-07-10 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * ffe.texi: Correctly use @var{srcdir}.
-
-2003-07-09 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR Fortran/11301
- * com.c (ffecom_sym_transform_): finish_decl should have
- the same last argument as start_decl.
-
-2003-07-08 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * Make-lang.in (f/g77.dvi): Use PWD_COMMAND.
-
-2003-07-08 Zack Weinberg <zack@codesourcery.com>
-
- * lex.c: Remove error block #ifdef MAP_CHARACTER.
-
-Mon Jul 7 18:13:22 2003 Nathan Sidwell <nathan@codesourcery.com>
-
- * com.c (bison_rule_pushlevel_, bison_rule_compstmt_): Adjust
- emit_line_note calls.
- * ste.c (ffeste_emit_line_note_): Likewise.
-
-2003-07-06 Andreas Jaeger <aj@suse.de>
-
- * bad.c: Convert () to (void) in function definitions.
- * bld.c: Likewise.
- * data.c: Likewise.
- * equiv.c: Likewise.
- * expr.c: Likewise.
- * global.c: Likewise.
- * implic.c: Likewise.
- * info.c: Likewise.
- * intdoc.c: Likewise.
- * intrin.c: Likewise.
- * lab.c: Likewise.
- * lex.c: Likewise.
- * malloc.c: Likewise.
- * src.c: Likewise.
- * st.c: Likewise.
- * sta.c: Likewise.
- * stb.c: Likewise.
- * stc.c: Likewise.
- * std.c: Likewise.
- * ste.c: Likewise.
- * storag.c: Likewise.
- * stt.c: Likewise.
- * stw.c: Likewise.
- * symbol.c: Likewise.
- * top.c: Likewise.
- * where.c: Likewise.
-
- * com.c: Convert prototypes to ISO C90.
- * com.h: Likewise.
- * g77spec.c: Likewise.
-
-Sun Jul 6 20:01:29 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * top.c (ffe_handle_option): Don't handle filenames.
-
-2003-07-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR Fortran/11301
- * com.c (ffecom_sym_transform_): Only install
- FFEINFO_whereGLOBAL symbols in the global binding
- level if not -fno-globals.
-
-Wed Jul 2 21:16:02 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * top.c (ffe_init_options): Update prototype.
- * top.h (ffe_init_options): Update prototype.
-
-2003-06-27 Zack Weinberg <zack@codesourcery.com>
-
- * com.c (input_file_stack_tick): Delete redundant declaration.
-
-Thu Jun 26 07:06:29 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * top.c (ffe_handle_option): Don't check for missing arguments.
-
-Wed Jun 25 06:52:12 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * top.c (ffe_handle_option): Add missing break;.
-
-2003-06-24 Scott Snyder <snyder@fnal.gov>
-
- PR fortran/11299
- * com.c (ffe_init): Call push_srcloc() to ensure that
- input_file_stack is initialized.
-
-Sat Jun 21 21:29:38 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * lang.opt: Add -fpreprocessed.
- * top.c (ffe_handle_option): Handle it.
-
-Fri Jun 20 10:00:31 2003 Nathan Sidwell <nathan@codesourcery.com>
-
- * com.c (finish_function): Adjust expand_function_end call.
-
-2003-06-17 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * Make-lang.in: Replace BUILD_CC references with CC_FOR_BUILD.
-
-Sun Jun 15 15:56:51 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * lang.opt: Declare F77.
-
-Sat Jun 14 18:13:00 2003 Nathan Sidwell <nathan@codesourcery.com>
-
- * com.c (stor_parm_decls): Adjust init_function_start call.
-
-Sat Jun 14 13:25:00 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * Make-lang.in: Update to use options.c and options.h.
- * top.c: Include options.h not f-options.h.
- (ffe_init_options): From com.c. Request F77 options.
- (ffe_handle_options): Abort on unrecognized switch.
- * com.c (ffe_init_options): Move to top.c.
- * top.h (fee_init_options): New.
-
-2003-06-13 Richard Henderson <rth@redhat.com>
-
- PR debug/9864
- * com.c (ffecom_sym_transform_): Install FFEINFO_whereGLOBAL
- symbols in the global binding level.
-
-Sun Jun 8 15:42:09 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * Make-lang.in (F77_OBJS, f77.mostlyclean, f/com.o): Update.
- (f/f-options.c, f/f-options.h): New.
- * com.c: Include opts.h and f-options.h.
- (ffecom_decode_include_option_): Remove.
- (LANG_HOOKS_HANDLE_OPTION): New.
- (LANG_HOOKS_DECODE_OPTION): Drop.
- (struct file_name_list, ffecom_decode_include_option,
- ffecom_open_include_): Constify.
- * com.h (ffecom_decode_include_option): Update.
- * lang.opt: New.
- * top.c: Include f-options.h, opts.h.
- (ffe_is_digit_string_): Constify.
- (ffe_decode_option): Transform to ffe_handle_option.
- * top.h (ffe_decode_option): Replace with ffe_handle_option.
-
-2003-06-08 Andreas Jaeger <aj@suse.de>
-
- * std.c: Remove #if 0'ed functions.
-
- * sta.c: Remove usage of HARD_F90, FFESTR_F90 and FFESTR_VXT.
- * stb.c: Likewise.
- * stb.h: Likewise.
- * stc.c: Likewise.
- * stc.h: Likewise.
- * std.c: Likewise.
- * std.h: Likewise.
- * ste.c: Likewise.
- * ste.h: Likewise.
-
- * str.h (FFESTR_F90): Remove macro.
- (FFESTR_VXT): Remove macro.
-
- * bld.c: Remove usage of FFETARGET_okCHARACTER2,
- FFETARGET_okCHARACTER3, FFETARGET_okCHARACTER4,
- FFETARGET_okCHARACTER5, FFETARGET_okCHARACTER6,
- FFETARGET_okCHARACTER7, FFETARGET_okCHARACTER8,
- FFETARGET_okCOMPLEX4, FFETARGET_okCOMPLEX5, FFETARGET_okCOMPLEX6,
- FFETARGET_okCOMPLEX7, FFETARGET_okCOMPLEX8, FFETARGET_okINTEGER5,
- FFETARGET_okINTEGER6, FFETARGET_okINTEGER7, FFETARGET_okINTEGER8,
- FFETARGET_okLOGICAL5, FFETARGET_okLOGICAL6, FFETARGET_okLOGICAL7,
- FFETARGET_okLOGICAL8, FFETARGET_okREAL4, FFETARGET_okREAL5,
- FFETARGET_okREAL6, FFETARGET_okREAL7 and FFETARGET_okREAL8.
- * bld.h: Likewise.
- * expr.c: Likewise.
- * target.h: Likewise.
- * com.c: Likewise.
-
-Sun Jun 8 12:28:14 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * Make-lang.in: Update.
- * top.c: Include opts.h. Define cl_options_count and cl_options.
-
-2003-06-07 Andreas Jaeger <aj@suse.de>
-
- * symbol.c (ffesymbol_new_): Remove tests for macro
- FFECOM_symbolHOOK.
- * symbol.h: Likewise.
-
- * storag.c (ffestorag_new): Remove tests for macro
- FFECOM_storageHOOK.
- * storag.h: Likewise.
-
- * lab.c (ffelab_new): Remove tests for macro FFECOM_labelHOOK.
- * lab.h: Likewise.
-
- * global.c: Remove tests for macro FFECOM_globalHOOK.
- * global.h (struct _ffeglobal_): Likewise.
-
- * bld.h: Remove tests for macros FFECOM_constantHOOK,
- FFECOM_nonterHOOK, FFECOM_globalHOOK, FFECOM_labelHOOK,
- FFECOM_storageHOOK, FFECOM_symbolHOOK.
- Remove code dependend on FFECOM_itemHOOK.
- * bld.c: Likewise.
-
- * com.h (FFECOM_constantHOOK): Remove define.
- (FFECOM_nonterHOOK): Remove.
- (FFECOM_globalHOOK): Remove.
- (FFECOM_labelHOOK): Remove.
- (FFECOM_storageHOOK): Remove.
- (FFECOM_symbolHOOK): Remove.
-
- * com.c (ffecom_get_external_identifier_): Remove usage of
- FFETARGET_isENFORCED_MAIN_NAME.
-
- * bld.c: Remove code dependend on FFEBLD_BLANK_, FFECOM_itemHOOK.
- (ffebld_new_accter): Likewise.
- (ffebld_new_arrter): Likewise.
- (ffebld_new_conter_with_orig): Likewise.
- (ffebld_new_item): Likewise.
- (ffebld_new_labter): Likewise.
- (ffebld_new_labtok): Likewise.
- (ffebld_new_none): Likewise.
- (ffebld_new_one): Likewise.
- (ffebld_new_symter): Likewise.
- (ffebld_new_two): Likewise.
-
-Sat Jun 7 12:10:41 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * com.c (ffe_init_options): Update.
-
-Thu Jun 5 18:33:40 CEST 2003 Jan Hubicka <jh@suse.cz>
-
- * Make-lang.in: Add support for stageprofile and stagefeedback
-
-2003-06-04 Andreas Jaeger <aj@suse.de>
-
- * g77spec.c (lang_specific_driver): Remove ALT_LIBM usage.
-
-2003-06-01 Bud Davis <bdavis9659@comcast.net>
-
- * ste.c (ffeste_R838): Handle ERROR_MARK.
- (ffeste_R839): Ditto.
-
-2003-06-01 Andreas Jaeger <aj@suse.de>
-
- * lex.c (ffelex_file_fixed): Remove usage of
- REDUCE_CARD_SIZE_AFTER_BIGGY.
-
- * expr.c (ffeexpr_exprstack_push_operand_): Remove code depenend
- on WEIRD_NONFORTRAN_RULES.
-
- * com.c (ffecom_arg_ptr_to_expr): Remove
- PASS_HOLLERITH_BY_DESCRIPTOR dependend code.
- (ffecom_const_expr): Remove usage of NEWCOMMON.
- (ffecom_expand_let_stmt): Remove MOVE_EXPR.
-
-2003-05-31 Bud Davis <bdavis9659@comcast.net>
-
- PR fortran/10843
- * sta.c (ffesta_second_): Parse GO TO correctly,
- even in free source format.
-
-2003-05-31 Andreas Jaeger <aj@suse.de>
-
- * lex.c (ffelex_hash_): Remove HANDLE_PRAGMA and
- HANDLE_GENERIC_PRAGMA dependend code, remove #if 0 code.
- (pragma_getc): Removed.
- (pragma_ungetc): Removed.
-
-2003-05-30 Roger Sayle <roger@eyesopen.com>
-
- * com.c (ffecom_init_0): Define built-in functions for tan and atan.
- * com-rt.def: Use then to implement g77's tan and atan intrinsics.
-
-2003-05-22 Bud Davis <bdavis9659@comcast.net>
-
- * com.c (ffecom_sym_transform_): Error out on unallocatable
- storage after type is set.
-
-2003-05-18 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * intdoc.in: Fix documentation of IDATE.
- * intdoc.texi: Regenerate.
- * news.texi: Update due to also fixing it in 3.3.1.
-
-2003-05-16 Wolfgang Bangerth <bangerth@dealii.org>
-
- * g77.texi: Remove most of the of the preface of the
- bugs section.
-
-2003-05-15 Wolfgang Bangerth <bangerth@dealii.org>
-
- * g77.texi: Remove most of the bug reporting instructions and
- merge them into bugs.html.
-
-2003-05-13 Zack Weinberg <zack@codesourcery.com>
-
- * com.c: Replace all calls to fatal_io_error with calls to
- fatal_error; add ": %m" to the end of all the affected error
- messages.
-
-2003-05-12 Zack Weinberg <zack@codesourcery.com>
-
- * bad.c: Don't call diagnostic_count_diagnostic.
-
-2003-05-12 Roger Sayle <roger@eyesopen.com>
-
- * com.c (ffecom_init_0): Define built-in functions for atan2,
- exp, floor, fmod, log and pow.
- (duplicate_decls): Preserve assembler name when redeclaring a
- built-in.
- * com-rt.def: Implement using the built-in forms of the above
- functions rather than calling the standard C library directly.
- Correct some of the run-time prototype "codes".
-
-2003-05-11 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/10726
- * intdoc.in: Fix documentation of IDATE.
- * intdoc.texi: Regenerate.
- * g77.texi: Document completion of INTEGER*n support.
- * news.texi: Update due to the above.
-
-2003-05-08 Roger Sayle <roger@eyesopen.com>
-
- PR fortran/8485
- * target.h (FFETARGET_REAL_VALUE_FROM_INT_): Cast to
- HOST_WIDE_INT instead of long.
- (FFETARGET_REAL_VALUE_FROM_LONGLONG_): New macro.
- (FFETARGET_LONGLONG_FROM_INTS_): New macro.
- (ffetarget_convert_complex1_integer4): Implement.
- (ffetarget_convert_complex2_integer4): Implement.
- (ffetarget_convert_integer4_complex1): Implement.
- (ffetarget_convert_integer4_complex2): Implement.
- (ffetarget_convert_integer4_real1): Implement.
- (ffetarget_convert_integer4_real2): Implement.
- (ffetarget_convert_real1_integer4): Implement.
- (ffetarget_convert_real2_integer4): Implement.
- * com.c (ffecom_constantunion): Handle INTEGER*8.
- (ffecom_constantunion_with_type): Likewise.
-
-2003-05-03 Nathan Sidwell <nathan@codesourcery.com>
-
- * com.c (ffecom_do_entry_): Use location_t and input_location
- directly.
- (ffecom_gen_sfuncdef_): Likewise.
- (ffecom_start_progunit_): Likewise.
- (ffecom_sym_transform_): Likewise.
- (ffecom_sym_transform_assign_): Likewise.
- * lex.c (ffelex_hash_): Likewise.
- (ffelex_include_): Likewise.
- * std.c (ffestd_exec_begin): Likewise.
- (ffestd_exec_end): Likewise.
- * ste.c (struct gbe_block): Likewise.
- (ffeste_start_block_): Likewise.
- (ffeste_start_stmt_): Likewise.
-
-2003-05-03 Nathan Sidwell <nathan@codesourcery.com>
-
- * ansify.c (die_unless): Revert lineno change here.
-
-2003-05-02 Nathan Sidwell <nathan@codesourcery.com>
-
- * lex.c (ffelex_file_pop_): Adjust file_stack member use.
- (ffelex_file_push_): Likewise.
- (ffelex_hash_): Likewise.
-
-2003-05-01 Nathan Sidwell <nathan@codesourcery.com>
-
- * ansify.c (die_unless): Rename lineno to input_line.
- * com.c (ffecom_subscript_check_, ffecom_do_entry_,
- ffecom_gen_sfuncdef_, ffecom_start_progunit_,
- ffecom_sym_transform_, ffecom_sym_transform_assign_,
- bison_rule_pushlevel_, bison_rule_compstmt_, finish_function,
- store_parm_decls): Likewise.
- * intrin.c (ffeintrin_fulfill_generic): Likewise.
- * lex.c (ffelex_hash_, ffelex_include_, ffelex_next_line_,
- ffelex_file_fixed, ffelex_file_free): Likewise.
- * std.c (ffestd_exec_end): Likewise.
- * ste.c (ffeste_emit_line_note_, ffeste_start_block_,
- ffeste_start_stmt_): Likewise.
- * ste.h (ffeste_filelinenum, ffeste_set_line): Likewise.
-
- * lex.c (ffelex_file_pop_): Rename parameter from input_filename.
- (ffelex_file_push_): Likewise.
-
- * ste.c (struct gbe_block): Rename field from input_filename.
- (ffeste_start_block_, ffeste_start_stmt_): Likewise.
-
-2003-04-17 Roger Sayle <roger@eyesopen.com>
-
- PR c/10375
- * com.c (duplicate_decls): Preserve "const" and "noreturn"
- function attributes.
-
-2003-04-13 Roger Sayle <roger@eyesopen.com>
-
- * com.c (duplicate_decls): Preserve pure and malloc attributes.
-
-2003-04-12 Zack Weinberg <zack@codesourcery.com>
-
- * com.c (ffecom_build_complex_constant_, ffecom_expr_)
- (ffecom_init_zero_, ffecom_transform_namelist_, ffecom_vardesc_)
- (ffecom_vardesc_array_, ffecom_vardesc_dims_, ffecom_2)
- * ste.c (ffeste_io_ialist_, ffeste_io_cilist_, ffeste_io_cllist_)
- (ffeste_io_icilist_, ffeste_io_inlist_, ffeste_io_olist_):
- Use build_constructor.
-
-2003-04-11 Bud Davis <bdavis9659@comcast.net>
-
- PR Fortran/9263
- * gcc/f/data.c (ffedata_advance_): Check initial, final and
- increment values for INTEGER typeness.
- * gcc/f/news.texi: Document these fixes.
-
-2003-03-27 Steven Bosscher <steven@gcc.gnu.org>
-
- * ffe.texi: Don't mention dead file proj.c.
-
-2003-03-26 Roger Sayle <roger@eyesopen.com>
-
- PR fortran/9793
- * target.h (ffetarget_divide_integer1): Perform division by -1
- using negation to prevent possible overflow trap on the host.
-
-2003-03-25 Marcelo Abreu <mmabreu@inf.ufrgs.br>
-
- PR fortran/10204
- * ffe.texi: Reference the GCC web site in the URL.
-
-2003-03-24 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/10197
- * news.texi: Document PR fortran/10197 fixed.
-
-Sun Mar 23 23:43:45 2003 Mark Mitchell <mark@codesourcery.com>
-
- PR c++/7086
- * com.c (ffecom_sym_transform_): Adjust calls to
- put_var_into_stack.
- (ffe_mark_addressable): Likewise.
-
-2003-03-22 Bud Davis <bdavis9659@comcast.net>
-
- * com.c (ffecom_constantunion_with_type): New function.
- * com.h (ffecom_constantunion_with_type): Declare.
- * stc.c (ffestc_R810): Check for kind type.
- * ste.c (ffeste_R810): Use ffecom_constantunion_with_type
- to discern SELECT CASE variables.
-
-2003-03-15 Roger Sayle <roger@eyesopen.com>
-
- * stb.c (ffestb_R100110_): Allow the number before the X format
- to be optional when not -fpedantic.
- * std.c (ffestd_R1001dump_1010_3_): Delete unused static function.
- (ffestd_R1001dump_): For the FFESTP_formattypeX case, call
- ffestd_R1001dump_1010_2_ instead of ffestd_R1001dump_1010_3_.
-
-2003-03-15 Roger Sayle <roger@eyesopen.com>
-
- * f/ste.c (ffeste_R810): Fix whitespace.
-
-2003-03-15 Andreas Jaeger <aj@suse.de>
-
- * g77spec.c (DEFAULT_SWITCH_TAKES_ARG): Remove.
- (DEFAULT_WORD_SWITCH_TAKES_ARG): Remove.
-
-2003-03-12 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * g77.texi, invoke.texi, g77spec.c, lang-specs.h: GCC, not
- GNU CC. Especially here.
-
-2003-03-10 Roger Sayle <roger@eyesopen.com>
-
- * com.c (duplicate_decls): Synchronize with C's duplicate_decls.
-
-Sat Mar 8 21:11:40 2003 Neil Booth <neil@daikokuya.co.uk>
-
- * com.c (ffe_init): Update prototype; move code to ffe_post_options.
- (ffe_post_options): New.
-
-2003-03-04 Tom Tromey <tromey@redhat.com>
-
- * Make-lang.in (f77.tags): New target.
-
-2003-02-20 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document fixing PR fortran/9038.
-
-2003-02-04 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * g77.texi, invoke.texi: Update to GFDL 1.2.
-
-2003-01-31 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document fixing PR fortran/7681
- and optimization/9258.
-
-2003-01-26 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * lang-specs.h: Revoke change to (incorrectly) prohibit
- passing -f options to cc1 when preprocessing.
- * news.texi: Document this.
-
-Tue Jan 21 08:42:12 2003 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- Make-lang.in (f/sta.o-warn): Add -Wno-error.
-
-Thu Jan 16 10:53:16 2003 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (f/target.o): Depend on toplev.h.
- * target.c: Include toplev.h.
-
-Sat Jan 11 21:31:10 2003 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_convert_narrow_, ffecom_convert_widen_,
- pushdecl_top_level, storedecls, convert, delete_block,
- insert_block, ffe_init, ffe_mark_addressable, poplevel,
- ffe_print_identifier, pushdecl, pushlevel, set_block,
- ffe_signed_or_unsigned_type, ffe_signed_type,
- ffe_truthvalue_conversion, ffe_type_for_mode, ffe_type_for_size,
- ffe_unsigned_type, append_include_chain, open_include_file,
- read_filename_string, read_name_map): Convert to ISO C style function
- definitions.
- * parse.c (ffe_parse_file): Likewise.
- * top.c (ffe_is_digit_string_): Likewise.
-
-2003-01-09 Christian Cornelssen <ccorn@cs.tu-berlin.de>
-
- * Make-lang.in (f77.install-common, f77.install-info,
- f77.install-man, f77.uninstall): Prepend $(DESTDIR) to
- destination paths in all (un)installation commands.
-
-2003-01-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Revise history again:
- PR Fortran/9038 will be fixed in 3.4.
-
-2003-01-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Update news to reflect reality:
- PR Fortran/9038 won't be fixed until 3.4.
-
-2003-01-04 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR Fortran/9038
- * lang-specs.h: Remove -f options before preprocessing.
- * news.texi: Document fixing of PR Fortran/9038.
-
-2003-01-03 Bud Davis <bdavis11@directvinternet.com>
-
- * stc.c (ffestc_R810): Allow any kind integer in
- case statements.
- * ste.c (ffeste_R810): Give error message when
- case selector exceeds its valid values.
-
-2003-01-01 Andreas Jaeger <aj@suse.de>
-
- * f/Make-lang.in ($(srcdir)/f/BUGS): Add include path for
- gcc-common.texi.
- ($(srcdir)/f/NEWS): Likewise.
-
-2002-12-28 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * g77.texi: Use @copying.
-
-2002-12-23 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * root.texi: Include gcc-common.texi.
- * bugs.texi, news.texi: Don't include root.texi as part of full
- manual.
- * g77.texi: Update for use of gcc-common.texi.
- * Make-lang.in ($(srcdir)/f/g77.info, f/g77.dvi): Depend on
- $(srcdir)/doc/include/gcc-common.texi.
-
-2002-12-19 Kazu Hirata <kazu@cs.umass.edu>
-
- * intdoc.in: Fix typos.
-
-2002-12-18 Kazu Hirata <kazu@cs.umass.edu>
-
- * g77.texi: Fix typos.
- * intdoc.texi: Likewise.
- * news.texi: Follow spelling conventions.
-
-Mon Dec 16 13:53:18 2002 Mark Mitchell <mark@codesourcery.com>
-
- * root.texi: Change version number to 3.4.
-
-2002-12-15 Zack Weinberg <zack@codesourcery.com>
-
- * target.h: Don't define HOST_WIDE_INT.
-
-2002-12-02 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * Make-lang.in, ansify.c, intdoc.c, proj.h: Replace hconfig.h with
- bconfig.h.
- * fini.c, proj.h: Replace USE_HCONFIG with USE_BCONFIG
-
-2002-11-30 Zack Weinberg <zack@codesourcery.com>
-
- * proj.h, ansify.c, g77spec.c, intdoc.c:
- Include coretypes.h and tm.h.
- * Make-lang.in: Update dependencies.
-
-2002-11-20 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * invoke.texi: Explain the purpose of -fmove-all-movables,
- -freduce-all-givs and -frerun-loop-opts better.
-
-2002-11-19 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * Make-lang.in: Correct BUILD/HOST confusion.
-
-2002-11-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/8587
- * news.texi: Show PR fortran/8587 fixed.
-
-2002-11-19 Jason Thorpe <thorpej@wasabisystems.com>
-
- * g77spec.c (lang_specific_spec_functions): New.
-
-2002-11-02 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Correct documentation on generating C++ prototypes
- of Fortran routines with f2c.
- * news.texi: Document fixes in GCC-3.3, 3.2 and 3.1.
-
-2002-10-30 Roger Sayle <roger@eyesopen.com>
-
- * com.c (ffecom_subscript_check_): Cast the failure branch
- of the bounds check COND_EXPR to void, to indicate noreturn.
- (ffe_truthvalue_conversion): Only apply truth value conversion
- to the non-void branches of a COND_EXPR.
-
-2002-10-26 Andris Pavenis <pavenis@latnet.lv>
-
- * lang-specs.h: Fix ratfor specs.
-
-2002-10-15 Richard Henderson <rth@redhat.com>
-
- * target.h (ffetarget_print_real1, ffetarget_print_real2): Use
- real_to_decimal directly, and with the new arguments.
-
-2002-09-23 Zack Weinberg <zack@codesourcery.com>
-
- * Make-lang.in (g77spec.o): Don't depend on f/version.h.
- (f/parse.o): Depend on version.h not f/version.h.
- (g77version.o, f/version.o): Delete all references.
-
- * com.c (ffecom_init_0): Fix transposed array indices in bsearch test.
- * g77spec.c: Don't include f/version.h or refer to ffe_version_string.
- * parse.c: Use version_string, not ffe_version_string.
- * version.c, version.h: Delete files.
-
-2002-09-23 Kazu Hirata <kazu@cs.umass.edu>
-
- * ChangeLog: Follow spelling conventions.
- * ChangeLog.0: Likewise.
- * com.c: Likewise.
- * ffe.texi: Likewise.
- * g77.texi: Likewise.
- * intdoc.in: Likewise.
- * invoke.texi: Likewise.
- * news.texi: Likewise.
- * intdoc.texi: Regenerate.
-
-2002-09-16 Geoffrey Keating <geoffk@apple.com>
-
- * com.c (union lang_tree_node): Add chain_next option.
-
-2002-09-16 Richard Henderson <rth@redhat.com>
-
- * target.c (ffetarget_real1): Don't pass FFETARGET_ATOF_
- directly to ffetarget_make_real1.
- (ffetarget_real2): Similarly.
- * target.h (ffetarget_cvt_r1_to_rv_, ffetarget_cvt_rv_to_r2_,
- ffetarget_cvt_r2_to_rv_): Use new real.h interface and simplify.
-
-2002-09-15 Kazu Hirata <kazu@cs.umass.edu>
-
- * intdoc.texi: Regenerate.
-
-2002-09-15 Kazu Hirata <kazu@cs.umass.edu>
-
- * ChangeLog: Follow spelling conventions.
- * intdoc.in: Likewise.
-
-2002-09-09 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- Fix PR web/7596:
- * ffe.texi (Front End): Fix broken links.
- * bugs.texi (Known Bugs): Refer to gcc.gnu.org instead of
- www.gnu.org for onlinedocs.
- * news.texi (News): Ditto.
-
-2002-09-07 Jan Hubicka <jh@suse.cz>
-
- * com.c (ffe_type_for_mode): Handle long double.
-
-2002-09-04 Richard Henderson <rth@redhat.com>
-
- * target.h (ffetarget_print_real1, ffetarget_print_real2): Update
- call to REAL_VALUE_TO_DECIMAL.
-
-2002-08-31 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c: Don't set flag_finite_math_only by default.
- * invoke.texi: Reverse the documentation of option
- -ffinite-math-only to reflect the new default.
-
-2002-08-30 Hans-Peter Nilsson <hp@bitrange.com>
-
- * target.c (ffetarget_memcpy_): Don't test nonexistent
- HOST_BYTES_BIG_ENDIAN, HOST_BITS_BIG_ENDIAN. Check
- HOST_WORDS_BIG_ENDIAN against both WORDS_BIG_ENDIAN and
- BYTES_BIG_ENDIAN.
-
-2002-08-30 Alan Modra <amodra@bigpond.net.au>
-
- * target.h (FFETARGET_32bit_longs): Don't define for powerpc64 or
- mmix.
-
-2002-08-28 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * bugs.texi, news.texi: Update URLs for online news and bugs
- lists.
-
-2002-08-22 Hans-Peter Nilsson <hp@bitrange.com>
-
- * where.h (struct _ffewhere_file_): Mark GTY.
- (ffewhere_file_kill): Remove prototype.
- * where.c: Include ggc.h.
- (struct _ffewhere_ll_, struct _ffewhere_root_ll_): Mark GTY.
- (ffewhere_root_ll_): Ditto. Change type from struct
- _ffewhere_root_ll_ to struct _ffewhere_root_ll_*. All uses
- changed.
- (ffewhere_file_kill): Remove.
- (ffewhere_file_new): Use GC to allocate ffewhereFile objects.
- (ffewhere_file_set): Use GC to allocate ffewhereLL_ objects.
- (ffewhere_init_1): Use GC to allocate ffewhere_root_ll_ sentinel.
- Include gt-f-where.h.
- * lex.c (ffelex_current_wf_, ffelex_include_wherefile_): Mark GTY.
- Include gt-f-lex.h.
- * std.c (ffestd_S3P4): Don't call ffewhere_file_kill.
- * config-lang.in (gtfiles): Add f/where.h f/where.c and f/lex.c.
- * Make-lang.in (gt-f-lex.h gt-f-where.h): Add to dependents of
- s-gtype.
- (f/lex.o): Depend on gt-f-lex.h.
- (f/where.o): Depend on gt-f-where.h.
-
-Tue Aug 20 16:49:40 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * where.c (ffewhere_track): Remove impossible if-then clause.
-
-Thu Aug 8 10:06:14 2002 Nathan Sidwell <nathan@codesourcery.com>
-
- * f/Make-lang.in (f.mostlyclean): Remove coverage files.
-
-2002-08-06 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * g77.texi (Top): Rename Index to Keyword Index.
-
-2002-08-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * invoke.texi: Improve description of
- -fno-finite-math-only flag.
-
-Sun Aug 4 16:45:49 2002 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * root.texi (version-gcc): Increase to 3.3.
-
-2002-07-30 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffe_init_options): Set
- flag_finite_math_only.
- * invoke.texi: Document -fno-finite-math-only.
-
-Mon Jul 29 22:05:35 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (read_name_map): Use concat in lieu of xmalloc/strcpy.
-
-2002-07-25 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document better handling of (no-)alias
- information of dummy arguments and induction variables
- on loop unrolling.
-
-2002-07-01 Roger Sayle <roger@eyesopen.com>
-
- * f/com.c (builtin_function): Accept additional parameter.
- (ffe_com_init_0): Pass an additional NULL_TREE argument to
- builtin_function.
-
-2002-06-28 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Mention 2 Gbyte limit on 32-bit targets
- for arrays explicitly in news on g77-3.1.
-
-Thu Jun 20 21:56:34 2002 Neil Booth <neil@daikokuya.co.uk>
-
- * lang-specs.h: Use cc1 for traditional preprocessing.
-
-2002-06-20 Andreas Jaeger <aj@suse.de>
-
- * com.c (ffecom_prepare_expr_,ffecom_expr_power_integer_):
- Remove #ifdefed HAHA sections.
-
-2002-06-20 Nathanael Nerode <neroden@twcny.rr.com>
-
- * com.c: Remove #ifdef HOHO sections.
-
-2002-06-17 Jason Thorpe <thorpej@wasabisystems.com>
-
- * bit.c: Don't include glimits.h.
- * target.c: Likewise.
- * where.h: Likewise.
-
-2002-06-12 Gabriel Dos Reis <gdr@codesourcery.com>
-
- * bad.c (ffebad_start_): Adjust calls to diagnostic_count_error.
-
-2002-06-04 Gabriel Dos Reis <gdr@codesourcery.com>
-
- * bad.c (ffebad_start_): Adjust call to count_error.
- * Make-lang.in (f/bad.o): Depend on diagnostic.h
- * bad.c: #include diagnostic.h
-
-2002-06-03 Geoffrey Keating <geoffk@redhat.com>
-
- * Make-lang.in (f/com.o): Depend on debug.h.
- * com.c: Include debug.h.
- (LANG_HOOKS_MARK_TREE): Delete.
- (struct lang_identifier): Use gengtype.
- (union lang_tree_node): New.
- (struct lang_decl): New dummy definition.
- (struct lang_type): New dummy definition.
- (ffe_mark_tree): Delete.
-
- * com.c (struct language_function): New dummy structure.
-
- * Make-lang.in: Add rules to generate gt-f-ste.h gtype-f.h; allow
- for filename changes.
- (com.o): Allow for filename changes; add gtype-f.h as dependency.
- (ste.o): Add gt-f-ste.h as dependency.
- * config-lang.in (gtfiles): Add com.h, ste.c.
- * com.c: Replace uses of ggc_add_* with GTY markers. Include
- gtype-f.h.
- (mark_binding_level): Delete.
- * com.h: Replace uses of ggc_add_* with GTY markers.
- * ste.c: Replace uses of ggc_add_* with GTY markers. Include
- gt-f-ste.h.
-
- * Make-lang.in (f/gt-com.h): Build using gengtype.
- (com.o): Depend on f/gt-com.h.
- * com.c: Rename struct binding_level to f_binding_level.
- (struct f_binding_level): Use gengtype.
- (struct tree_ggc_tracker): Use gengtype.
- (mark_tracker_head): Use gt_ggc_m_tree_ggc_tracker.
- (make_binding_level): Use GGC.
- (mark_binding_level): Use gt_ggc_m_f_binding_level.
- (ffecom_init_decl_processing): Change free_binding_level
- to a deletable root.
- * config-lang.in (gtfiles): Define.
- * where.c: Strings need no longer be allocated in GCable memory;
- remove my change of 30 Dec 1999.
-
-2002-05-31 Matthew Woodcraft <mattheww@chiark.greenend.org.uk>
-
- * lang-specs.h: Use cpp_debug_options.
-
-2002-05-28 Zack Weinberg <zack@codesourcery.com>
-
- * bld.c, com.c, expr.c, target.c: Include real.h.
- * Make-lang.in: Update dependency lists.
-
-2002-05-16 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * Make-lang.in: Allow for PWDCMD to override hardcoded pwd.
-
-2002-05-09 Hassan Aurag <aurag@cae.com>
-
- * expr.c (ffeexpr_reduced_ugly2log_): Allow logicals-as-integers
- under -fugly-logint as arguments of .and., .or., .xor.
-
-2002-05-07 Jan Hubicka <jh@suse.cz>
-
- * target.h (FFETARGET_32bit_longs): Undefine for x86-64.
-
-2002-04-29 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * invoke.texi: Use @gol at ends of lines inside @gccoptlist.
- * g77.texi: Update last update date.
-
-Thu Apr 25 07:44:44 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.h (ffe_parse_file): Update.
- * lex.c (ffe_parse_file): Update.
-
-2002-04-20 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi: Remove variable version-g77.
- * g77.texi: Remove the single use of that variable.
-
-Thu Apr 18 19:10:44 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (incomplete_type_error): Remove.
-
-Tue Apr 16 14:55:47 2002 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_expr_power_integer): Add has_scope argument to
- call to expand_start_stmt_expr.
-
-Mon Apr 15 10:59:14 2002 Mark Mitchell <mark@codesourcery.com>
-
- * g77.texi: Remove Chill reference.
-
-2002-04-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Deprecate frontend version number;
- update list of fixed bugs.
-
-2002-04-08 Hans-Peter Nilsson <hp@bitrange.com>
-
- * Make-lang.in (f/target.o): Depend on diagnostic.h.
- * target.c: Include diagnostic.h.
- (ffetarget_memcpy_): Call sorry if host and target endians are
- not matching.
-
-Thu Apr 4 23:29:48 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_TRUTHVALUE_CONVERSION): Redefine.
- (truthvalue_conversion): Rename. Update. Make static.
- (ffecom_truth_value): Update.
-
-Mon Apr 1 21:39:36 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_MARK_ADDRESSABLE): Redefine.
- (mark_addressable): Rename.
- (ffecom_arrayref_, ffecom_1): Update.
-
-Mon Apr 1 09:59:53 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_SIGNED_TYPE, LANG_HOOKS_UNSIGNED_TYPE,
- LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE): New.
- (unsigned_type, signed_type, signed_or_unsigned_type): Rename.
-
-Sun Mar 31 23:50:22 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (lang_print_error_function): Rename.
- (LANG_HOOKS_PRINT_ERROR_FUNCTION): Redefine.
- (ffe_init): Don't set hook.
-
-Fri Mar 29 21:59:15 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_TYPE_FOR_MODE, LANG_HOOKS_TYPE_FOR_SIZE):
- Redefine.
- (type_for_mode, type_for_size): Rename.
- (signed_or_unsigned_type, signed_type, truthvalue_conversion,
- unsigned_type): Use new hooks.
-
-Tue Mar 26 10:30:05 2002 Andrew Cagney <ac131313@redhat.com>
-
- * invoke.texi (Warning Options): Mention -Wswitch-enum.
- Fix PR c/5044.
-
-Tue Mar 26 07:30:51 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_MARK_TREE): Redefine.
- (lang_mark_tree): Rename ffe_mark_tree, make static.
-
-Mon Mar 25 19:27:11 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (maybe_build_cleanup): Remove.
-
-2002-03-23 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_check_size_overflow_): Add a test
- so that arrays too large for 32-bit byte-offset
- addressing get caught.
- * news.texi: Document the fixing of this problem.
-
-Sat Mar 23 11:18:17 2002 Andrew Cagney <ac131313@redhat.com>
-
- * invoke.texi (Warning Options): Mention -Wswitch-default.
-
-Thu Mar 21 18:55:41 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * cp-tree.h (pushdecl, pushlevel, poplevel, set_block,
- insert_block, getdecls, global_bindings_p): New.
-
-Wed Mar 20 08:03:42 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (lang_printable_name): Rename.
- (LANG_HOOKS_DECL_PRINTABLE_NAME): Redefine.
- (ffe_init): Don't use old hook.
-
-Sun Mar 17 18:50:15 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.h (ffe_parse_file): Prototype.
-
-Sun Mar 17 20:57:30 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_PARSE_FILE): Redefine.
- * com.h (ffe_parse_file): New.
- * parse.c (NAME_OF_STDIN): Remove.
- (yyparse): Rename ffe_parse_file.
-
-Tue Mar 12 20:23:18 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (tree_code_type, tree_code_length, tree_code_name):
- Define.
-
-Sun Mar 10 12:37:42 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * target.c (ffetarget_print_hex): Const-ify.
-
-2002-03-06 Phil Edwards <pme@gcc.gnu.org>
-
- * version.c: Fix misplaced leading blanks on first line.
-
-2002-03-03 Zack Weinberg <zack@codesourcery.com>
-
- * com.c, target.h: Remove all #ifndef REAL_ARITHMETIC
- blocks, make all #ifdef REAL_ARITHMETIC blocks unconditional.
- Delete some further #ifdef blocks predicated on REAL_ARITHMETIC.
-
-Thu Feb 28 07:53:46 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (copy_lang_decl): Delete.
-
-2002-02-27 Zack Weinberg <zack@codesourcery.com>
-
- * com.c, lex.c, top.c: Delete traditional-mode-related code
- copied from the C front end but not used, or used only to
- permit the compiler to link.
-
-2002-02-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: List Problem Reports fixed in 3.1.
-
-2002-02-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * data.c (ffedata_eval_offset_): Only convert index,
- low and high bound in data statements to default integer
- if they are constants. Use a copy of the data structure.
-
-2002-02-09 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * data.c (ffedata_eval_offset_): Convert non-default integer
- constants to default integer kind if necessary.
-
-2002-02-09 Toon Moene <toon@moene.indiv.nlug.nl>
-
- * invoke.texi: Add a short debugging session
- as an example to the documentation of -g.
-
-2002-02-06 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/4730 fortran/5473
- * com.c (ffecom_expr_): Deal with %VAL constructs.
- * intrin.c (ffeintrin_check_): Handle 'N' constraints for intrinsics,
- to indicate "no larger than default kind" integers and logicals.
- * intrin.def: Use 'N' constraints in table of intrinsics.
- * intdoc.c: Document this constraint.
- * intdoc.texi: Regenerated.
-
-2002-02-04 Philipp Thomas <pthomas@suse.de>
-
- * implic.c lex.c stb.c ste.c stu.c: Update copyright dates.
-
-2002-02-04 Philipp Thomas <pthomas@suse.de>
-
- * bad.def com.c expr.c implic.c lex.c stb.c ste.c stu.c:
- Insert comments to mark messages as not being printf style
- where appropriate.
-
-2002-02-03 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * expr.c (ffeexpr_sym_impdoitem_): Allow other than
- default INTEGER implied-do loop counts.
-
-2002-02-01 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bad.def: Remove non-historical reference to version 0.6.
- * bugs.texi: Ditto.
- * com.c: Ditto.
- * ffe.texi: Ditto.
- * proj.h: Ditto.
- * g77.texi: Ditto.
-
-2002-01-31 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lang_specific_driver): Follow GNU Coding Standards
- for --version.
-
-2002-01-30 Richard Henderson <rth@redhat.com>
-
- * ste.c (ffeste_begin_iterdo_): Use expand_exit_loop_top_cond.
- (ffeste_R819B): Likewise.
-
-2002-01-30 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * intrin.c (upcasecmp_): New function.
- (ffeintrin_cmp_name_): Use it to correctly compare name
- and table entry for bsearch.
-
-2002-01-26 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * intrin.c (ffeintrin_cmp_name_): Correct comparison
- for intrinsics in intrinsic table (intrin.def).
-
-2002-01-22 Zack Weinberg <zack@codesourcery.com>
-
- * bad.c: Include intl.h.
- (FFEBAD_MSGS1, FFEBAD_MSGS2): Replace by FFEBAD_MSG, SHORT,
- LONG. Adjust definitions to work with exgettext.
- (ffebad_start_): Translate all error messages.
- (ffebad_finish): Mark constant strings for translation.
- * bad.h: Use FFEBAD_MSG. Adjust prototype of ffebad_start_
- and definitions of ffebad_start_msg, ffebad_start_msg_lex to
- work with exgettext.
- * bad.def: Use FFEBAD_MSG, SHORT, LONG throughout.
-
- * com.c: Include intl.h.
- (lang_print_error_function): Always use ffeinfo_kind_message
- to get the kind label for a non-nested construct. Translate
- it. Translate constant strings.
- * info.c (FFEINFO_KIND): Adjust definition to work with exgettext.
- * info-k.def: Block xgettext from slurping copyright notice
- into gcc.pot. Adjust strings for their sole use, in com.c.
-
- * Make-lang.in (f/bad.o, f/com.o): Depend on intl.h.
-
-2002-01-14 David Billinghurst <David.Billinghurst@riotinto.com>
-
- PR fortran/3807
- * f/intrin.c (ffeintrin_check_): Allow for case of intrinsic
- control string have COL-spec an integer > 0.
-
-2002-01-08 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lookup_option): Handle -fversion.
- (lang_specific_driver): Update copyright date in --version output.
-
-Mon Jan 7 00:03:42 2002 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * invoke.texi: Markup g77 as @command. Remove reference to
- http://gcc.gnu.org/thanks.html.
-
-Wed Jan 2 18:13:11 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (clear_binding_level): Const-ify.
- (ffecom_arglist_expr_): Likewise.
- * info.c (ffeinfo_types_): Don't needlessly zero init.
- * lex.c (ffelex_hash_kludge): Const-ify.
-
-Sun Dec 23 10:45:09 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_gfrt_volatile_, ffecom_gfrt_complex_,
- ffecom_gfrt_const_, ffecom_gfrt_type_): Const-ify.
-
-Sat Dec 22 16:01:51 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bld.c (ffebld_arity_op_): Declare array size explicitly.
- * bld.h (ffebld_arity_op_): Likewise.
-
-2001-12-20 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * config-lang.in (diff_excludes): Remove.
-
-2001-12-17 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi, invoke.texi: Update links to GCC manual.
-
-Sun Dec 16 16:08:57 2001 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * news.texi: Fix spelling errors.
-
-Sun Dec 16 10:36:51 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (f/version.o): Depend on f/version.h.
- * version.c: Include ansidecl.h and f/version.h.
-
-Sun Dec 16 08:52:48 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * lex.c (ffelex_backslash_, ffelex_cfebackslash_): Use hex_value.
- * target.c (ffetarget_integerhex, ffetarget_typeless_hex): Use
- hex_p/hex_value.
-
-2001-12-14 Roger Sayle <roger@eyesopen.com>
-
- * com-rt.def: Use __builtin_sqrt instead of __builtin_fsqrt.
- * com.c (ffecom_init_0): Same, and fixed enumeration usage.
-
-2001-12-10 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Don't condition menus on @ifinfo.
-
-Wed Dec 5 06:49:21 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_1): Properly handle TREE_READONLY for INDIRECT_REF.
-
-Mon Dec 3 18:56:04 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c: Remove leading capital from diagnostic messages, as
- per GNU coding standards.
- * g77spec.c: Similarly.
- * lex.c: Similarly.
-
-2001-12-01 Zack Weinberg <zack@codesourcery.com>
-
- * f/fini.c: Use xmalloc.
-
-Fri Nov 30 20:54:02 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in: Delete references to proj.[co], proj-h.[co].
- * proj.c: Delete file.
-
-2001-11-29 Zack Weinberg <zack@codesourcery.com>
-
- * Make-lang.in (f/fini, f/intdoc): Depend on $(HOST_LIBDEPS)
- and link with $(HOST_LIBS), not safe-ctype.o.
-
-2001-11-29 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (f77.generated-manpages): New target.
- ($(srcdir)/f/g77.1): Don't check $(GENERATED_MANPAGES). Allow
- manpage generation to fail.
- (f77.info): Don't depend on $(srcdir)/f/g77.1.
- (f77.install-man): Depend on $(GENERATED_MANPAGES) rather than
- directly on $(srcdir)/g77.1.
-
-2001-11-24 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/3957
- * lang-specs.h: Correct !pipe conditional in tradcpp0 invocation.
-
-2001-11-21 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: egcs was not a `@command'.
- * invoke.texi: Ditto.
- * news.texi: Substitute `@command' for `@code'
- and `@option' for `@samp' where appropriate.
-
-2001-11-19 Loren J. Rittle <ljrittle@acm.org>
-
- * Make-lang.in: Complete ``Build g77.1 in $(srcdir)''.
-
-2001-11-19 Geoffrey Keating <geoffk@redhat.com>
-
- * g77spec.c (lang_specific_driver) [ENABLE_SHARED_LIBGCC]: Add
- libgcc_s.so if libf2c is used.
- * Make-lang.in (g77spec.o): Use DRIVER_DEFINES.
-
-2001-11-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * .cvsignore: Ignore g77.1
- * g77.texi: Substitute `@command' for `@code'
- where appropriate.
- * invoke.texi: Ditto.
-
-2001-11-18 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Remove all references to LANGUAGES
- and the stamp files that depend on its value.
-
-Sun Nov 18 11:13:04 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (finish_parse): Remove.
- (ffe_finish): Move body of finish_parse.
-
-Thu Nov 15 10:06:38 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (ffecom_init_decl_processing): Renamed from
- init_decl_processing.
- (init_parse): Move contents to ffe_init.
- (ffe_init): Update prototype.
-
-2001-11-14 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Update to use `@command', `@option.
- * invoke.texi: Ditto
-
-2001-11-14 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in: Change all uses of $(manext) to $(man1ext).
-
-2001-11-14 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.1: Remove from CVS.
- * Make-lang.in: Build g77.1 in $(srcdir).
- Add --section=1 to POD2MAN command line.
- * invoke.texi: Correct copyright years.
- Add more sections to man page. Add GFDL.
-
-Fri Nov 9 23:16:45 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (ffe_print_identifier): Rename.
- (LANG_HOOKS_PRINT_IDENTIFIER): Override.
- (lang_print_xnode, print_lang_decl, print_lang_statistics,
- print_lang_type, set_yydebug): Remove.
-
-2001-11-09 Zack Weinberg <zack@codesourcery.com>
-
- * g77spec.c (lang_specific_driver): Adjust behavior of -v and
- --version for consistency with other front ends. Remove large
- #if 0 block. Do not add libraries to argv if there are no
- input files.
- (add_version_magic): Delete all references and dependent code.
- * lang-options.h: Delete -fnull-version.
- * lang-specs.h: Delete f77-version spec.
-
- * lex.c: Delete logic conditional on ffe_is_null_version() and
- now-unused label.
- * top.c: Delete ffe_is_null_version_ variable.
- (ffe_decode_option): Delete -fnull-version case.
- * top.h: Delete declaration of ffe_is_null_version_ and
- ffe_is_null_version(), ffe_set_is_null_version() macros.
-
-Fri Nov 9 07:14:47 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (language_string, lang_identify): Remove.
- (struct lang_hooks): Constify.
- (LANG_HOOKS_NAME): Override.
- (init_parse): Update.
-
-2001-11-08 Andreas Franck <afranck@gmx.de>
-
- * Make-lang.in (G77_INSTALL_NAME, G77_CROSS_NAME): Handle
- program_transform_name the way suggested by autoconf.
-
-2001-11-08 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Add rules for building g77.1.
- * invoke.texi: Add man page stuff. Move indexing
- from g77.texi to here.
- * g77.texi: Remove indexing specific to invoke.texi.
- * news.texi: Document that g77.1 is now a generated
- file.
-
-Tue Nov 6 21:17:47 2001 Neil Booth <neil@cat.daikokuya.demon.co.uk>
-
- * com.c: Include langhooks-def.h.
- * Make-lang.in: Update.
-
-2001-11-04 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Split off invoke.texi (preliminary to using it
- to generate a man page).
- * Make-lang.in: Reflect in build rules.
-
-Fri Nov 2 10:51:34 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_initialize_char_syntax_, U_CHAR, is_idchar,
- is_idstart, is_hor_space, is_space, SKIP_WHITE_SPACE,
- SKIP_ALL_WHITE_SPACE): Delete.
- (read_filename_string, read_name_map): Don't use is_space or
- is_hor_space.
-
-2001-10-29 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document new ability to compile programs with
- arrays larger than 512 Mbyte on 32-bit targets.
-
-2001-10-24 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_check_size_overflow_): Only check for TREE_OVERFLOW.
-
-Tue Oct 23 14:01:27 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (LANG_HOOKS_GET_ALIAS_SET): New macro.
- (lang_get_alias_set): Delete.
-
-2001-10-23 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi (Sending Patches): Remove.
-
-2001-10-22 Zack Weinberg <zack@codesourcery.com>
-
- * Make-lang.in (f/intdoc): Depend on safe-ctype.o.
-
-Sun Oct 21 17:28:17 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Use safe-ctype macros and/or fold extra
- calls into fewer ones.
- * implic.c (ffeimplic_lookup_): Likewise.
- * intdoc.c (dumpimp): Likewise.
- * intrin.c (ffeintrin_init_0): Likewise.
- * lex.c (ffelex_backslash_, ffelex_cfebackslash_, ffelex_hash_):
- Likewise.
- * lex.h (ffelex_is_firstnamechar): Likewise.
- * target.c (ffetarget_integerhex): Likewise.
-
-2001-10-21 Craig Prescott <prescott@phys.ufl.edu>
-
- * target.h (FFETARGET_32bit_longs): Don't define
- for 64-bit hppa.
-
-2001-10-17 Richard Henderson <rth@redhat.com>
-
- * std.c (ffestd_labeldef_format): Fix variable/stmt ordering.
- (ffestd_R737A): Likewise.
-
-2001-10-17 Richard Henderson <rth@redhat.com>
-
- * com.h: Remove FFECOM_targetCURRENT, FFECOM_ONEPASS, BUILT_FOR_270,
- BUILT_FOR_280, FFECOM_GCC_INCLUDE, all derivitive defines, and all
- related conditional compilation directives.
- * bad.c, bld.c, bld.h, com.c, equiv.c, equiv.h, global.h, intdoc.c,
- intrin.c, intrin.h, lex.c, parse.c, sta.c, std.c, ste.c, ste.h, stt.c,
- stt.h, stw.h, symbol.c, symbol.h, target.h, top.c: Likewise.
-
-2001-10-17 Richard Henderson <rth@redhat.com>
-
- * Make-lang.in (f/com.o): Depend on langhooks.h.
- * com.c: Include it.
- (LANG_HOOKS_INIT, LANG_HOOKS_FINISH): New.
- (LANG_HOOKS_INIT_OPTIONS, LANG_HOOKS_DECODE_OPTION): New.
- (lang_hooks): Use LANG_HOOKS_INITIALIZER.
-
-Sun Oct 7 12:27:54 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (_ffebad_message_, ffebad_messages_): Const-ify.
- * bld.c (ffebld_arity_op_): Likewise.
- * bld.h (ffebld_arity_op_): Likewise.
- * com.c (ffecom_init_0): Likewise.
- * intdoc.c (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, names, gens, imps, specs, cc_pair,
- cc_descriptions, cc_summaries): Likewise.
- * intrin.c (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, ffeintrin_names_, ffeintrin_gens_,
- ffeintrin_imps_, ffeintrin_specs_): Likewise.
-
-2001-10-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document libf2c being built as a shared library.
- Use of array elements in bounds of adjustable arrays ditto.
-
-2001-10-03 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Remove reference to FORTRAN_INIT.
- * g77spec.c: Add reference to FORTRAN_INIT.
-
-2001-09-29 Juergen Pfeifer <juergen.pfeifer@gmx.net>
-
- Make libf2c a shared library.
-
- * Make-lang.in: Pass define of frtbegin.o to compilation of g77spec.c.
- * g77spec.c (lang_specific_driver): Treat linking in of frtbegin.o.
-
-2001-09-28 Robert Anderson <rwa@alumni.princeton.edu>
-
- * expr.c (ffeexpr_sym_rhs_dimlist_): Allow array elements
- as bounds of adjustable arrays.
-
-Thu Sep 20 15:05:20 JST 2001 George Helffrich <george@geo.titech.ac.jp>
-
- * com.c (ffecom_subscript_check_): Loosen subscript checking rules
- for character strings, to permit substring expressions like
- string(1:0).
- * news.texi: Document this as a new feature.
-
-Thu Sep 13 10:33:27 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Const-ification and/or static-ization.
- * intrin.c (ffeintrin_cmp_name_): Likewise.
- * stc.c (ffestc_R904): Likewise.
-
-Wed Sep 12 12:09:04 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bld.c (ffebld_op_string_): Const-ification.
- * com.c (ffecom_gfrt_name_, ffecom_gfrt_argstring_): Likewise.
- * fini.c (xspaces): Likewise.
- * global.c (ffeglobal_type_string_): Likewise.
- * info.c (ffeinfo_basictype_string_, ffeinfo_kind_message_,
- ffeinfo_kind_string_, ffeinfo_kindtype_string_,
- ffeinfo_where_string_): Likewise.
- * lex.c (ffelex_type_string_): Likewise.
- * malloc.c (malloc_types_): Likewise.
- * stc.c (ffestc_subr_binsrch_, ffestc_R904, ffestc_R904,
- ffestc_R907): Likewise.
- * symbol.c (ffesymbol_state_name_, ffesymbol_attr_name_):
- Likewise.
- * version.c (ffe_version_string): Likewise.
- * version.h (ffe_version_string): Likewise.
-
-2001-09-11 Richard Henderson <rth@redhat.com>
-
- * parse.c (finput): Mark extern.
-
-2001-09-11 Jakub Jelinek <jakub@redhat.com>
-
- * com.c (ffe_init_options): Default to -fmerge-all-constants
- if optimizing.
-
-2000-08-14 Ulrich Weigand <uweigand@de.ibm.com>
-
- * target.h (FFETARGET_32bit_longs): Don't define
- for 64-bit S/390.
-
-2001-07-20 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_expr_intrinsic_):
- case FFEINTRIN_impIBITS: Remove TREE_SHIFT_FULLWIDTH define.
- case FFEINTRIN_impISHFT: Ditto. Change LT_EXPR to NE_EXPR.
- case FFEINTRIN_impISHFTC: Ditto.
- case FFEINTRIN_impMVBITS: Ditto.
-
-2001-07-19 Jakub Jelinek <jakub@redhat.com>
-
- * top.c (ffe_decode_option): Disallow lang-independent processing
- for -ffixed-form.
-
-2001-07-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * f/com.c (ffecom_expr_intrinsic_): Deal (correctly) with
- {L|R}SHIFT_EXPR not working when shift > size of type.
-
-2001-07-17 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (lang_print_error_function): Argument context
- is unused.
-
-2001-07-14 Tim Josling <tej@melbpc.org.au>
-
- * com.c (ffecom_overlap_): Remove references to EXPON_EXPR.
- (ffecom_tree_canonize_ref_): Likewise.
-
-2001-07-10 James Smaby <jsmaby@virgo.umeche.maine.edu>
-
- * intdoc.in: Fix the definition of COMPLEX ABS.
- Remove `the' where inappropriate.
- * intdoc.texi: Rebuilt.
-
-2001-07-04 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Use gpl.texi and funding.texi. Remove Look and Feel
- section. Add Funding Free Software to invariant sections.
- * Make-lang.in ($(srcdir)/f/g77.info, f/g77.dvi): Update
- dependencies and use doc/include in search path.
-
-2001-06-28 Gabriel Dos Reis <gdr@codesourcery.com>
-
- * Make-lang.in (f/com.o): Depend on diagnostic.h
- * com.c: #include diagnostic.h
- (lang_print_error_function): Take a 'diagnostic_context *'.
-
-Wed Jun 13 11:22:39 2001 Mark Mitchell <mark@codesourcery.com>
-
- * BUGS: Remove.
- * NEWS: Likewise.
-
-2001-06-10 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77install.texi: Remove.
- * Make-lang.in: Remove all mention of g77install.texi.
- * g77.texi: Add documentation on how to get output always
- flushed and how to increase the maximum unit number.
- Remove all mention of g77install.texi.
- * bugs.texi: Add documentation on how to change the threshold
- for putting local arrays on the stack.
-
-2001-06-03 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi: Fix typo in patches e-mail address.
-
-2001-06-03 Toon Moene <toon@moene.indiv.nluug.nl>
- Jan van Male <jan.vanmale@fenk.wau.nl>
-
- * root.texi: Define `help' and `patches' mailing list
- addresses.
- * news.texi: Remove `prerelease' from 0.5.26
- * g77.texi: Use two spaces between command options, eliminate
- some 'overfull hboxes'. Use help and patches mailing list
- addresses where appropriate.
-
-2001-06-02 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Move contents to just after title page.
-
-2001-06-02 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_init_0): Make CHARACTER*1 unsigned.
-
-2001-05-23 Theodore Papadopoulo <Theodore.Papadopoulo@sophia.inria.fr>
-
- * Make-lang.in ($(srcdir)/f/g77.info): Added dependencies on
- fdl.texi.
- (f/g77.dvi): Use TEXI2DVI instead of custom tex calls. Create the
- dvi file in the f directory.
-
-2001-05-25 Sam TH <sam@uchicago.edu>
-
- * bad.h: Fix header include guards.
- * bit.h bld.h com.h data.h equiv.h expr.h global.h
- implic.h info.h intrin.h lab.h lex.h malloc.h name.h
- proj.h src.h st.h sta.h stb.h stc.h std.h ste.h
- storag.h stp.h str.h sts.h stt.h stu.h stv.h stw.h
- symbol.h target.h top.h type.h version.h
- where.h: Likewise.
-
-2001-05-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Update last-changed date.
- * news.texi: Update copyright years, last-changed date.
- * bugs.texi: Update copyright years, last-changed date.
-
-2001-05-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Update maintenance information for
- GNU Fortran. Remove all mention of -fdebug-kludge.
- * news.texi: Make more news in 0.5.26 `user visible
- changes'. Acknowledge work by important contributors.
- * bugs.texi: Remove all mention of -fdebug-kludge.
-
-2001-05-20 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (f/g77.dvi): Include $(srcdir) in TEXINPUTS.
-
-2001-05-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Have $(MAKEINFO) look into the parent
- directory for includes.
- * g77.texi: Use the GFDL.
-
-Sun May 13 12:25:06 2001 Mark Mitchell <mark@codesourcery.com>
-
- * Make-lang.in: Replace all uses of `touch' with $(STAMP).
-
-Wed May 2 10:20:08 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c: NULL_PTR -> NULL.
-
-Sun Apr 22 20:18:01 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_subscript_check_): Use concat in lieu of
- xmalloc/sprintf.
-
-2001-04-21 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Update release information for 0.5.27.
-
-Thu Apr 19 12:49:24 2001 Mark Mitchell <mark@codesourcery.com>
-
- * top.c (ffe_decode_option): Do not permit language-independent
- processing for -ffixed-line-length.
-
-Thu Apr 12 17:57:55 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (inhibit_warnings): Delete redundant declaration.
-
- * com.c (skip_redundant_dir_prefix): Likewise.
-
- * com.h (mark_addressable): Likewise.
-
-2001-04-02 Jakub Jelinek <jakub@redhat.com>
-
- * lex.c (ffelex_hash_): Avoid eating one whole line after
- #line.
-
-Mon Apr 2 22:38:09 2001 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (duplicate_decls): Fix thinko in lazy DECL_RTL patch
- of 2001-03-04.
-
-Tue Mar 27 17:40:08 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in: Depend on $(SYSTEM_H), not system.h.
-
-Mon Mar 26 18:13:30 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (duplicate_decls): Don't copy DECL_FRAME_SIZE.
-
-Mon Mar 19 15:05:39 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (builtin_function): Use SET_DECL_ASSEMBLER_NAME.
-
-Wed Mar 14 09:29:27 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_member_phase_2): Use COPY_DECL_RTL,
- DECL_RTL_SET_P, etc.
- (duplicate_decls): Likewise.
- (start_decl): Likewise.
-
-Fri Mar 9 22:52:55 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * fini.c (main): Use really_call_malloc, not malloc.
-
-Thu Mar 8 13:27:47 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c: Don't rely on the POSIX macro to define autoconf stuff.
-
-2001-03-07 Brad Lucier <lucier@math.purdue.edu>
-
- * g77.texi: Document new options -funsafe-math-optimizations
- and -fno-trapping-math. Revise documentation for -ffast-math.
-
-2001-03-01 Zack Weinberg <zackw@stanford.edu>
-
- * proj.h: Delete 'bool' type. Don't include stddef.h here.
- * com.c: Rename variables named 'true' and/or 'false'.
- * intdoc.c: Delete 'bool' type.
-
-2001-03-01 Zack Weinberg <zackw@stanford.edu>
-
- * lang-specs.h: Add zero initializer for cpp_spec field to all
- array elements.
-
-2001-02-24 Zack Weinberg <zackw@stanford.edu>
-
- * com.c: Don't define STDC_HEADERS, autoconf handles it.
-
-Fri Feb 23 15:28:39 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (set_block): Set NAMES and BLOCKS from BLOCK.
-
-2001-02-19 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * version.c, root.texi: Update GCC version number to 3.1. Update
- G77 version number to 0.5.27.
- * BUGS, NEWS: Regenerate.
-
-Sun Feb 4 15:52:44 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_init_0): Call fatal_error instead of fatal.
- * com.c (init_parse): Call fatal_io_error instead of
- pfatal_with_name.
- (ffecom_decode_include_option_): Make errors non-fatal.
- * lex.c (ffelex_cfelex_, ffelex_get_directive_line_): Likewise.
- (ffelex_hash_): Likewise.
-
-Sat Jan 27 20:52:18 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in: Remove all dependencies on defaults.h.
- * com.c: Don't include defaults.h.
-
-2001-01-23 Michael Sokolov <msokolov@ivan.Harhan.ORG>
-
- * com.c: Don't explicitly include any time headers, the right ones are
- already included by proj.h.
-
-2001-01-15 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_lookup_label): Set DECL_CONTEXT for FORMAT
- label to current_function_decl.
-
-Fri Jan 12 17:21:33 2001 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lang_specific_driver): Update copyright year to 2001.
-
-Wed Jan 10 14:39:45 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_init_zero_): Remove last argument in call to
- make_decl_rtl; use make_function_rtl instead of make_decl_rtl.
- (ffecom_lookup_label_): Likewise.
- (builtin_function): Likewise.
- (start_function): Likewise.
-
-Thu Dec 21 21:19:42 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77install.texi, g77.texi: Update last-updated dates for
- installation information and the manual as a whole.
- * bugs.texi, news.texi: Update copyright years in the comments at
- the top of the file.
-
-2000-12-21 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77install.texi: Adjust wording of an EGCS reference.
-
-Thu Dec 21 20:00:48 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * BUGS, NEWS: Regenerate.
-
-2000-12-18 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * com.c [VMS]: Remove definition of BSTRING.
-
-2000-12-18 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Update GPL copy not to refer to years 19@var{yy}.
-
-2000-12-18 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bugs.texi: Correct copyright years.
- * g77.texi: Likewise.
- * news.texi: Likewise.
-
-2000-12-18 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77install.texi: Remove obsolete parts only used for INSTALL,
- and DOC-G77 conditionals. Update last-update-install date.
-
-Sat Dec 9 10:20:11 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * .cvsignore: New file; add info files.
-
-2000-12-08 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (f77.info): Depend on info files in source
- directory.
- (f/g77.info): Build info files in source directory; don't build
- them unless BUILD_INFO is "info".
- (f77.install-info): Install info files from source directory.
-
-2000-12-07 Zack Weinberg <zack@wolery.stanford.edu>
-
- * Make-lang.in: Link f/fini with safe-ctype.o.
- * bad.c: Don't test ISUPPER(c) || ISLOWER(c) before calling TOUPPER(c).
- * com.c: Use TOUPPER, not ffesrc_toupper.
- * fini.c: Don't test ISALPHA(c) before calling TOUPPER(c)/TOLOWER(c).
- * intrin.c: Don't test IN_CTYPE_DOMAIN(c).
- * src.c: Delete ffesrc_toupper_ and ffesrc_tolower_ and their
- initializing code; use TOUPPER and TOLOWER instead of
- ffesrc_toupper and ffesrc_tolower.
- * src.h: Don't declare ffesrc_toupper_ or ffesrc_tolower_.
- Don't define ffesrc_toupper or ffesrc_tolower.
-
-2000-11-28 Richard Henderson <rth@redhat.com>
-
- * com.c (ffecom_member_phase2_): Set TREE_USED on the debugging decl.
-
-2000-11-26 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * RELEASE-PREP: Remove obsolete EGCS reference.
- * g77.texi: Adjust reference to EGCS as something current.
- * lang-options.h (FTNOPT): Remove macro and obsolete comment.
- Include doc strings directly in option listing instead of through
- this macro.
- * root.texi: Remove support for multiple different (FSF and EGCS)
- distributions of g77.
- * g77install.texi: Remove conditioned out instructions applying
- only to obsolete distributions of g77 not as part of GCC. Change
- "superceded" to the correct spelling "superseded".
-
-Sun Nov 26 19:25:56 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lang_specific_driver): Update copyright year to 2000.
-
-Thu Nov 23 02:18:57 2000 J"orn Rennecke <amylaar@redhat.com>
-
- * Make-lang.in (g77spec.o): Depend on $(CONFIG_H).
-
-2000-11-21 David Billinghurst <David.Billinghurst@riotinto.com)
-
- * Make-lang.in: Add $(build_exeext) to f/fini target
-
-2000-11-21 Andreas Jaeger <aj@suse.de>
-
- * g77.texi (Floating-point Exception Handling): Use feenableexcept
- in example.
- (Floating-point precision): Change to match above change.
-
-Sun Nov 19 17:29:22 2000 Matthias Klose <doko@marvin.itso-berlin.de>
-
- * g77.texi (Floating-point precision): Adjust example
- to work with glibc (>= 2.1).
-
-Sat Nov 18 13:54:49 2000 Matthias Klose <doko@cs.tu-berlin.de>
-
- * g77.texi (Floating-point Exception Handling): Adjust
- example to work with glibc (>= 2.1).
-
-2000-11-18 Alexandre Oliva <aoliva@redhat.com>
-
- * Make-lang.in (INTDOC_DEPS): New macro.
- (f/intdoc.texi): Depend on $(INTDOC_DEPS). Build f/intdoc.
- (f/intdoc): Likewise. Add $(build_exeext).
-
-2000-11-17 Zack Weinberg <zack@wolery.stanford.edu>
-
- * lex.c (ffelex_hash_): Change ggc_alloc_string (var, -1) to
- ggc_strdup (var).
-
-Thu Nov 16 23:14:07 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * malloc.c (malloc_init): Call xmalloc, not malloc.
-
-2000-11-10 Rodney Brown <RodneyBrown@mynd.com>
-
- * Make-lang.in: Remove OUTPUT_OPTION from g77version.o target.
-
-2000-11-10 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi: Remove non-historical EGCS reference.
- Set current g77 version to 0.5.26.
-
-2000-11-10 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_stabilize_aggregate_) case RTL_EXPR: Abort.
-
-2000-11-10 Zack Weinberg <zack@wolery.stanford.edu>
-
- * Make-lang.in (f/fini.o, f/proj-h.o): Remove pointless sed
- munging of source file name.
- ($(srcdir)/f/intdoc.texi): Break up into several rules each of
- which builds just one thing. Don't mess with $(LANGUAGES).
- (f/ansify.o, f/intdoc.o): Remove unnecessary rules.
-
-2000-11-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi, news.texi, g77install.texi, g77.texi, bugs.texi:
- Remove non-historical references to egcs/EGCS.
-
-2000-11-05 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in: Remove f77.distdir and f/INSTALL.
- * INSTALL, install0.texi: Remove.
-
-2000-11-02 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * com.c (open_include_file, ffecom_open_include_): Use strchr ()
- and strrchr () instead of index () and rindex ().
-
-2000-10-27 Zack Weinberg <zack@wolery.stanford.edu>
-
- * Make-lang.in: Move all build rules here from Makefile.in,
- adapt to new context. Wrap all rules that change the current
- directory in parentheses. Expunge all references to $(P).
- When one command depends on another and they're run all at
- once, use && to separate them, not ;. Add OUTPUT_OPTION to
- all object-file generation rules. Delete obsolete variables.
-
- * Makefile.in: Delete.
- * config-lang.in: Delete outputs= line.
-
-Sat Oct 21 18:07:48 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Makefile.in, g77spec.c: Remove EGCS references in comments.
-
-Thu Oct 12 22:28:51 2000 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_do_entry_): Don't mess with obstacks.
- (ffecom_finish_global_): Likewise.
- (ffecom_finish_symbol_transform_): Likewise.
- (ffecom_gen_sfuncdef_): Likewise.
- (ffecom_init_zero_): Likewise.
- (ffecom_start_progunit_): Likewise.
- (ffecom_sym_transform_): Likewise.
- (ffecom_sym_transform_assign_): Likewise.
- (ffecom_transform_equiv_): Likewise.
- (ffecom_transform_namelist_): Likewise.
- (ffecom_vardesc_): Likewise.
- (ffecom_vardesc_array_): Likewise.
- (ffecom_vardesc_dims_): Likewise.
- (ffecom_end_transition): Likewise.
- (ffecom_make_tempvar): Likewise.
- (bison_rule_pushlevel_): Likewise.
- (bison_rule_compstmt_): Likewise.
- (finish_decl): Likewise.
- (finish_function): Likewise.
- (push_parm_decl): Likewise.
- (start_decl): Likewise.
- (start_function): Likewise.
- (ggc_p): Don't define.
- * std.c (ffestd_stmt_pass_): Likewise.
- * ste.c (ffeste_end_block_): Likewise.
- (ffeste_end_stmt_): Likewise.
- (ffeste_begin_iterdo_): Likewise.
- (ffeste_io_ialist_): Likewise.
- (ffeste_io_cilist_): Likewise.
- (ffeste_io_inlist_): Likewise.
- (ffeste_io_olist_): Likewise.
- (ffeste_R810): Likewise.
- (ffeste_R838): Likewise.
- (ffeste_R839): Likewise.
- (ffeste_R842): Likewise.
- (ffeste_R843): Likewise.
- (ffeste_R1001): Likewise.
-
-2000-10-05 Richard Henderson <rth@cygnus.com>
-
- * com.c (finish_function): Don't init can_reach_end.
-
-Sun Oct 1 11:43:44 2000 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (lang_mark_false_label_stack): Remove.
-
-2000-09-10 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c: Include defaults.h.
- * com.h: Don't define the *_TYPE_SIZE macros.
- * Makefile.in: Update dependencies.
-
-2000-08-29 Zack Weinberg <zack@wolery.cumb.org>
-
- * ansify.c: Use #line, not # <number>.
-
-2000-08-24 Greg McGary <greg@mcgary.org>
-
- * intdoc.c (ARRAY_SIZE): Remove macro.
- * proj.h (ARRAY_SIZE): Remove macro.
- * com.c (init_decl_processing): Use ARRAY_SIZE.
-
-2000-08-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com-rt.def: Adapt macro DEFGFRT to accept CONST boolean.
- * com.c (macro DEFGFRT): Use CONST boolean.
- (ffecom_call_binop_): Choose between call by value
- and call by reference.
- (ffecom_expr_): Use direct calls to (g)libc functions for
- POW_DD, LOG10, (float) MOD.
- (ffecom_make_gfrt_): Add const indication to table of
- intrinsics.
- * com.h (macro DEFGFRT): Use CONST boolean.
- * intrin.def: Adjust DEFIMP definition of LOG10, (float) MOD.
-
-2000-08-21 Nix <nix@esperi.demon.co.uk>
-
- * lang-specs.h: Do not process -o or run the assembler if
- -fsyntax-only. Use %j instead of /dev/null.
-
-2000-08-21 Jakub Jelinek <jakub@redhat.com>
-
- * lang-specs.h: Pass -I* options to f771.
-
-2000-08-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * top.c (ffe_decode_option): Disable -fdebug-kludge
- and warn about it.
- * lang-options.h: Document the fact.
- * g77.texi: Ditto.
-
-2000-08-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bugs.texi: Describe new ability to emit debug info
- for EQUIVALENCE members.
- * news.texi: Ditto.
-
-2000-08-11 G. Helffrich <george@gly.bris.ac.uk>
- Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_transform_equiv_): Make EQUIVALENCEs addressable
- so that debug info can be attached to their storage.
- Unconditionally list the storage set aside for them.
-
-2000-08-07 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77spec.c (lang_specific_driver): Clearer g77 version message.
-
-2000-08-04 Zack Weinberg <zack@wolery.cumb.org>
-
- * Make-lang.in (f771): Depend on $(BACKEND), not stamp-objlist.
- * Makefile.in: Add BACKEND; delete OBJS, OBJDEPS.
- (f771): Link with $(BACKEND).
-
-2000-08-02 Zack Weinberg <zack@wolery.cumb.org>
-
- * g77spec.c: Adjust type of second argument to
- lang_specific_driver, and update code as necessary.
-
- * expr.c (ffeexpr_finished_): Cast signed side of ?:
- expression to bool.
-
-2000-07-31 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Rename cpp to cpp0 and/or tradcpp to tradcpp0.
-
-Thu Jul 27 11:50:08 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * fini.c (main): Avoid automatic aggregate initialization.
-
- * proj.h: Indent #error directive.
-
-2000-07-26 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * lang-specs.h: Remove one /dev/null from tradcpp invocation.
-
-Sun Jul 23 15:47:30 2000 Billinghurst, David <David.Billinghurst@riotinto.com>
-
- * Make-lang.in: Put $(build_exeext) suffix on programs which run
- on the build machine.
-
-2000-07-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_expr_intrinsic_): case FFEINTRIN_impFGETC_subr,
- FFEINTRIN_impFPUTC_subr: Check for arg3 being NULL.
-
-2000-07-13 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Use the new named specs. Remove unnecessary braces.
-
-2000-07-02 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * version.c: Bump version number.
-
-2000-06-21 Zack Weinberg <zack@wolery.cumb.org>
-
- * Make-lang.in (F77_SRCS): Remove all .j files.
- * Makefile.in (ASSERT_H, CONFIG_H, CONVERT_H, FLAGS_H, GGC_H,
- GLIMITS_H, HCONFIG_H, INPUT_H, OUTPUT_H, RTL_H, SYSTEM_H,
- TOPLEV_H, TREE_H): Remove references to .j files.
- (TCONFIG_H, TM_H): Remove entirely.
- (deps-kinda): Delete rule.
- Correct commentary.
-
- * assert.j, config.j, convert.j. flags.j, ggc.j, glimits.j,
- hconfig.j, input.j, output.j, rtl.j, system.j, toplev.j,
- tree.j, tconfig.j, tree.j: Delete.
-
- * ansify.c, bad.c, bit.c, com.c, com.h, intdoc.c, lex.c,
- parse.c, proj.c, proj.h, ste.c, target.c, target.h, top.c,
- where.c, where.h: Include parent-directory headers directly.
- * lex.c: Don't include tree.h twice.
-
-2000-05-17 H.J. Lu (hjl@gnu.org)
-
- * Make-lang.in: Use a unique stamp for each target to support
- parallel make.
-
-Thu Jun 15 14:03:14 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * ste.c (gbe_block): Constify.
-
-2000-06-13 Jakub Jelinek <jakub@redhat.com>
-
- * com.c (ffecom_transform_common_): Set DECL_USER_ALIGN.
- (ffecom_transform_equiv_, ffecom_decl_field): Likewise.
- (ffecom_init_0): Set DECL_USER_ALIGN resp. TYPE_USER_ALIGN.
- (duplicate_decls): Set DECL_USER_ALIGN.
-
-Sun Jun 11 00:03:00 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (lang_get_alias_set): Mark parameter with ATTRIBUTE_UNUSED.
-
-2000-06-04 Philipp Thomas <pthomas@suse.de>
-
- * Makefile.in(INTLLIBS): New macro.
- (LIBS): Add INTLLIBS.
- (DEPLIBS): Likewise.
-
-2000-06-02 Richard Henderson <rth@cygnus.com>
-
- * com.c (lang_get_alias_set): New.
-
-2000-05-28 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bugs.texi: Note that debugging information for
- common block items is emitted now.
- * news.texi: Ditto.
-
-2000-05-18 Chris Demetriou <cgd@sibyte.com>
-
- * com.h (FFECOM_f2cINTEGER, FFECOM_f2cLONGINT): Note that
- these types correspond to built-in types now defined in
- the C front end (for libf2c).
-
-Wed May 17 17:27:44 2000 Andrew Cagney <cagney@b1.cygnus.com>
-
- * top.c (ffe_decode_option): Update -Wall unused flags by calling
- set_Wunused.
-
-2000-05-09 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c (ffecom_subscript_check_): Constify array_name
- parameter. Clean up string bashing.
- (ffecom_arrayref_, ffecom_char_args_x_): Constify array_name
- parameter.
- (ffecom_do_entry_, ffecom_gen_sfuncdef_, ffecom_start_progunit_,
- ffecom_sym_transform_, ffecom_sym_transform_assign_): Constify
- local char *.
- (init_parse): Constify parameter and return value.
- * lex.c: Include dwarfout.h instead of prototyping dwarfout_*
- functions here.
- (ffelex_file_pop_, ffelex_file_push_): Constify filename parameter.
- (ffelex_hash_, ffelex_include_): Constify local char *.
- * std.c (ffestd_exec_end): Constify local char *.
- * where.c (ffewhere_file_new): Constify filename parameter.
- * where.h: Update prototypes.
-
-2000-05-06 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c (ffecom_overlap_): Set source_offset to
- bitsize_zero_node.
- (ffecom_tree_canonize_ptr_): Use size_binop. Convert to
- bitsizetype before multiplying by TYPE_SIZE.
- (ffecom_tree_canonize_ref_) [case ARRAY_REF]: Break up offset
- calculation. Convert to bitsizetype before multiplying by
- TYPE_SIZE.
-
-2000-04-18 Zack Weinberg <zack@wolery.cumb.org>
-
- * lex.c: Remove references to cccp.c.
- * g77install.texi: Remove references to cexp.c/cexp.y.
-
-2000-04-15 David Edelsohn <edelsohn@gnu.org>
-
- * target.h (FFETARGET_32bit_longs): Define for 64-bit PowerPC
- as well.
-
-Wed Apr 12 15:15:26 2000 Mark Mitchell <mark@codesourcery.com>
-
- * com.h (FFECOM_f2cINTEGER): Avoid using LONG_TYPE_SIZE as a
- preprocessor constant.
- (FFECOM_f2cLOGICAL): Likewise.
- (FFECOM_f2cLONGINT): Likewise.
-
-Wed Apr 5 17:46:39 2000 Mark Mitchell <mark@codesourcery.com>
-
- * Makefile.in (GGC_H): Add varray.h.
-
-2000-04-03 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Pass -fno-show-column to the preprocessor.
-
-2000-03-28 Franz Sirl <Franz.Sirl-kernel@lauterbach.com>
-
- * com.c (ffecom_decl_field): Use DECL_ALIGN for a FIELD_DECL.
- (ffecom_init_0): Likewise.
-
-Sat Mar 25 09:12:10 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_tree_canonize_ptr_): Use bitsize_zero_node.
- (ffecom_tree_canonize_ref_): Likewise.
-
-Mon Mar 20 15:49:40 2000 Jim Wilson <wilson@cygnus.com>
-
- * f/target.h (FFETARGET_32bit_longs): New. Define for alpha, sparc64,
- and ia64.
- (ffetargetInteger1, ffetargetLogical1, ffetargetReal1, ffetargetReal2,
- ffetarget_integerdefault_is_magical): Use FFETARGET_32bit_longs.
-
-Fri Mar 10 00:43:55 2000 Jason Merrill <jason@casey.cygnus.com>
-
- * com.c (ffecom_stabilize_aggregate_): Don't refer to TREE_RAISES.
-
-Mon Mar 6 18:05:19 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_f2c_set_lio_code_): Use compare_tree_int.
- (ffecom_sym_transform_, ffecom_transform_common_): Likewise.
- (ffecom_transform_equiv_): Likewise.
-
-Mon Mar 6 13:01:19 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * ansify.c (die_unless): Don't use ANSI string concatenation.
- (die): Mark with ATTRIBUTE_NORETURN.
-
-Wed Mar 1 00:31:44 2000 Martin von Loewis <loewis@informatik.hu-berlin.de>
-
- * com.c (current_function_decl): Move to toplev.c.
-
-Sun Feb 27 16:40:33 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_arrayref_): Convert args to size_binop to proper type.
- (ffecom_tree_canonize_ptr_): Don't use size_binop for non-sizes.
- (ffecom_tree_canonize_ref_): Likewise.
- (type_for_mode): Handle TImode.
- * ste.c (ffeste_io_dofio_, ffeste_io_douio_): Use TYPE_SIZE_UNIT.
- (ffeste_io_ciclist_): Likewise.
-
-2000-02-23 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c (ffecom_type_permanent_copy_): Delete unused function.
- (finish_decl): Don't change TREE_PERMANENT (DECL_INITIAL (decl)).
-
-Sat Feb 19 18:43:13 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_sym_transform): Use DECL_SIZE_UNIT.
- (ffecom_transform_common_, ffecom_transform_equiv_): Likewise.
- (duplicate_decls): Likewise.
- (ffecom_tree_canonize_ptr_): Delete extra arg to bitsize_int.
- (finish_decl): Delete -Wlarger-than processing.
-
-Fri Feb 18 13:19:34 2000 Martin von Loewis <loewis@informatik.hu-berlin.de>
-
- * g77spec.c (lang_specific_driver): Use GCCBUGURL.
-
-2000-02-17 Andy Vaught <andy@maxwell.la.asu.edu>
-
- * com.c (ffecom_member_phase2_): Re-enable COMMON debug code.
- (ffecom_finish_symbol_transform_): Likewise.
- (ffecom_transform_common_): Call ffestorag_set_hook.
-
-Wed Feb 16 11:09:38 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (g77spec.o): Depend on $(GCC_H), not gcc.h.
-
-2000-02-15 Jonathan Larmour <jlarmour@redhat.co.uk>
-
- * lang-specs.h: Add new __GNUC_PATCHLEVEL__ define to default spec.
-
-Tue Feb 15 11:14:17 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * g77spec.c: Don't declare `version_string'.
-
-Sat Feb 5 23:27:25 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (mark_tracker_head, mark_binding_level): Protoize.
-
- * where.c (mark_ffewhere_head): Likewise.
-
-Wed Jan 12 09:32:59 2000 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Pass -lang-fortran to preprocessor.
-
-Thu Dec 30 13:14:31 1999 Richard Henderson <rth@cygnus.com>
-
- * stw.h (struct _ffestw_): Change type of uses_ to int.
-
-Thu Dec 30 11:42:05 1999 Geoff Keating <geoffk@cygnus.com>
-
- * com.c (ffecom_init_0): Make double_ftype_double,
- float_ftype_float, ldouble_ftype_ldouble,
- ffecom_tree_ptr_to_fun_type_void local.
- (tracker_head): New static variable.
- (mark_tracker_head): New, marker procedure for tracker_head.
- (ffecom_save_tree_forever): New procedure.
- (ffecom_init_zero_): Remove obstack use.
- (ffecom_make_gfrt_): Remove obstack use.
- (ffecom_sym_transform_): Remove obstack use, save appropriate trees.
- (ffecom_transform_common_): Remove obstack use, save appropriate
- trees.
- (ffecom_type_namelist_): Remove obstack use, save appropriate
- trees.
- (ffecom_type_vardesc_): Remove obstack use, save appropriate trees.
- (ffecom_lookup_label): Remove obstack use, save appropriate trees.
- (duplicate_decls): Remove obstack use.
- (finish_function): push & pop ggc context around
- rest_of_compilation when building nested function.
- (mark_binding_level): New function.
- (init_decl_processing): Mark all the GC roots.
- (ggc_p): Set to 1.
- (lang_mark_tree): New function.
- (lang_mark_false_label_stack): New trivial function.
- * com.h (ffecom_save_tree_forever): Declare as external.
- * lex.c (ffelex_hash_): Use GC to allocate the filename string
- even when ffelex_kludge_flag_.
- * ste.c (ffeste_io_ialist_): Register a static root.
- (ffeste_io_inlist_): Likewise.
- (ffeste_io_icilist_): Likewise.
- (ffeste_io_cllist_): Likewise.
- (ffeste_io_cilist_): Likewise.
- (ffeste_io_olist_): Likewise.
- * Makefile.in (OBJS): Don't use ggc-callbacks.o.
- (OBJDEPS): Likewise.
- (GGC_H): New variable.
- Update dependencies.
- * where.c (ffewhere_head): New global.
- (mark_ffewhere_head): New marker procedure for ffewhere_head.
- (ffewhere_file_kill): Use GC to do memory management.
- (ffewhere_file_new): Use GC to do memory management.
- * ggc.j: New file.
-
-Wed Dec 29 19:29:26 1999 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * g77.texi (C Interfacing Tools): Fix an incorrect link.
-
-1999-12-13 Jakub Jelinek <jakub@redhat.com>
-
- * target.h: Handle sparc64 the same way as alpha.
-
-Sun Nov 28 21:39:05 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_file_, ffecom_file, file_buf,
- ffecom_open_include_): Constify a char*.
- (ffecom_possible_partial_overlap_): Mark parameter `expr2' with
- ATTRIBUTE_UNUSED.
- (ffecom_init_0): Use a fully prototyped cast in call to bsearch.
- (lang_print_error_function): ANSI-fy.
-
- * com.h (ffecom_file): Constify a char*.
-
- * fini.c (main): Call return, not exit.
-
- * g77spec.c (lang_specific_driver): Use non-const *in_argv in
- assignment.
-
- * intrin.c (ffeintrin_cmp_name_): Don't needlessly cast away
- const-ness.
-
-Sun Nov 28 21:15:29 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_get_invented_identifier): Rewrite to take an ellipses.
-
- (ffecom_char_enhance_arg_, ffecom_do_entry_,
- ffecom_f2c_make_type_, ffecom_gen_sfuncdef_,
- ffecom_start_progunit_, ffecom_start_progunit_,
- ffecom_start_progunit_, ffecom_sym_transform_assign_,
- ffecom_transform_equiv_, ffecom_transform_namelist_,
- ffecom_vardesc_, ffecom_vardesc_array_, ffecom_vardesc_dims_,
- ffecom_end_transition, ffecom_lookup_label, ffecom_temp_label):
- Adjust accordingly.
-
- * com.h (ffecom_get_invented_identifier): Likewise.
-
- * sts.c (ffests_printf): New function taking ellipses.
- (ffests_printf_1D, ffests_printf_1U, ffests_printf_1s,
- ffests_printf_2Us): Delete.
-
- * sts.h: Likewise.
-
- * std.c (ffestd_R1001dump_, ffestd_R1001dump_1005_1_,
- ffestd_R1001dump_1005_2_, ffestd_R1001dump_1005_3_,
- ffestd_R1001dump_1005_4_, ffestd_R1001dump_1005_5_,
- ffestd_R1001dump_1010_2_, ffestd_R1001dump_1010_3_,
- ffestd_R1001dump_1010_4_, ffestd_R1001dump_1010_5_,
- ffestd_R1001rtexpr_): Call `ffests_printf', not `ffests_printf_*'.
-
- * ste.c (ffeste_io_ialist_, ffeste_io_cilist_, ffeste_io_cllist_,
- ffeste_io_icilist_, ffeste_io_inlist_, ffeste_io_olist_): Likewise.
-
-Wed Nov 10 12:43:21 1999 Philippe De Muyter <phdm@macqel.be>
- Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * proj.h: Test `GCC_VERSION', not `HAVE_GCC_VERSION'.
-
-Tue Oct 26 01:32:19 1999 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (poplevel): Don't call remember_end_note.
-
-Fri Oct 15 15:18:12 1999 Greg McGary <gkm@gnu.org>
-
- * top.h (ffe_is_subscript_check_): Remove extern decl.
- (ffe_is_subscript_check, ffe_set_is_subscript_check): Remove macros.
- * top.c (ffe_is_subscript_check_): Remove global variable.
- (ffe_decode_option): Remove "(no-)bounds-check" flag handling.
- Set flag_bounds_check for "(no-)fortran-bounds-check".
- * com.c
- (ffecom_arrayref_): s/ffe_is_subscript_check ()/flag_bounds_check/
- (ffecom_char_args_x_): Ditto.
-
-Sun Oct 10 08:40:18 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * proj.h: Use HAVE_GCC_VERSION instead of explicitly testing
- __GNUC__ and __GNUC_MINOR__. Don't define BUILT_WITH_270. Define
- macro UNUSED in terms of ATTRIBUTE_UNUSED.
-
-Fri Sep 24 10:48:10 1999 Bernd Schmidt <bernds@cygnus.co.uk>
-
- * com.c (duplicate_decls): Use DECL_BUILT_IN_CLASS rather than
- DECL_BUILT_IN.
- (builtin_function): No longer static. New arg CLASS. Arg
- FUNCTION_CODE now of type int. All callers changed.
- Set the builtin's DECL_BUILT_IN_CLASS.
-
-Tue Sep 21 09:08:30 1999 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77spec.c (lang_specific_driver): Initialize return value.
-
-Thu Sep 16 18:07:11 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Use uppercase ctype macro from system.h.
-
- * fini.c (main): Likewise.
-
- * intrin.c (ffeintrin_init_0): Likewise.
-
- * lex.c (ffelex_hash_): Likewise.
-
- * src.c (ffesrc_init_1): Likewise.
-
-Tue Sep 14 12:14:28 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * g77spec.c (lang_specific_driver): Remove unnecessary argument in
- call to function `fatal'.
-
-Sun Sep 12 23:29:47 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (g77spec.o): Depend on system.h and gcc.h.
-
- * g77spec.c: Include gcc.h.
- (g77_xargv): Constify.
- (g77_fn): Add parameter prototypes.
- (lookup_option, append_arg): Add static prototypes.
- (g77_newargv): Constify.
- (lookup_option, append_arg, lang_specific_driver): Constify a char*.
- (lang_specific_driver): All calls to the function pointer
- parameter now explicitly call `fatal'.
-
-Fri Sep 10 10:32:32 1999 Bernd Schmidt <bernds@cygnus.co.uk>
-
- * com.h: Delete declarations for all tree nodes now moved to
- global_trees.
- * com.c: Delete their definitions.
- (ffecom_init_0): Call build_common_tree_nodes and
- build_common_tree_nodes_2 instead of building their nodes here.
- Override their decisions for complex nodes.
-
-Sat Sep 4 13:46:27 1999 Mark Mitchell <mark@codesourcery.com>
-
- * Make-lang.in (f771): Depend on ggc-callbacks.o.
- * Makefile.in (OBJS): Add ggc-callbacks.o.
- (OBJDEPS): Likewise.
-
-Mon Aug 30 22:05:53 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (language_string): Constify.
-
-Mon Aug 30 20:29:30 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Makefile.in (LIBS, LIBDEPS): Link with & depend on libiberty.a.
- Remove hacks for stuff which now comes from libiberty.
-
-Sun Aug 29 09:47:45 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (lang_printable_name): Constify a char*.
-
-Wed Aug 25 01:21:06 1999 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * lang-specs.h: Pass cc1 spec to f771.
-
-Mon Aug 9 19:44:08 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (lang_print_error_function): Constify a char*.
- (init_parse): Remove redundant prototype for `print_error_function'.
- (lang_identify): Constify a char*.
-
-Thu Aug 5 02:40:42 1999 Jeffrey A Law (law@cygnus.com)
-
- * g77spec.c: Update URLS and mail addresses.
- * root.texi: Update URLS and mail addresses.
-
-1999-07-25 Richard Henderson <rth@cygnus.com>
-
- * com.c (ptr_type_node, va_list_type_node): New.
- (ffecom_init_0): Init and use ptr_type_node.
-
-1999-07-17 Alexandre Oliva <oliva@dcc.unicamp.br>
-
- * root.texi: Update e-mail addresses to gcc.gnu.org.
- * g77spec.c (lang_specific_driver): Updated URL with bug reporting
- instructions to gcc.gnu.org. Removed e-mail address.
-
-Sat Jul 17 11:28:43 1999 Craig Burley <craig@jcb-sc.com>
-
- * root.texi, g77install.texi: Switchover to GCC terminology.
- Also, FSF-G77 had been mistakenly set at some point.
-
-Thu Jul 8 15:38:50 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Describe DATE intrinsic fix.
-
-Mon Jun 28 21:44:19 1999 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Denote experimental version.
-
-Mon Jun 28 10:43:11 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (ffecom_prepare_expr_): A COMPLEX intrinsic needs
- a temp even if -fno-f2c.
-
- * version.c: Bump version.
-
-Mon Jun 28 21:31:35 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Doc upgrade to netlib libf2c as of today.
- Explain that this fixes the NAMELIST-read bug.
-
-Fri Jun 25 11:06:32 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi: Describe K(5)=10*3 NAMELIST-read bug.
-
-Mon Jun 21 12:40:17 1999 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * g77.texi: Update links.
-
-Mon Jun 21 05:33:51 1999 Jeffrey A Law (law@cygnus.com)
-
- * news.texi: Add missing @end ifclear.
-
-Fri Jun 18 11:43:46 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Doc TtyNam fix.
-
-Fri Jun 18 11:26:50 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: New heading for development version.
- Doc upgrade to netlib libf2c as of today.
-
-Wed Jun 16 11:43:02 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Mention BACKSPACE fix to libg2c.
-
-Mon Jun 7 08:42:40 1999 Craig Burley <craig@jcb-sc.com>
-
- * Make-lang.in: Any target using libsubdir must depend
- on installdirs.
-
-Sat Jun 5 23:50:36 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Describe a few more missing features people
- have emailed me about.
-
-Sat Jun 5 17:03:23 1999 Craig Burley <craig@jcb-sc.com>
-
- From Dave Love to egcs-patches on 20 May 1999 17:38:38 +0100:
- * g77.texi: Clean up fossil text vis-a-vis Intel CPUs.
-
-Fri Jun 4 13:56:56 1999 Craig Burley <craig@jcb-sc.com>
-
- * Make-lang.in: Use libsubdir, not prefix, to store
- temporary lang-f77 `flag' file.
-
-Fri Jun 4 10:26:04 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi (News): Mention GCC 2.95 in favor of EGCS 1.2.
- Mention that libg2c is multilibbed.
-
-Fri Jun 4 10:09:50 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Missing Features): Add `Better Warnings'
- item.
-
-Fri May 28 16:51:41 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Fix thinko.
-
-Wed May 26 14:43:27 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Document Tue May 18 03:52:04 1999 patch.
- Fix a grammo.
-
-Wed May 26 14:25:07 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi, news.texi, root.texi, version.c: Start renaming
- EGCS 1.2 to GCC 2.95, and start using 0.5.25 to designate
- the version of g77 within GCC 2.95.
-
-Wed May 26 11:45:21 1999 Craig Burley <craig@jcb-sc.com>
-
- Rename -fsubscript-check to -fbounds-check and
- -ff2c-subscript-check to -ffortran-bounds-check:
- * g77.texi: Rename options in docs, clarify usage.
- * lang-options.h: Rename options, clarify doclets.
- * news.texi: Rename options, don't bother with fortran-specific
- option.
- * top.c (ffe_decode_option): Rename recognized strings.
-
-Tue May 25 18:21:09 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (FFECOM_FASTER_ARRAY_REFS): Delete this vestige,
- now that -fflatten-arrays exists.
-
-Tue May 25 17:48:34 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix 19990525-0.f:
- * com.c (ffecom_arg_ptr_to_expr): Strip off parens around
- CHARACTER expression.
- (ffecom_prepare_expr_): Ditto.
-
-Tue May 18 03:52:04 1999 Craig Burley <craig@jcb-sc.com>
-
- Support use of back end's improved open-coding of complex divide:
- * com.c (ffecom_tree_divide_): Use RDIV_EXPR for complex divide,
- instead of run-time call to [cz]_div, if `-Os' option specified.
- (lang_init_options): Tell back end we want support for wide range
- of inputs to complex divide.
-
- * Bump version.
-
-Tue May 18 00:21:34 1999 Zack Weinberg <zack@rabi.phys.columbia.edu>
-
- * lang-specs.h: Define __GNUC__ and __GNUC_MINOR__ only if -no-gcc
- was not given.
-
-Thu May 13 12:23:20 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix INTEGER*8 subscripts in array references:
- * com.c (ffecom_subscript_check_): Convert low, high, and
- element as necessary to make comparison work.
- (ffecom_arrayref_): Do more of the work.
- Properly handle subscript expr that's wider than int,
- if pointers are wider than int.
- (ffecom_expr_): Leave more work to ffecom_arrayref_.
- (ffecom_init_0): Record sizes of pointers and ints for
- convenience.
- Use set_sizetype etc. as done by gcc front end.
- (ffecom_ptr_to_expr): Leave more work to ffecom_arrayref_.
- * expr.c (ffeexpr_finished_): Don't convert INTEGER subscript
- expressions in run-time contexts.
- (ffeexpr_token_elements_, ffeexpr_token_substring_1_): Cope with
- non-default INTEGER subscript expressions.
- * news.texi: Announce.
-
- Finish accepting -fflatten-arrays option:
- * com.c (ffecom_arrayref_): Flatten references if requested.
- * g77.texi: Describe.
- * lang-options.h: Allow.
- * news.texi: Announce.
- * top.c, top.h: Recognize.
-
- * version.c: Bump version.
-
-Wed May 12 07:30:05 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (lang_init_options): Disable back end's maintenance
- of errno.
- * news.texi: Document dropping of errno.
-
-1999-05-10 18:21 -0400 Zack Weinberg <zack@rabi.phys.columbia.edu>
-
- * lang-specs.h: Pass -$ to the preprocessor.
-
-Mon May 10 18:14:28 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Fix various @xref's per proper style.
- Go ahead and use nested braces in @xref's, with care.
- * g77install.texi: Fix @xref per proper style.
-
-Mon May 10 17:38:39 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Doc upgrade to netlib libf2c as of today.
-
-Sun May 9 18:52:13 1999 Hans-Peter Nilsson <hp@bitrange.com>
-
- * f/g77spec.c (lang_specific_driver): Correct bug-report address
- and point to the FAQ.
-
-Thu May 6 12:40:21 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Arbitrary Concatenation): Put this under
- "Missing Features" instead of "Projects".
- (Internals Documentation): Point to new "Front End" chapter.
-
-Thu May 6 08:23:52 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Automatic arrays reportedly working
- on HP-UX systems.
-
-Thu May 6 08:19:31 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Advantages Over f2c): Expand on this topic.
-
-Mon May 3 19:41:48 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (ffecom_expr_intrinsic_): Fix test of CTIME_subr.
-
-Mon May 3 18:11:48 1999 Craig Burley <craig@jcb-sc.com>
-
- Reverse order of two arguments to CTIME_subr, DTIME_subr,
- ETIME_subr, and TTYNAM_subr:
- * com.c (ffecom_expr_intrinsic_): Reverse the arguments.
- While at it, set TREE_SIDE_EFFECTS for CTIME_subr and
- TTYNAM_subr.
- * intdoc.in: Document the new calling sequences.
- * intrin.def: Reverse the arguments.
- * news.texi: Document the fact that they changed.
- * version.c: Bump version.
-
-Mon May 3 11:28:14 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Doc upgrade to netlib libf2c as of today.
-
-Sun May 2 17:04:28 1999 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Bump version.
-
-Sun May 2 16:53:01 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix compile/19990502-1.f:
- * ste.c (ffeste_R819B): Don't overwrite tree for temp
- variable when expanding the assignment into it.
-
-Sun Apr 25 20:55:10 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix 19990325-0.f and 19990325-1.f:
- * com.c (ffecom_possible_partial_overlap_): New function.
- (ffecom_expand_let_stmt): Use it to determine whether to assign
- to a COMPLEX operand through a temp.
- * news.texi: Document fix.
-
- * version.c: Bump version.
-
-Sat Apr 24 12:19:53 1999 Craig Burley <craig@jcb-sc.com>
-
- * expr.c (ffeexpr_finished_): Convert DATA implied-do
- start/end/incr expressions to default INTEGER.
- Fix some broken conditionals.
- Clean up some code in the region.
- * news.c: Document the fix.
-
- * version.c: Bump version.
-
-Fri Apr 23 02:08:32 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Compiler Prototypes): Replace "missing" subscript-
- checking option with something else.
-
-Fri Apr 23 01:48:28 1999 Craig Burley <craig@jcb-sc.com>
-
- Support new -fsubscript-check and -ff2c-subscript-check options:
- * com-rt.def (FFECOM_gfrtRANGE): Describe s_rnge, in libf2c/libF77.
- * com.c (ffecom_subscript_check_, ffecom_arrayref_): New functions.
- (ffecom_char_args_x_): Use new ffecom_arrayref_ function for
- FFEBLD_opARRAYREF case.
- Compute character name, array type, and use new
- ffecom_subscript_check_ function for FFEBLD_opSUBSTRING case.
- (ffecom_expr_): Use new ffecom_arrayref_ function.
- (ffecom_ptr_to_expr): Use new ffecom_arrayref_ function.
- * g77.texi, news.texi: Document new options.
- * top.c, top.h: Support new options.
-
- * news.texi: Fix up some items to not be in "User-Visible Changes".
-
- * ste.c (ffeste_R819B): Fix type for loop variable, to avoid
- warnings.
-
- * version.c: Bump version.
-
-Tue Apr 20 01:38:57 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Clarify -malign-double situation.
-
-Tue Apr 20 01:15:25 1999 Craig Burley <craig@jcb-sc.com>
-
- * stb.c (ffestb_R5282_): Convert DATA repeat count
- to default INTEGER, to avoid problems downstream.
-
- * version.c: Bump version.
-
-Mon Apr 19 21:36:48 1999 Craig Burley <craig@jcb-sc.com>
-
- * ste.c (ffeste_R819B): Start the loop before expanding
- the termination expression.
-
- * version.c: Bump version.
-
-Sun Apr 18 21:53:58 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (ffecom_sym_transform_): COMMON and EQUIVALENCE
- variables have constant addresses (EQUIVALENCE only if
- containing aggregate is static).
-
-Sat Apr 17 16:55:59 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, ffe.texi, g77.texi, g77install.texi, news.texi:
- Clean up @code{} vs. @samp{}.
- Clean up dashes (`--') vs. @minus{} vs. `---'.
-
- * ffe.texi: Add copyright header.
-
- * g77.texi, lang-options.h, news.texi, top.c (ffe_decode_option):
- Remove support for -fugly option.
- Clarify that -fugly-logint is needed instead of -fugly
- to work around using .EQ./.NE. on LOGICAL operands.
- Explain more about why -fugly-logint is bad juju.
-
- * g77.texi (Missing Features): Describe READONLY as a missing
- feature. Describe AUTOMATIC better.
-
- * news.texi: Mention libf2c upgrade.
-
-Sat Apr 17 14:05:53 1999 Craig Burley <craig@jcb-sc.com>
-
- Make a place for front-end internals documentation:
- * Make-lang.in (f/g77.info, f/g77.dvi): Depend on f/ffe.texi.
- * ffe.texi: New file, containing docs on front-end internals.
- * g77.texi: New chapter for, and inclusion of, ffe.texi.
-
- * g77.texi: Fix an index entry.
-
-Sat Apr 17 13:53:43 1999 Craig Burley <craig@jcb-sc.com>
-
- Rewrite to use block/scope structure of GBE and to ensure
- variables (especially those going on stack/reg) are declared
- before executable code generated:
- * bld.c (ffebld_new_item, ffebld_new_one, ffebld_new_two):
- Support new hooks.
- * bld.h (ffebld_item_hook, ffebld_item_set_hook,
- ffebld_nonter_hook, ffebld_nonter_set_hook): Ditto.
- * bld.h (ffebld_basictype, ffebld_kind, ffebld_kindtype,
- ffebld_rank, ffebld_where): New convenience macros (used
- by rest of this patch).
- * com.c, com.h (ffecom_push_calltemps, ffecom_pop_calltemps,
- ffecom_push_tempvar, ffecom_pop_tempvar): Remove temp-var-
- handling mechanism.
- * com.c (ffecom_call_, ffecom_call_binop_, ffecom_tree_divide_,
- ffecom_call_gfrt): Support passing hooks for temp-var info.
- (ffecom_expr_power_integer_): Takes opPOWER expression, instead
- of its left and right operands, so it can get at the hook.
- (ffecom_prepare_let_char_, ffecom_prepare_arg_ptr_to_expr,
- ffecom_prepare_end, ffecom_prepare_expr_, ffecom_prepare_expr_rw,
- ffecom_prepare_expr_w, ffecom_prepare_return_expr,
- ffecom_prepare_ptr_to_expr): New functions supporting expression
- pre-scanning.
- (bison_rule_compstmt_): Return the tree, as in the CFE.
- (delete_block): New function, from CFE.
- (kept_level_p): New function, from CFE, modified.
- (ffecom_start_compstmt, ffecom_end_compstmt): New functions,
- replacing ffecom_start_compstmt_ and ffecom_end_compstmt_ macros,
- and they do real work.
- (struct binding_level): Add prep_state member. Initialize to 0.
- (ffecom_get_invented_identifier): Now takes either or both a
- string and an integer, using -1 to denote no integer.
- (ffecom_do_entry_): Disallow temp-var generation via expressions
- in body of function, since the exprs aren't prescanned.
- (ffecom_expr_rw): Now takes destination tree.
- (ffecom_expr_w): New function, now used in some places
- ffecom_expr_rw had been used.
- (ffecom_expr_intrinsic_): Move huge f2c-related comment to bottom
- of source file, to avoid annoying problems editing com.c using
- Emacs C-mode.
- (ffecom_expr_power_integer_): Make a temp var for division, if
- necessary.
- Handle expanded statement expression as does CFE.
- (ffecom_start_progunit_): Disallow temp-var generation in body
- of function, since expressions are not prescanned at this level.
- (ffecom_sym_transform_): Transform ASSIGN variables as well,
- so these are all transformed up front, before code-generation
- begins.
- (ffecom_arg_ptr_to_const_expr, ffecom_const_expr,
- ffecom_ptr_to_const_expr): New functions to transform expressions
- only if the results will surely be constants.
- (ffecom_arg_ptr_to_expr): Precompute size, for convenience
- obtaining temp vars.
- (ffecom_expand_let_stmt): Guess at usability of destination
- pre-expansion, to provide better prescan preparation (fewer
- spurious temp vars).
- (ffecom_init_0): Disallow temp-var generation in global scope.
- (ffecom_type_expr): New function, returns just the type tree
- for the expression.
- (start_function): Disallow temp-var generation in parm scope.
- (incomplete_type_error): Fix introductory comment.
- (poplevel): Update (somewhat) from CFE.
- (pushlevel): Update (somewhat) from CFE.
- * stc.c (ffestc_R838): Mark ASSIGNed variable as so.
- * std.c (ffestd_stmt_pass_, ffestd_R803, ffestd_R804, ffestd_R805,
- ffestd_R806): Remember and pass through the ffestw block info
- for these (IFTHEN, ELSEIF, ELSE, and ENDIF) statements.
- * ste.c (ffeste_end_iterdo_): Now takes ffestw block argument.
- (ffeste_io_inlist_): Add prototype.
- (ffeste_f2c_*): Macros rewritten, new ones added.
- (ffeste_start_block_, ffeste_end_block_, ffeste_start_stmt_,
- ffeste_end_stmt_): New macros/functions, depending on whether
- checking is enabled, to keep track of symmetry of other ste.c code.
- (ffeste_begin_iterdo_, ffeste_end_iterdo_, ffeste_io_impdo_,
- ffeste_io_dofio_, ffeste_io_dolio_, ffeste_io_douio_,
- ffeste_io_ialist_, ffeste_io_cilist_, ffeste_io_cllist_,
- ffeste_icilist_, ffeste_io_inlist_, ffeste_io_olist_,
- ffeste_subr_beru_, ffeste_do, ffeste_end_R807, ffeste_R737A,
- ffeste_R803, ffeste_R804, ffeste_R805, ffeste_R806, ffeste_R807,
- ffeste_R809, ffeste_R810, ffeste_R811, ffeste_R819A, ffeste_R819B,
- ffeste_R837, ffeste_R838, ffeste_R839, ffeste_R840, ffeste_R904,
- ffeste_R907, ffeste_R909_start, ffeste_R909_item, ffeste_R909_finish,
- ffeste_R910_start, ffeste_R910_item, ffeste_R910_finish,
- ffeste_R911_start, ffeste_R911_item, ffeste_R911_finish,
- ffeste_R923A, ffeste_R1212, ffeste_R1227): Prescan/prepare
- all pertinent expressions, update to new com.c interface, etc.
- (ffeste_io_impdo_): Relocate.
- (ffeste_R834, ffeste_R835, ffeste_R836, ffeste_R1226): Don't
- bother calling clear_momentary, nothing was generated.
- (ffeste_R842, ffeste_R843): Update to new com.c interface.
- (ffeste_R1226): Don't try to stuff error_mark_node's DECL_INITIAL.
- (ffeste_terminate_2): When checking enabled, make sure all blocks
- and statements have been ended.
- * ste.h (ffeste_R803, ffeste_R804, ffeste_R805, ffeste_R806):
- These now take ffestw block argument.
- (ffeste_terminate_2): When checking enabled, it's a function, not
- a macro.
- * stw.h (struct _ffestw_): New variable for IFTHEN.
- (ffestw_ifthen_fake_else, ffestw_set_ifthen_fake_else): New
- accessor macros.
- * symbol.c, symbol.h: Support new ASSIGN'ed-to info.
-
- * com.c: Clean up commentary per GNU coding standards.
-
- * bld.h (ffebld_size, ffebld_size_known): Canonize.
-
- * version.c: Bump version.
-
-Sun Apr 11 21:33:33 1999 Mumit Khan <khan@xraylith.wisc.edu>
-
- * g77spec.c (lang_specific_driver): Check whether MATH_LIBRARY is
- null to decide whether to use it.
-
-Wed Apr 7 09:47:09 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * ansify.c (die): Specify void argument.
-
- * intdoc.c (family_name, dumpgen, dumpspec, dumpimp,
- argument_info_ptr, argument_info_string, argument_name_ptr,
- argument_name_string, elaborate_if_complex,
- elaborate_if_maybe_complex, elaborate_if_real, print_type_string):
- Const-ify a char*.
- (main): Mark parameter `argv' with ATTRIBUTE_UNUSED.
- (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, cc_pair, descriptions, summaries): Const-ify a char*.
-
-Mon Apr 5 11:57:54 1999 Donn Terry (donn@interix.com)
-
- * Make-lang.in (HOST_CFLAGS): compute dynamically.
-
-Mon Apr 5 02:11:23 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix bugs exposed by configuring with --enable-checking:
- * com.c (ffecom_do_entry_, ffecom_expr_, ffecom_arg_ptr_to_expr,
- ffecom_list_expr, ffecom_list_ptr_to_expr, finish_function,
- pop_f_function_context, store_parm_decls, poplevel): Handle
- error_mark_node properly.
- * ste.c (ffeste_begin_iterdo_, ffeste_end_iterdo_): Ditto.
- * version.c: Bump version.
-
-Sat Apr 3 23:57:56 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Fix up docs for -fset-g77-defaults, and
- describe how internal consistency checking now happens.
- (Should have been done for EGCS version 1.1.)
-
-Sat Apr 3 23:29:33 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, g77.texi, lang-options.h, news.texi, top.c:
- Make -fno-emulate-complex the default, as COMPLEX support
- in the back end is now believed to be working.
-
- * version.c: Bump version.
-
-Fri Apr 2 13:33:16 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: -malign-double now works.
- Give URL for alignment-testing package.
- * news.texi: -malign-double now works.
-
-Fri Apr 2 12:49:12 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Funding GNU Fortran): Dude's got a web page.
- * root.texi: Ditto.
-
-Tue Mar 30 12:04:11 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * sta.c (ffesta_ffebad_1sp, ffesta_ffebad_1st, ffesta_ffebad_2st):
- Const-ify a char*.
-
- * sta.h (ffesta_ffebad_1sp, ffesta_ffebad_1st, ffesta_ffebad_2st):
- Likewise.
-
- * stb.c (ffestb_local_u_): Likewise.
- (ffestb_do, ffestb_dowhile, ffestb_else, ffestb_elsexyz,
- ffestb_else3_, ffestb_endxyz, ffestb_goto, ffestb_let,
- ffestb_type, ffestb_type1_, ffestb_varlist, ffestb_R423B,
- ffestb_R522, ffestb_R528, ffestb_R542, ffestb_R834, ffestb_R835,
- ffestb_R838, ffestb_R841, ffestb_R1102, ffestb_blockdata,
- ffestb_R1212, ffestb_R1228, ffestb_V009, ffestb_module,
- ffestb_R809, ffestb_R810, ffestb_R10014_, ffestb_R10015_,
- ffestb_R10018_, ffestb_R1107, ffestb_R1202, ffestb_R12026_,
- ffestb_S3P4, ffestb_V012, ffestb_V014, ffestb_V025, ffestb_V0255_,
- ffestb_V020, ffestb_dimlist, ffestb_dummy, ffestb_R524,
- ffestb_R547, ffestb_decl_chartype, ffestb_decl_dbltype,
- ffestb_decl_gentype, ffestb_decl_recursive, ffestb_decl_entsp_2_,
- ffestb_decl_func_, ffestb_V003, ffestb_V016, ffestb_V027,
- ffestb_decl_R539): Likewise.
-
- * stb.h (_ffestb_args_): Likewise.
-
- * stc.c (ffestc_subr_binsrch_, ffestc_subr_is_present_,
- ffestc_subr_speccmp_, ffestc_R904, ffestc_R907): Likewise.
-
- * std.c (ffestd_R1001dump_1005_1_, ffestd_R1001dump_1005_2_,
- ffestd_R1001dump_1005_3_, ffestd_R1001dump_1005_4_,
- ffestd_R1001dump_1005_5_, ffestd_R1001dump_1010_1_,
- ffestd_R1001dump_1010_2_, ffestd_R1001dump_1010_3_,
- ffestd_R1001dump_1010_4_, ffestd_R1001dump_1010_5_): Likewise.
-
- * ste.c (ffeste_begin_iterdo_, ffeste_subr_file_): Likewise.
-
- * sts.c (ffests_printf_1D, ffests_printf_1U, ffests_printf_1s,
- ffests_printf_2Us, ffests_puts, ffests_puttext): Likewise.
-
- * sts.h (ffests_printf_1D, ffests_printf_1U, ffests_printf_1s,
- ffests_printf_2Us, ffests_puts, ffests_puttext): Likewise.
-
- * stt.c (ffestt_exprlist_drive, ffestt_implist_drive,
- ffestt_tokenlist_drive): Add prototype arguments.
-
- * stt.h (ffestt_exprlist_drive, ffestt_implist_drive,
- ffestt_tokenlist_drive): Likewise.
-
- * stu.c (ffestu_dummies_transition_): Likewise.
- (ffestu_sym_end_transition): Const-ify a char*.
-
- * stw.c (ffestw_display_state, ffestw_new, ffestw_pop): Add
- prototype arguments.
-
- * stw.h (ffestw_display_state, ffestw_new, ffestw_pop): Likewise.
-
- * version.c (ffe_version_string): Const-ify a char*.
-
- * version.h (ffe_version_string): Likewise.
-
-Sat Mar 27 13:00:43 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (_ffebad_message_, ffebad_string_, ffebad_message_,
- ffebad_bufputs_, ffebad_bufputs_, ffebad_start_, ffebad_string,
- ffebad_finish): Const-ify a char*.
-
- * bld.c (ffebld_op_string_, ffebld_op_string): Likewise.
-
- * bld.h (ffebld_op_string): Likewise.
-
- * com.c (ffecom_arglist_expr_, ffecom_build_f2c_string_,
- ffecom_debug_kludge_, ffecom_f2c_make_type_,
- ffecom_get_appended_identifier_, ffecom_get_identifier_,
- ffecom_gfrt_args_): Likewise.
- (ffecom_convert_narrow_, ffecom_convert_widen_): Add prototype.
- (builtin_function, ffecom_gfrt_name_, ffecom_gfrt_argstring_,
- ffecom_arglist_expr_, ffecom_build_f2c_string_,
- ffecom_debug_kludge_, ffecom_f2c_make_type_,
- ffecom_get_appended_identifier_, ffecom_get_external_identifier_,
- ffecom_get_identifier_, ffecom_decl_field,
- ffecom_get_invented_identifier, lang_print_error_function,
- skip_redundant_dir_prefix, read_name_map, print_containing_files):
- Const-ify a char*.
- (savestring): Remove, use `xstrdup' instead.
-
- * com.h (ffecom_decl_field, ffecom_get_invented_identifier):
- Const-ify a char*.
-
- * data.c (ffebld, ffedata_gather_): Make explicitly static.
-
- * expr.c (ffeexpr_isdigits_, ffeexpr_percent_,
- ffeexpr_reduced_concatenate_, ffeexpr_nil_real_,
- ffeexpr_nil_number_, ffeexpr_nil_number_period_,
- ffeexpr_nil_number_real_, ffeexpr_token_real_,
- ffeexpr_token_number_, ffeexpr_token_number_period_,
- ffeexpr_token_number_real_): Const-ify a char*.
-
- * fini.c (xspaces): Likewise.
-
- * global.c (ffeglobal_type_string_): Likewise.
- (ffeglobal_drive): Protoize.
- (ffeglobal_proc_def_arg): Const-ify a char*.
-
- * global.h (ffeglobal_drive): Protoize.
- (ffeglobal_proc_def_arg): Const-ify a char*.
-
- * implic.c (ffeimplic_none, ffeimplic_peek_symbol_type):
- Likewise.
-
- * implic.h (ffeimplic_peek_symbol_type): Likewise.
-
- * info.c (ffeinfo_basictype_string_, ffeinfo_kind_message_,
- ffeinfo_kind_string_, ffeinfo_kindtype_string_,
- ffeinfo_where_string_, ffeinfo_basictype_string,
- ffeinfo_kind_message, ffeinfo_kind_string,
- ffeinfo_kindtype_string, ffeinfo_where_string): Likewise.
-
- * info.h (ffeinfo_basictype_string, ffeinfo_kind_message,
- ffeinfo_kind_string, ffeinfo_kindtype_string,
- ffeinfo_where_string): Likewise.
-
- * intrin.c (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, ffeintrin_check_, ffeintrin_cmp_name_,
- ffeintrin_fulfill_specific, ffeintrin_init_0,
- ffeintrin_is_actualarg, ffeintrin_is_intrinsic,
- ffeintrin_name_generic, ffeintrin_name_implementation,
- ffeintrin_name_specific): Likewise.
-
- * intrin.h (ffeintrin_is_intrinsic, ffeintrin_name_generic,
- ffeintrin_name_implementation, ffeintrin_name_specific): Likewise.
-
- * lex.c (ffelex_type_string_, ffelex_token_new_character,
- ffelex_token_new_name, ffelex_token_new_names,
- ffelex_token_new_number): Likewise.
-
- * lex.h (ffelex_token_new_character, ffelex_token_new_name,
- ffelex_token_new_names, ffelex_token_new_number): Likewise.
-
- * malloc.c (malloc_types_, malloc_pool_new, malloc_new_inpool_,
- malloc_new_zinpool_): Likewise.
-
- * malloc.h (malloc_new_inpool_, malloc_new_zinpool_,
- malloc_pool_new): Likewise.
-
- * name.c (ffename_space_drive_global, ffename_space_drive_symbol):
- Protoize.
-
- * name.h (ffename_space_drive_global, ffename_space_drive_symbol):
- Likewise.
-
- * symbol.c (ffesymbol_state_name_, ffesymbol_attr_name_,
- ffesymbol_attrs_string): Const-ify a char*.
- (ffesymbol_drive, ffesymbol_drive_sfnames): Protoize.
- (ffesymbol_state_string): Const-ify a char*.
-
- * symbol.h (ffesymbol_attrs_string): Likewise.
- (ffesymbol_drive, ffesymbol_drive_sfnames): Protoize.
- (ffesymbol_state_string): Const-ify a char*.
-
- * target.c (ffetarget_layout): Likewise.
-
- * target.h (ffetarget_layout): Likewise.
-
-1999-03-25 Zack Weinberg <zack@rabi.columbia.edu>
-
- * Make-lang.in: Remove all references to g77.o/g77.c.
- Link g77 from gcc.o.
-
-1999-03-21 Manfred Hollstein <manfred@s-direktnet.de>
-
- * Makefile.in (g77$(exeext)): Depend on intl.o. Link in intl.o.
-
-Wed Mar 17 11:39:44 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Editorial fix.
-
-Mon Mar 15 17:12:07 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, g77.texi, news.texi: Editorial fixes.
-
-Sat Mar 13 17:51:55 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix 19990313-0.f, 19990313-1.f, 19990313-2.f, 19990313-3.f:
- * bad.def (FFEBAD_NOCANDO): New error code for internal use only.
- * expr.c (ffeexpr_collapse_convert): If FFEBAD_NOCANDO returned
- by convertor, just return original expr.
- * target.h: Return FFEBAD_NOCANDO for (usually) 64-bit
- conversions that aren't yet working properly.
- * news.texi: Explain.
-
- * version.c: Bump version.
-
-Sat Mar 13 14:26:55 1999 Craig Burley <craig@jcb-sc.com>
-
- * RELEASE-PREP: New file, lists things to do for a release.
-
- * Make-lang.in, bugs.texi, bugs0.texi, g77.texi, g77install.texi,
- install0.texi, news.texi, news0.texi: Accommodate new doc
- architecture.
- Consolidate news items. Don't describe old news items in
- various generated docs.
- Don't describe FSF-g77 installation stuff in various EGCS-g77
- generated docs.
- Move description of AUTOMATIC to more suitable location.
- * root.texi: New file for new doc architecture.
-
-Thu Mar 11 17:32:55 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Add AUTOMATIC to list of unsupported extensions.
-
-Sat Mar 6 02:28:35 1999 Craig Burley <craig@jcb-sc.com>
-
- Warn about non-Y2K-compliant intrinsics:
- * bad.def (FFEBAD_INTRINSIC_Y2KBAD): New diagnostic.
- * intrin.def (FFEINTRIN_impDATE, FFEINTRIN_impIDATE_vxt):
- Use new DEFIMPY macro to flag these as non-Y2K-compliant.
- * intdoc.c (DEFIMPY): Support new Y2K macro.
- * intrin.h (DEFIMPY): Ditto.
- * intrin.c (DEFIMPY): Ditto.
- (ffeintrin_fulfill_generic, ffeintrin_fulfill_specific):
- Warn about invocation of non-Y2K-compliant intrinsic.
- * com-rt.def (FFECOM_gfrtDATE, FFECOM_gfrtVXTIDATE):
- Rename external procedure names, to keep previously-
- compiled (sans-new-warnings) code from linking to
- new library.
- * g77.texi: Document all this stuff.
- * news.texi: Spread the joy.
- * version.c: Bump version.
-
-Fri Mar 5 13:22:44 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Relocate IDATE (VXT) fix: we put it in 1.1.2
- so describe it there, instead of under 1.2.
-
-Wed Mar 3 00:57:56 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: IDATE (VXT) fixed to return year as 0..99.
-
-Wed Mar 3 00:43:49 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Add remaining changes pending from Dave Love.
-
-Wed Mar 3 00:38:42 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Conditionalize cross-references
- on non-html processing, providing temporary HTML "links".
-
- * g77.texi: Fix up a reference.
-
-Wed Mar 3 00:12:31 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi, bugs.texi: Delete fixed bugs, make one
- of them into the appropriate news item.
-
-Wed Mar 3 00:05:52 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Copy over 1.1.2 news.
-
-1999-03-02 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Bug Reporting): Clarify whether to use -E.
- Clarify other instructions.
-
-1999-02-27 Craig Burley <craig@jcb-sc.com>
-
- * lang-specs.h: Fix specs to pass `-ax' as well as `-a' option.
-
-1999-02-26 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (STAT_func, STAT_subr,
- FSTAT_func, FSTAT_subr, LSTAT_func, LSTAT_subr):
- Properly order array elements. Specify N/A return values.
-
-1999-02-26 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (DATE_AND_TIME): Explain that VALUES(7) holds
- seconds, and VALUES(8), therefore, milliseconds.
-
-1999-02-26 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Clarify IOSTAT= fix.
-
-1999-02-25 Richard Henderson <rth@cygnus.com>
-
- * lang-specs.h: Define __FAST_MATH__ when appropriate.
-
-1999-02-25 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Clarify/index lack of run-time allocation for
- concatenation.
-
-1999-02-25 Andreas Jaeger <aj@arthur.rhein-neckar.de>
-
- * f/intdoc.in: Add missing `,' after cross references.
-
-1999-02-20 Craig Burley <craig@jcb-sc.com>
-
- * Make-lang.in (f77.install-common, f77.install-info,
- f77.install-man, f77.uninstall): Use `$(prefix)/lang-f77'
- instead of `lang-f77' for flag file, to be sure of a
- writable directory, and remove the flag file after each
- operation to keep things clean.
-
-1999-02-20 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Properly attribute Priest document; clarify
- that it is in the .ps version of the Goldberg document.
-
-1999-02-19 Craig Burley <craig@jcb-sc.com>
-
- * bugs0.texi, bugs.texi, install0.texi, g77install.texi,
- news0.texi, news.texi: Update copyright dates.
- Clarify which files are source, which are derived,
- and remind maintainers where copyright dates are sourced.
- * BUGS, INSTALL, NEWS: Regenerated.
-
-1999-02-19 Craig Burley <craig@jcb-sc.com>
-
- * global.c (ffeglobal_ref_progunit_): Warn about a function
- definition that disagrees with the type of a previous reference.
- Improve commentary. Fix a couple of minor bugs. Clean up
- some code.
- * news.texi: Spread the joy.
-
-1999-02-18 Craig Burley <craig@jcb-sc.com>
-
- * expr.c (ffeexpr_finished_): Disallow non-default INTEGER
- as argument for FILEINT and FILEASSOC as lhs.
- * news.texi: Document fix.
- * version.c: Bump.
-
-1999-02-18 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Clarify -fno-globals vs. -Wno-globals.
-
-1999-02-18 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (LOG10): Fix typo.
-
-1999-02-17 Ulrich Drepper <drepper@cygnus.com>
-
- * intdoc.in: Fix typo.
-
-1999-02-17 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi, intdoc.in: Document Y2K and some other known
- limitations.
- * intrin.def (DTIME, FDATE): Fix capitalization of
- case-sensitive forms of these intrinsics' names.
-
-1999-02-17 Dave Love <fx@gnu.org>
-
- * intdoc.in: Say `common' logarithm for log10.
-
-1999-02-16 Ulrich Drepper <drepper@cygnus.com>
-
- * g77.texi: Add missing @ in email addresses.
-
-1999-02-15 Craig Burley <craig@jcb-sc.com>
-
- * *.*: Delete my (old) email address in most places, change it
- in a few.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Bump.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Bump for 1998-10-02 change (forgot to do this
- before).
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * lang-specs.h, g77.1, g77.texi, news.texi: Recognize `.FOR'
- and `.FPP' as well as `.for' and `.fpp'.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (LOG10): Fix description.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Mention fix for SIGNAL invocation circa egcs-1.1.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi, g77install.texi, bugs.texi, g77install.texi: Clean
- up and improve indexing, and some other areas of docs.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (MCLOCK8, TIME8): Warn about lower range on
- 32-bit systems.
-
-Sat Feb 6 18:02:17 1999 Jeffrey A Law (law@cygnus.com)
-
- * g77.texi: Update email addresses.
-
-Wed Feb 3 22:50:17 1999 Marc Espie <Marc.Espie@liafa.jussieu.fr>
-
- * Make-lang.in (g77$(exeext)): Get choose-temp.o, pexecute.o and
- mkstemp.o from libiberty.
-
-1999-02-01 Zack Weinberg <zack@rabi.columbia.edu>
-
- * top.c: Don't define ffe_is_ident_. Don't process
- -f(no-)ident here.
- * top.h: Remove declaration of ffe_is_ident_ and macros
- ffe_is_ident() and ffe_set_is_ident().
- * lex.c: Use flag_no_ident instead of ffe_is_ident().
-
-Sun Jan 31 20:34:29 1999 Zack Weinberg <zack@rabi.columbia.edu>
-
- * lang-specs.h: Map -Qn to -fno-ident.
-
-Tue Jan 5 22:12:41 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (g77.o): Depend on prefix.h.
-
-Fri Nov 27 13:10:32 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * fini.c: Rename variable `spaces' to `xspaces' to avoid
- conflicting with function `spaces' from libiberty.
-
- * g77spec.c: Don't prototype libiberty functions.
- * malloc.c: Likewise.
-
-1998-11-20 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Assorted minor changes.
-
-1998-11-19 Dave Love <d.love@dl.ac.uk>
-
- * bugs.texi: Formatting changes from Craig.
-
- * intdoc.in: Terminate some @xrefs with `,'.
-
-1998-11-19 Manfred Hollstein <manfred@s-direktnet.de>
-
- * Make-lang.in (mandir): Replace all uses of $(mandir) by $(man1dir).
-
-Mon Nov 9 23:15:39 1998 Jeffrey A Law (law@cygnus.com)
-
- * g77.texi, news.texi: Updates from Craig.
-
-Sun Nov 8 17:47:56 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Makefile.in (INCLUDES): Add "-I$(srcdir)/../../include".
-
-Sat Nov 7 15:58:54 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * g77spec.c: Don't include gansidecl.h.
- * output.j: Likewise.
-
-1998-11-04 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Small formatting/indexing fixes.
-
-Mon Oct 12 20:41:59 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Change type of variable `c' to unsigned
- char, change type of variable `s' to unsigned char *.
-
- * com.c (ffecom_symbol_null_): Add missing initializers.
-
- * fini.c (MAXNAMELEN): Undef it before defining.
-
- * implic.c (ffeimplic_lookup_): Change type of parameter `c' to
- unsigned char.
-
- * intrin.c (ffeintrin_init_0): Cast the argument of ctype macros
- to (unsigned char).
-
- * lex.c (ffelex_splice_tokens): Change type of variable `p' to
- unsigned char *.
- (ffelex_token_name_from_names): Cast the argument of
- `ffelex_is_firstnamechar' to (unsigned char).
- (ffelex_token_names_from_names): Likewise.
- (ffelex_token_new_name): Likewise.
- (ffelex_token_new_names): Likewise.
-
- * malloc.c (malloc_root_): Add missing initializer.
-
- * stb.c (ffestb_do): Change type of variable `p' to unsigned char *.
- (ffestb_else) Likewise.
- (ffestb_else3_) Likewise.
- (ffestb_endxyz) Likewise.
- (ffestb_goto) Likewise.
- (ffestb_let) Likewise.
- (ffestb_varlist) Likewise.
- (ffestb_R522) Likewise.
- (ffestb_R528) Likewise.
- (ffestb_R834) Likewise.
- (ffestb_R835) Likewise.
- (ffestb_R838) Likewise.
- (ffestb_R1102) Likewise.
- (ffestb_blockdata) Likewise.
- (ffestb_R1212) Likewise.
- (ffestb_R810) Likewise.
- (ffestb_R10014_): Cast the argument of `ffelex_is_firstnamechar'
- to (unsigned char).
- (ffestb_V014): Change type of variable `p' to unsigned char *.
- (ffestb_dummy) Likewise.
- (ffestb_R524) Likewise.
- (ffestb_R547) Likewise.
- (ffestb_decl_chartype) Likewise.
- (ffestb_decl_dbltype) Likewise.
- (ffestb_decl_gentype) Likewise.
- (ffestb_decl_entsp_2_) Likewise.
- (ffestb_V027) Likewise.
- (ffestb_decl_R539) Likewise.
-
- * top.c (ffe_decode_option): Mark parameter `argc' with
- ATTRIBUTE_UNUSED.
-
- * where.c (ffewhere_unknown_line_): Add missing initializers.
-
-1998-10-02 Dave Love <d.love@dl.ac.uk>
-
- * com.c (ffecom_expr_intrinsic_): Fix return type for RAND.
-
-Thu Oct 1 10:43:45 1998 Nick Clifton <nickc@cygnus.com>
-
- * lex.c: Replace occurances of HANDLE_SYSV_PRAGMA with
- HANDLE_GENERIC_PRAGMAS.
-
-Mon Sep 28 04:22:00 1998 Jeffrey A Law (law@cygnus.com)
-
- * news.texi: Update from Craig.
-
-1998-09-23 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Additions about `/*', trailing comments and cpp.
-
-1998-09-18 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Various additions and some small fixes.
-
-Thu Sep 10 14:55:44 1998 Kamil Iskra <iskra@student.uci.agh.edu.pl>
-
- * Make-lang.in (f77.install-common): Add missing "else true;".
-
-1998-09-07 Dave Love <d.love@dl.ac.uk>
-
- * ChangeLog.egcs: Deleted. Entries merged here.
-
-1998-09-05 Dave Love <d.love@dl.ac.uk>
-
- * Makefile.in (LDFLAGS): Set from BOOT_LDFLAGS.
- (F771_LDFLAGS): Variable dispensed with.
-
-Fri Sep 4 19:53:34 1998 Craig Burley <burley@gnu.org>
-
- * intdoc.in: Minor editorial tweaks.
-
-Fri Sep 4 18:35:52 1998 Craig Burley <burley@gnu.org>
-
- * lang-options.h: Convert to wrap option and doc string
- in a new macro invocation, FTNOPT, so the nearly identical
- list can be used in FSF-g77.
-
-Fri Sep 4 18:35:52 1998 Craig Burley <burley@gnu.org>
-
- * Makefile.in (fini.o): Don't define USE_HCONFIG here.
- * fini.c: Define USE_HCONFIG here instead, so deps-kinda
- picks up correct dependency.
-
- * Makefile.in (proj-h.o): Fix dependencies list.
-
-Wed Sep 02 09:25:29 1998 Nick Clifton <nickc@cygnus.com>
-
- * lex.c (ffe_lex_hash): Change how HANDLE_PRAGMA and
- HANDLE_SYSV_PRAGMA would be called if they pragma parsing was
- enabled in this code.
- Generate warning messages if unknown pragmas are encountered.
- (pragma_getc): New function: retrieves characters from the
- input stream. Defined when HANDLE_PRAGMA is defined.
- (pragma_ungetc): New function: replaces characters back into the
- input stream. Defined when HANDLE_PRAGMA is defined.
-
-Tue Sep 1 10:00:21 1998 Craig Burley <burley@gnu.org>
-
- * bugs.texi, g77.1, g77.texi, intdoc.in, news.texi: Doc updates
- from Craig.
-
-1998-08-23 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Increment `version-g77' and fix a few typos.
-
-Tue Aug 18 21:41:31 1998 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in: Add several "else true" clauses to deal with lame
- systems.
-
-Tue Aug 11 08:12:14 1998 H.J. Lu (hjl@gnu.org)
-
- * Make-lang.in (g77.o): Touch lang-f77 before checking it.
-
-1998-08-09 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (f/g77.dvi): Replace non-working use of texi2dvi
- with explicit use of tex.
- (f77.mostlyclean): Remove TeX index files.
-
- * g77install.texi (Prerequisites): Kluge round TeX lossage with
- hyphen in @value in @code.
-
-Tue Aug 4 16:59:39 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_convert_narrow_, ffecom_convert_widen_):
- Allow conversion from pointer to same-sized integer,
- to fix invoking SIGNAL as a function.
-
-1998-07-26 Dave Love <d.love@dl.ac.uk>
-
- * BUGS, INSTALL, NEWS: Rebuilt.
-
-Sat Jul 25 17:23:55 1998 Craig Burley <burley@gnu.org>
-
- Fix 980615-0.f:
- * stc.c (ffestc_R1229_start): Set info to ANY as well.
-
-Tue Jul 21 04:33:37 1998 Craig Burley <burley@gnu.org>
-
- * g77spec.c (lang_specific_driver): Return unmolested
- command line when --help seen.
- Comment out code that printed g77-specific --help info.
-
-Sat Jul 18 19:16:48 1998 Craig Burley <burley@gnu.org>
-
- * lang-options.h: Fix up doc strings.
- Remove the unimplemented -fdcp-intrinsics-* options.
-
- * str-1t.fin: Change mixed-case spelling of `GoTo' from
- `Goto'.
-
-Thu Jul 16 13:26:36 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_finish_symbol_transform_): Revert change
- of 1998-05-23, as it was too aggressive, in that it
- prevented transformation of (used) functions before
- primary code generation.
-
-1998-07-15 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.texi: Regenerated.
-
-Mon Jul 13 18:45:06 1998 Craig Burley <burley@gnu.org>
-
- * Make-lang.in (f77.rebuilt): Fix to depend on
- build-dir-based, not source-based, g77.info.
-
- * g77.texi: Merge docs with 0.5.24.
- * g77install.texi: Ditto.
-
-Mon Jul 13 18:02:29 1998 Craig Burley <burley@gnu.org>
-
- Cleanups vis-a-vis g77-0.5.24:
- * g77spec.c (lang_specific_driver): Tabify source.
- * top.c (ffe_decode_option): Use fixed macro to set
- internal-checking flag.
- * top.h (ffe_set_is_do_internal_checks): Fix macro.
-
-Mon Jul 13 17:33:44 1998 Craig Burley <burley@gnu.org>
-
- Cleanups vis-a-vis system.h cutover and g77-0.5.24:
- * Makefile.in (fini.o): Define USE_HCONFIG macro
- so source code doesn't have to.
- * fini.c: Don't define USE_HCONFIG here, since
- source code usually shouldn't care about this.
- * ansify.c: Include stddef.h only if we have it.
- * intdoc.c: Ditto.
- * proj.h: Ditto.
-
-Mon Jul 13 17:30:29 1998 Nick Clifton <nickc@cygnus.com>
-
- * lang-options.h: Format changed to work with --help support added
- to gcc/toplev.c
-
-Mon Jul 13 11:54:03 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_push_tempvar): Replace kludge that
- munged back-end globals directly with proper calls
- to push_topmost_sequence and pop_topmost_sequence.
-
-1998-07-12 Dave Love <d.love@dl.ac.uk>
-
- * version.c: Bump version.
-
-Sat Jul 11 19:24:32 1998 Craig Burley <burley@gnu.org>
-
- Fix 980616-0.f:
- * equiv.c (ffeequiv_offset_): Don't crash on various
- possible ANY operands.
-
-Sat Jul 11 18:24:37 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_expr_) [FFEBLD_opCONTER]: Die if padding
- for constant is nonzero.
-
- * com.c (__eprintf): Delete this function, it is obsolete.
-
-1998-07-09 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.in (HOSTNM_func, HOSTNM_subr): Update last change.
-
-Thu Jul 9 00:45:59 1998 Craig Burley <burley@gnu.org>
-
- Fix debugging of CHARACTER*(*), etc., which requires
- emitting debug info on types like `ftnlen':
- * com.c (ffecom_start_progunit_): Don't bother
- resetting "invented" flag for identifier.
- (ffecom_transform_equiv_): Don't bother zeroing
- "ignored" flag for decl.
- (pushdecl): No longer set "ignored", "used", or
- "suppressed debug" flags for decls having "invented"
- identifiers.
-
-1998-07-06 Mike Stump <mrs@wrs.com>
-
- * Make-lang.in (f77.stage?): Use mv -f instead of just mv so that
- we can move g77.c.
-
-1998-07-06 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.in (HOSTNM_func, HOSTNM_subr): Note possible need for
- -lsocket.
-
-1998-07-05 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.in: Add entry for DATE_AND_TIME.
-
- * intrin.def: Add implementation for DATE_AND_TIME. Make second
- and third args of SYSTEM_CLOCK optional.
-
- * com.c (ffecom_expr_intrinsic_): New case for DATE_AND_TIME.
-
- * com-rt.def (FFECOM_gfrtSYSTEM_CLOCK): Call G77_system_clock_0,
- not system_clock_.
- (FFECOM_gfrtDATE_AND_TIME): New DEFGFRT.
-
-Wed Jul 1 11:19:13 1998 Craig Burley <burley@gnu.org>
-
- Fix 980701-1.f (which was producing "unaligned trap"
- on an Alpha running GNU/Linux, as predicted):
- * equiv.c (ffeequiv_layout_local_): Don't bother
- coping with pre-padding of entire area while building
- it; do that instead after the building is done, and
- do it by modifying only the modulo field. This covers
- the case of alignment stringency being increased without
- lowering the starting offset, unlike the previous changes,
- and even more elegantly than those.
-
- * target.c (ffetarget_align): Make sure alignments
- are nonzero, just in case.
-
-See ChangeLog.0 for earlier changes.
-
-Local Variables:
-add-log-time-format: current-time-string
-End:
-2003-01-01 Andreas Jaeger <aj@suse.de>
-
- * f/Make-lang.in ($(srcdir)/f/BUGS): Add include path for
- gcc-common.texi.
- ($(srcdir)/f/NEWS): Likewise.
-
-2002-12-28 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * g77.texi: Use @copying.
-
-2002-12-23 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * root.texi: Include gcc-common.texi.
- * bugs.texi, news.texi: Don't include root.texi as part of full
- manual.
- * g77.texi: Update for use of gcc-common.texi.
- * Make-lang.in ($(srcdir)/f/g77.info, f/g77.dvi): Depend on
- $(srcdir)/doc/include/gcc-common.texi.
-
-2002-12-19 Kazu Hirata <kazu@cs.umass.edu>
-
- * intdoc.in: Fix typos.
-
-2002-12-18 Kazu Hirata <kazu@cs.umass.edu>
-
- * g77.texi: Fix typos.
- * intdoc.texi: Likewise.
- * news.texi: Follow spelling conventions.
-
-Mon Dec 16 13:53:18 2002 Mark Mitchell <mark@codesourcery.com>
-
- * root.texi: Change version number to 3.4.
-
-2002-12-15 Zack Weinberg <zack@codesourcery.com>
-
- * target.h: Don't define HOST_WIDE_INT.
-
-2002-12-02 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * Make-lang.in, ansify.c, intdoc.c, proj.h: Replace hconfig.h with
- bconfig.h.
- * fini.c, proj.h: Replace USE_HCONFIG with USE_BCONFIG
-
-2002-11-30 Zack Weinberg <zack@codesourcery.com>
-
- * proj.h, ansify.c, g77spec.c, intdoc.c:
- Include coretypes.h and tm.h.
- * Make-lang.in: Update dependencies.
-
-2002-11-20 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * invoke.texi: Explain the purpose of -fmove-all-movables,
- -freduce-all-givs and -frerun-loop-opts better.
-
-2002-11-19 Nathanael Nerode <neroden@gcc.gnu.org>
-
- * Make-lang.in: Correct BUILD/HOST confusion.
-
-2002-11-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/8587
- * news.texi: Show PR fortran/8587 fixed.
-
-2002-11-19 Jason Thorpe <thorpej@wasabisystems.com>
-
- * g77spec.c (lang_specific_spec_functions): New.
-
-2002-11-02 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Correct documentation on generating C++ prototypes
- of Fortran routines with f2c.
- * news.texi: Document fixes in GCC-3.3, 3.2 and 3.1.
-
-2002-10-30 Roger Sayle <roger@eyesopen.com>
-
- * com.c (ffecom_subscript_check_): Cast the failure branch
- of the bounds check COND_EXPR to void, to indicate noreturn.
- (ffe_truthvalue_conversion): Only apply truth value conversion
- to the non-void branches of a COND_EXPR.
-
-2002-10-26 Andris Pavenis <pavenis@latnet.lv>
-
- * lang-specs.h: Fix ratfor specs.
-
-2002-10-15 Richard Henderson <rth@redhat.com>
-
- * target.h (ffetarget_print_real1, ffetarget_print_real2): Use
- real_to_decimal directly, and with the new arguments.
-
-2002-09-23 Zack Weinberg <zack@codesourcery.com>
-
- * Make-lang.in (g77spec.o): Don't depend on f/version.h.
- (f/parse.o): Depend on version.h not f/version.h.
- (g77version.o, f/version.o): Delete all references.
-
- * com.c (ffecom_init_0): Fix transposed array indices in bsearch test.
- * g77spec.c: Don't include f/version.h or refer to ffe_version_string.
- * parse.c: Use version_string, not ffe_version_string.
- * version.c, version.h: Delete files.
-
-2002-09-23 Kazu Hirata <kazu@cs.umass.edu>
-
- * ChangeLog: Follow spelling conventions.
- * ChangeLog.0: Likewise.
- * com.c: Likewise.
- * ffe.texi: Likewise.
- * g77.texi: Likewise.
- * intdoc.in: Likewise.
- * invoke.texi: Likewise.
- * news.texi: Likewise.
- * intdoc.texi: Regenerate.
-
-2002-09-16 Geoffrey Keating <geoffk@apple.com>
-
- * com.c (union lang_tree_node): Add chain_next option.
-
-2002-09-16 Richard Henderson <rth@redhat.com>
-
- * target.c (ffetarget_real1): Don't pass FFETARGET_ATOF_
- directly to ffetarget_make_real1.
- (ffetarget_real2): Similarly.
- * target.h (ffetarget_cvt_r1_to_rv_, ffetarget_cvt_rv_to_r2_,
- ffetarget_cvt_r2_to_rv_): Use new real.h interface and simplify.
-
-2002-09-15 Kazu Hirata <kazu@cs.umass.edu>
-
- * intdoc.texi: Regenerate.
-
-2002-09-15 Kazu Hirata <kazu@cs.umass.edu>
-
- * ChangeLog: Follow spelling conventions.
- * intdoc.in: Likewise.
-
-2002-09-09 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- Fix PR web/7596:
- * ffe.texi (Front End): Fix broken links.
- * bugs.texi (Known Bugs): Refer to gcc.gnu.org instead of
- www.gnu.org for onlinedocs.
- * news.texi (News): Ditto.
-
-2002-09-07 Jan Hubicka <jh@suse.cz>
-
- * com.c (ffe_type_for_mode): Handle long double.
-
-2002-09-04 Richard Henderson <rth@redhat.com>
-
- * target.h (ffetarget_print_real1, ffetarget_print_real2): Update
- call to REAL_VALUE_TO_DECIMAL.
-
-2002-08-31 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c: Don't set flag_finite_math_only by default.
- * invoke.texi: Reverse the documentation of option
- -ffinite-math-only to reflect the new default.
-
-2002-08-30 Hans-Peter Nilsson <hp@bitrange.com>
-
- * target.c (ffetarget_memcpy_): Don't test nonexistent
- HOST_BYTES_BIG_ENDIAN, HOST_BITS_BIG_ENDIAN. Check
- HOST_WORDS_BIG_ENDIAN against both WORDS_BIG_ENDIAN and
- BYTES_BIG_ENDIAN.
-
-2002-08-30 Alan Modra <amodra@bigpond.net.au>
-
- * target.h (FFETARGET_32bit_longs): Don't define for powerpc64 or
- mmix.
-
-2002-08-28 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * bugs.texi, news.texi: Update URLs for online news and bugs
- lists.
-
-2002-08-22 Hans-Peter Nilsson <hp@bitrange.com>
-
- * where.h (struct _ffewhere_file_): Mark GTY.
- (ffewhere_file_kill): Remove prototype.
- * where.c: Include ggc.h.
- (struct _ffewhere_ll_, struct _ffewhere_root_ll_): Mark GTY.
- (ffewhere_root_ll_): Ditto. Change type from struct
- _ffewhere_root_ll_ to struct _ffewhere_root_ll_*. All uses
- changed.
- (ffewhere_file_kill): Remove.
- (ffewhere_file_new): Use GC to allocate ffewhereFile objects.
- (ffewhere_file_set): Use GC to allocate ffewhereLL_ objects.
- (ffewhere_init_1): Use GC to allocate ffewhere_root_ll_ sentinel.
- Include gt-f-where.h.
- * lex.c (ffelex_current_wf_, ffelex_include_wherefile_): Mark GTY.
- Include gt-f-lex.h.
- * std.c (ffestd_S3P4): Don't call ffewhere_file_kill.
- * config-lang.in (gtfiles): Add f/where.h f/where.c and f/lex.c.
- * Make-lang.in (gt-f-lex.h gt-f-where.h): Add to dependents of
- s-gtype.
- (f/lex.o): Depend on gt-f-lex.h.
- (f/where.o): Depend on gt-f-where.h.
-
-Tue Aug 20 16:49:40 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * where.c (ffewhere_track): Remove impossible if-then clause.
-
-Thu Aug 8 10:06:14 2002 Nathan Sidwell <nathan@codesourcery.com>
-
- * f/Make-lang.in (f.mostlyclean): Remove coverage files.
-
-2002-08-06 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * g77.texi (Top): Rename Index to Keyword Index.
-
-2002-08-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * invoke.texi: Improve description of
- -fno-finite-math-only flag.
-
-Sun Aug 4 16:45:49 2002 Joseph S. Myers <jsm@polyomino.org.uk>
-
- * root.texi (version-gcc): Increase to 3.3.
-
-2002-07-30 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffe_init_options): Set
- flag_finite_math_only.
- * invoke.texi: Document -fno-finite-math-only.
-
-Mon Jul 29 22:05:35 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (read_name_map): Use concat in lieu of xmalloc/strcpy.
-
-2002-07-25 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document better handling of (no-)alias
- information of dummy arguments and induction variables
- on loop unrolling.
-
-2002-07-01 Roger Sayle <roger@eyesopen.com>
-
- * f/com.c (builtin_function): Accept additional parameter.
- (ffe_com_init_0): Pass an additional NULL_TREE argument to
- builtin_function.
-
-2002-06-28 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Mention 2 Gbyte limit on 32-bit targets
- for arrays explicitly in news on g77-3.1.
-
-Thu Jun 20 21:56:34 2002 Neil Booth <neil@daikokuya.co.uk>
-
- * lang-specs.h: Use cc1 for traditional preprocessing.
-
-2002-06-20 Andreas Jaeger <aj@suse.de>
-
- * com.c (ffecom_prepare_expr_,ffecom_expr_power_integer_):
- Remove #ifdefed HAHA sections.
-
-2002-06-20 Nathanael Nerode <neroden@twcny.rr.com>
-
- * com.c: Remove #ifdef HOHO sections.
-
-2002-06-17 Jason Thorpe <thorpej@wasabisystems.com>
-
- * bit.c: Don't include glimits.h.
- * target.c: Likewise.
- * where.h: Likewise.
-
-2002-06-12 Gabriel Dos Reis <gdr@codesourcery.com>
-
- * bad.c (ffebad_start_): Adjust calls to diagnostic_count_error.
-
-2002-06-04 Gabriel Dos Reis <gdr@codesourcery.com>
-
- * bad.c (ffebad_start_): Adjust call to count_error.
- * Make-lang.in (f/bad.o): Depend on diagnostic.h
- * bad.c: #include diagnostic.h
-
-2002-06-03 Geoffrey Keating <geoffk@redhat.com>
-
- * Make-lang.in (f/com.o): Depend on debug.h.
- * com.c: Include debug.h.
- (LANG_HOOKS_MARK_TREE): Delete.
- (struct lang_identifier): Use gengtype.
- (union lang_tree_node): New.
- (struct lang_decl): New dummy definition.
- (struct lang_type): New dummy definition.
- (ffe_mark_tree): Delete.
-
- * com.c (struct language_function): New dummy structure.
-
- * Make-lang.in: Add rules to generate gt-f-ste.h gtype-f.h; allow
- for filename changes.
- (com.o): Allow for filename changes; add gtype-f.h as dependency.
- (ste.o): Add gt-f-ste.h as dependency.
- * config-lang.in (gtfiles): Add com.h, ste.c.
- * com.c: Replace uses of ggc_add_* with GTY markers. Include
- gtype-f.h.
- (mark_binding_level): Delete.
- * com.h: Replace uses of ggc_add_* with GTY markers.
- * ste.c: Replace uses of ggc_add_* with GTY markers. Include
- gt-f-ste.h.
-
- * Make-lang.in (f/gt-com.h): Build using gengtype.
- (com.o): Depend on f/gt-com.h.
- * com.c: Rename struct binding_level to f_binding_level.
- (struct f_binding_level): Use gengtype.
- (struct tree_ggc_tracker): Use gengtype.
- (mark_tracker_head): Use gt_ggc_m_tree_ggc_tracker.
- (make_binding_level): Use GGC.
- (mark_binding_level): Use gt_ggc_m_f_binding_level.
- (ffecom_init_decl_processing): Change free_binding_level
- to a deletable root.
- * config-lang.in (gtfiles): Define.
- * where.c: Strings need no longer be allocated in GCable memory;
- remove my change of 30 Dec 1999.
-
-2002-05-31 Matthew Woodcraft <mattheww@chiark.greenend.org.uk>
-
- * lang-specs.h: Use cpp_debug_options.
-
-2002-05-28 Zack Weinberg <zack@codesourcery.com>
-
- * bld.c, com.c, expr.c, target.c: Include real.h.
- * Make-lang.in: Update dependency lists.
-
-2002-05-16 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * Make-lang.in: Allow for PWDCMD to override hardcoded pwd.
-
-2002-05-09 Hassan Aurag <aurag@cae.com>
-
- * expr.c (ffeexpr_reduced_ugly2log_): Allow logicals-as-integers
- under -fugly-logint as arguments of .and., .or., .xor.
-
-2002-05-07 Jan Hubicka <jh@suse.cz>
-
- * target.h (FFETARGET_32bit_longs): Undefine for x86-64.
-
-2002-04-29 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * invoke.texi: Use @gol at ends of lines inside @gccoptlist.
- * g77.texi: Update last update date.
-
-Thu Apr 25 07:44:44 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.h (ffe_parse_file): Update.
- * lex.c (ffe_parse_file): Update.
-
-2002-04-20 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi: Remove variable version-g77.
- * g77.texi: Remove the single use of that variable.
-
-Thu Apr 18 19:10:44 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (incomplete_type_error): Remove.
-
-Tue Apr 16 14:55:47 2002 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_expr_power_integer): Add has_scope argument to
- call to expand_start_stmt_expr.
-
-Mon Apr 15 10:59:14 2002 Mark Mitchell <mark@codesourcery.com>
-
- * g77.texi: Remove Chill reference.
-
-2002-04-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Deprecate frontend version number;
- update list of fixed bugs.
-
-2002-04-08 Hans-Peter Nilsson <hp@bitrange.com>
-
- * Make-lang.in (f/target.o): Depend on diagnostic.h.
- * target.c: Include diagnostic.h.
- (ffetarget_memcpy_): Call sorry if host and target endians are
- not matching.
-
-Thu Apr 4 23:29:48 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_TRUTHVALUE_CONVERSION): Redefine.
- (truthvalue_conversion): Rename. Update. Make static.
- (ffecom_truth_value): Update.
-
-Mon Apr 1 21:39:36 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_MARK_ADDRESSABLE): Redefine.
- (mark_addressable): Rename.
- (ffecom_arrayref_, ffecom_1): Update.
-
-Mon Apr 1 09:59:53 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_SIGNED_TYPE, LANG_HOOKS_UNSIGNED_TYPE,
- LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE): New.
- (unsigned_type, signed_type, signed_or_unsigned_type): Rename.
-
-Sun Mar 31 23:50:22 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (lang_print_error_function): Rename.
- (LANG_HOOKS_PRINT_ERROR_FUNCTION): Redefine.
- (ffe_init): Don't set hook.
-
-Fri Mar 29 21:59:15 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_TYPE_FOR_MODE, LANG_HOOKS_TYPE_FOR_SIZE):
- Redefine.
- (type_for_mode, type_for_size): Rename.
- (signed_or_unsigned_type, signed_type, truthvalue_conversion,
- unsigned_type): Use new hooks.
-
-Tue Mar 26 10:30:05 2002 Andrew Cagney <ac131313@redhat.com>
-
- * invoke.texi (Warning Options): Mention -Wswitch-enum.
- Fix PR c/5044.
-
-Tue Mar 26 07:30:51 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_MARK_TREE): Redefine.
- (lang_mark_tree): Rename ffe_mark_tree, make static.
-
-Mon Mar 25 19:27:11 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (maybe_build_cleanup): Remove.
-
-2002-03-23 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_check_size_overflow_): Add a test
- so that arrays too large for 32-bit byte-offset
- addressing get caught.
- * news.texi: Document the fixing of this problem.
-
-Sat Mar 23 11:18:17 2002 Andrew Cagney <ac131313@redhat.com>
-
- * invoke.texi (Warning Options): Mention -Wswitch-default.
-
-Thu Mar 21 18:55:41 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * cp-tree.h (pushdecl, pushlevel, poplevel, set_block,
- insert_block, getdecls, global_bindings_p): New.
-
-Wed Mar 20 08:03:42 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (lang_printable_name): Rename.
- (LANG_HOOKS_DECL_PRINTABLE_NAME): Redefine.
- (ffe_init): Don't use old hook.
-
-Sun Mar 17 18:50:15 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.h (ffe_parse_file): Prototype.
-
-Sun Mar 17 20:57:30 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (LANG_HOOKS_PARSE_FILE): Redefine.
- * com.h (ffe_parse_file): New.
- * parse.c (NAME_OF_STDIN): Remove.
- (yyparse): Rename ffe_parse_file.
-
-Tue Mar 12 20:23:18 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (tree_code_type, tree_code_length, tree_code_name):
- Define.
-
-Sun Mar 10 12:37:42 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * target.c (ffetarget_print_hex): Const-ify.
-
-2002-03-06 Phil Edwards <pme@gcc.gnu.org>
-
- * version.c: Fix misplaced leading blanks on first line.
-
-2002-03-03 Zack Weinberg <zack@codesourcery.com>
-
- * com.c, target.h: Remove all #ifndef REAL_ARITHMETIC
- blocks, make all #ifdef REAL_ARITHMETIC blocks unconditional.
- Delete some further #ifdef blocks predicated on REAL_ARITHMETIC.
-
-Thu Feb 28 07:53:46 2002 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (copy_lang_decl): Delete.
-
-2002-02-27 Zack Weinberg <zack@codesourcery.com>
-
- * com.c, lex.c, top.c: Delete traditional-mode-related code
- copied from the C front end but not used, or used only to
- permit the compiler to link.
-
-2002-02-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: List Problem Reports fixed in 3.1.
-
-2002-02-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * data.c (ffedata_eval_offset_): Only convert index,
- low and high bound in data statements to default integer
- if they are constants. Use a copy of the data structure.
-
-2002-02-09 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * data.c (ffedata_eval_offset_): Convert non-default integer
- constants to default integer kind if necessary.
-
-2002-02-09 Toon Moene <toon@moene.indiv.nlug.nl>
-
- * invoke.texi: Add a short debugging session
- as an example to the documentation of -g.
-
-2002-02-06 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/4730 fortran/5473
- * com.c (ffecom_expr_): Deal with %VAL constructs.
- * intrin.c (ffeintrin_check_): Handle 'N' constraints for intrinsics,
- to indicate "no larger than default kind" integers and logicals.
- * intrin.def: Use 'N' constraints in table of intrinsics.
- * intdoc.c: Document this constraint.
- * intdoc.texi: Regenerated.
-
-2002-02-04 Philipp Thomas <pthomas@suse.de>
-
- * implic.c lex.c stb.c ste.c stu.c: Update copyright dates.
-
-2002-02-04 Philipp Thomas <pthomas@suse.de>
-
- * bad.def com.c expr.c implic.c lex.c stb.c ste.c stu.c:
- Insert comments to mark messages as not being printf style
- where appropriate.
-
-2002-02-03 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * expr.c (ffeexpr_sym_impdoitem_): Allow other than
- default INTEGER implied-do loop counts.
-
-2002-02-01 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bad.def: Remove non-historical reference to version 0.6.
- * bugs.texi: Ditto.
- * com.c: Ditto.
- * ffe.texi: Ditto.
- * proj.h: Ditto.
- * g77.texi: Ditto.
-
-2002-01-31 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lang_specific_driver): Follow GNU Coding Standards
- for --version.
-
-2002-01-30 Richard Henderson <rth@redhat.com>
-
- * ste.c (ffeste_begin_iterdo_): Use expand_exit_loop_top_cond.
- (ffeste_R819B): Likewise.
-
-2002-01-30 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * intrin.c (upcasecmp_): New function.
- (ffeintrin_cmp_name_): Use it to correctly compare name
- and table entry for bsearch.
-
-2002-01-26 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * intrin.c (ffeintrin_cmp_name_): Correct comparison
- for intrinsics in intrinsic table (intrin.def).
-
-2002-01-22 Zack Weinberg <zack@codesourcery.com>
-
- * bad.c: Include intl.h.
- (FFEBAD_MSGS1, FFEBAD_MSGS2): Replace by FFEBAD_MSG, SHORT,
- LONG. Adjust definitions to work with exgettext.
- (ffebad_start_): Translate all error messages.
- (ffebad_finish): Mark constant strings for translation.
- * bad.h: Use FFEBAD_MSG. Adjust prototype of ffebad_start_
- and definitions of ffebad_start_msg, ffebad_start_msg_lex to
- work with exgettext.
- * bad.def: Use FFEBAD_MSG, SHORT, LONG throughout.
-
- * com.c: Include intl.h.
- (lang_print_error_function): Always use ffeinfo_kind_message
- to get the kind label for a non-nested construct. Translate
- it. Translate constant strings.
- * info.c (FFEINFO_KIND): Adjust definition to work with exgettext.
- * info-k.def: Block xgettext from slurping copyright notice
- into gcc.pot. Adjust strings for their sole use, in com.c.
-
- * Make-lang.in (f/bad.o, f/com.o): Depend on intl.h.
-
-2002-01-14 David Billinghurst <David.Billinghurst@riotinto.com>
-
- PR fortran/3807
- * f/intrin.c (ffeintrin_check_): Allow for case of intrinsic
- control string have COL-spec an integer > 0.
-
-2002-01-08 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lookup_option): Handle -fversion.
- (lang_specific_driver): Update copyright date in --version output.
-
-Mon Jan 7 00:03:42 2002 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * invoke.texi: Markup g77 as @command. Remove reference to
- http://gcc.gnu.org/thanks.html.
-
-Wed Jan 2 18:13:11 2002 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (clear_binding_level): Const-ify.
- (ffecom_arglist_expr_): Likewise.
- * info.c (ffeinfo_types_): Don't needlessly zero init.
- * lex.c (ffelex_hash_kludge): Const-ify.
-
-Sun Dec 23 10:45:09 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_gfrt_volatile_, ffecom_gfrt_complex_,
- ffecom_gfrt_const_, ffecom_gfrt_type_): Const-ify.
-
-Sat Dec 22 16:01:51 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bld.c (ffebld_arity_op_): Declare array size explicitly.
- * bld.h (ffebld_arity_op_): Likewise.
-
-2001-12-20 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * config-lang.in (diff_excludes): Remove.
-
-2001-12-17 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi, invoke.texi: Update links to GCC manual.
-
-Sun Dec 16 16:08:57 2001 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * news.texi: Fix spelling errors.
-
-Sun Dec 16 10:36:51 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (f/version.o): Depend on f/version.h.
- * version.c: Include ansidecl.h and f/version.h.
-
-Sun Dec 16 08:52:48 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * lex.c (ffelex_backslash_, ffelex_cfebackslash_): Use hex_value.
- * target.c (ffetarget_integerhex, ffetarget_typeless_hex): Use
- hex_p/hex_value.
-
-2001-12-14 Roger Sayle <roger@eyesopen.com>
-
- * com-rt.def: Use __builtin_sqrt instead of __builtin_fsqrt.
- * com.c (ffecom_init_0): Same, and fixed enumeration usage.
-
-2001-12-10 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Don't condition menus on @ifinfo.
-
-Wed Dec 5 06:49:21 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_1): Properly handle TREE_READONLY for INDIRECT_REF.
-
-Mon Dec 3 18:56:04 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c: Remove leading capital from diagnostic messages, as
- per GNU coding standards.
- * g77spec.c: Similarly.
- * lex.c: Similarly.
-
-2001-12-01 Zack Weinberg <zack@codesourcery.com>
-
- * f/fini.c: Use xmalloc.
-
-Fri Nov 30 20:54:02 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in: Delete references to proj.[co], proj-h.[co].
- * proj.c: Delete file.
-
-2001-11-29 Zack Weinberg <zack@codesourcery.com>
-
- * Make-lang.in (f/fini, f/intdoc): Depend on $(HOST_LIBDEPS)
- and link with $(HOST_LIBS), not safe-ctype.o.
-
-2001-11-29 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (f77.generated-manpages): New target.
- ($(srcdir)/f/g77.1): Don't check $(GENERATED_MANPAGES). Allow
- manpage generation to fail.
- (f77.info): Don't depend on $(srcdir)/f/g77.1.
- (f77.install-man): Depend on $(GENERATED_MANPAGES) rather than
- directly on $(srcdir)/g77.1.
-
-2001-11-24 Toon Moene <toon@moene.indiv.nluug.nl>
-
- PR fortran/3957
- * lang-specs.h: Correct !pipe conditional in tradcpp0 invocation.
-
-2001-11-21 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: egcs was not a `@command'.
- * invoke.texi: Ditto.
- * news.texi: Substitute `@command' for `@code'
- and `@option' for `@samp' where appropriate.
-
-2001-11-19 Loren J. Rittle <ljrittle@acm.org>
-
- * Make-lang.in: Complete ``Build g77.1 in $(srcdir)''.
-
-2001-11-19 Geoffrey Keating <geoffk@redhat.com>
-
- * g77spec.c (lang_specific_driver) [ENABLE_SHARED_LIBGCC]: Add
- libgcc_s.so if libf2c is used.
- * Make-lang.in (g77spec.o): Use DRIVER_DEFINES.
-
-2001-11-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * .cvsignore: Ignore g77.1
- * g77.texi: Substitute `@command' for `@code'
- where appropriate.
- * invoke.texi: Ditto.
-
-2001-11-18 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Remove all references to LANGUAGES
- and the stamp files that depend on its value.
-
-Sun Nov 18 11:13:04 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (finish_parse): Remove.
- (ffe_finish): Move body of finish_parse.
-
-Thu Nov 15 10:06:38 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (ffecom_init_decl_processing): Renamed from
- init_decl_processing.
- (init_parse): Move contents to ffe_init.
- (ffe_init): Update prototype.
-
-2001-11-14 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Update to use `@command', `@option.
- * invoke.texi: Ditto
-
-2001-11-14 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in: Change all uses of $(manext) to $(man1ext).
-
-2001-11-14 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.1: Remove from CVS.
- * Make-lang.in: Build g77.1 in $(srcdir).
- Add --section=1 to POD2MAN command line.
- * invoke.texi: Correct copyright years.
- Add more sections to man page. Add GFDL.
-
-Fri Nov 9 23:16:45 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (ffe_print_identifier): Rename.
- (LANG_HOOKS_PRINT_IDENTIFIER): Override.
- (lang_print_xnode, print_lang_decl, print_lang_statistics,
- print_lang_type, set_yydebug): Remove.
-
-2001-11-09 Zack Weinberg <zack@codesourcery.com>
-
- * g77spec.c (lang_specific_driver): Adjust behavior of -v and
- --version for consistency with other front ends. Remove large
- #if 0 block. Do not add libraries to argv if there are no
- input files.
- (add_version_magic): Delete all references and dependent code.
- * lang-options.h: Delete -fnull-version.
- * lang-specs.h: Delete f77-version spec.
-
- * lex.c: Delete logic conditional on ffe_is_null_version() and
- now-unused label.
- * top.c: Delete ffe_is_null_version_ variable.
- (ffe_decode_option): Delete -fnull-version case.
- * top.h: Delete declaration of ffe_is_null_version_ and
- ffe_is_null_version(), ffe_set_is_null_version() macros.
-
-Fri Nov 9 07:14:47 2001 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * com.c (language_string, lang_identify): Remove.
- (struct lang_hooks): Constify.
- (LANG_HOOKS_NAME): Override.
- (init_parse): Update.
-
-2001-11-08 Andreas Franck <afranck@gmx.de>
-
- * Make-lang.in (G77_INSTALL_NAME, G77_CROSS_NAME): Handle
- program_transform_name the way suggested by autoconf.
-
-2001-11-08 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Add rules for building g77.1.
- * invoke.texi: Add man page stuff. Move indexing
- from g77.texi to here.
- * g77.texi: Remove indexing specific to invoke.texi.
- * news.texi: Document that g77.1 is now a generated
- file.
-
-Tue Nov 6 21:17:47 2001 Neil Booth <neil@cat.daikokuya.demon.co.uk>
-
- * com.c: Include langhooks-def.h.
- * Make-lang.in: Update.
-
-2001-11-04 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Split off invoke.texi (preliminary to using it
- to generate a man page).
- * Make-lang.in: Reflect in build rules.
-
-Fri Nov 2 10:51:34 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_initialize_char_syntax_, U_CHAR, is_idchar,
- is_idstart, is_hor_space, is_space, SKIP_WHITE_SPACE,
- SKIP_ALL_WHITE_SPACE): Delete.
- (read_filename_string, read_name_map): Don't use is_space or
- is_hor_space.
-
-2001-10-29 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document new ability to compile programs with
- arrays larger than 512 Mbyte on 32-bit targets.
-
-2001-10-24 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_check_size_overflow_): Only check for TREE_OVERFLOW.
-
-Tue Oct 23 14:01:27 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (LANG_HOOKS_GET_ALIAS_SET): New macro.
- (lang_get_alias_set): Delete.
-
-2001-10-23 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi (Sending Patches): Remove.
-
-2001-10-22 Zack Weinberg <zack@codesourcery.com>
-
- * Make-lang.in (f/intdoc): Depend on safe-ctype.o.
-
-Sun Oct 21 17:28:17 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Use safe-ctype macros and/or fold extra
- calls into fewer ones.
- * implic.c (ffeimplic_lookup_): Likewise.
- * intdoc.c (dumpimp): Likewise.
- * intrin.c (ffeintrin_init_0): Likewise.
- * lex.c (ffelex_backslash_, ffelex_cfebackslash_, ffelex_hash_):
- Likewise.
- * lex.h (ffelex_is_firstnamechar): Likewise.
- * target.c (ffetarget_integerhex): Likewise.
-
-2001-10-21 Craig Prescott <prescott@phys.ufl.edu>
-
- * target.h (FFETARGET_32bit_longs): Don't define
- for 64-bit hppa.
-
-2001-10-17 Richard Henderson <rth@redhat.com>
-
- * std.c (ffestd_labeldef_format): Fix variable/stmt ordering.
- (ffestd_R737A): Likewise.
-
-2001-10-17 Richard Henderson <rth@redhat.com>
-
- * com.h: Remove FFECOM_targetCURRENT, FFECOM_ONEPASS, BUILT_FOR_270,
- BUILT_FOR_280, FFECOM_GCC_INCLUDE, all derivitive defines, and all
- related conditional compilation directives.
- * bad.c, bld.c, bld.h, com.c, equiv.c, equiv.h, global.h, intdoc.c,
- intrin.c, intrin.h, lex.c, parse.c, sta.c, std.c, ste.c, ste.h, stt.c,
- stt.h, stw.h, symbol.c, symbol.h, target.h, top.c: Likewise.
-
-2001-10-17 Richard Henderson <rth@redhat.com>
-
- * Make-lang.in (f/com.o): Depend on langhooks.h.
- * com.c: Include it.
- (LANG_HOOKS_INIT, LANG_HOOKS_FINISH): New.
- (LANG_HOOKS_INIT_OPTIONS, LANG_HOOKS_DECODE_OPTION): New.
- (lang_hooks): Use LANG_HOOKS_INITIALIZER.
-
-Sun Oct 7 12:27:54 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (_ffebad_message_, ffebad_messages_): Const-ify.
- * bld.c (ffebld_arity_op_): Likewise.
- * bld.h (ffebld_arity_op_): Likewise.
- * com.c (ffecom_init_0): Likewise.
- * intdoc.c (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, names, gens, imps, specs, cc_pair,
- cc_descriptions, cc_summaries): Likewise.
- * intrin.c (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, ffeintrin_names_, ffeintrin_gens_,
- ffeintrin_imps_, ffeintrin_specs_): Likewise.
-
-2001-10-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Document libf2c being built as a shared library.
- Use of array elements in bounds of adjustable arrays ditto.
-
-2001-10-03 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Remove reference to FORTRAN_INIT.
- * g77spec.c: Add reference to FORTRAN_INIT.
-
-2001-09-29 Juergen Pfeifer <juergen.pfeifer@gmx.net>
-
- Make libf2c a shared library.
-
- * Make-lang.in: Pass define of frtbegin.o to compilation of g77spec.c.
- * g77spec.c (lang_specific_driver): Treat linking in of frtbegin.o.
-
-2001-09-28 Robert Anderson <rwa@alumni.princeton.edu>
-
- * expr.c (ffeexpr_sym_rhs_dimlist_): Allow array elements
- as bounds of adjustable arrays.
-
-Thu Sep 20 15:05:20 JST 2001 George Helffrich <george@geo.titech.ac.jp>
-
- * com.c (ffecom_subscript_check_): Loosen subscript checking rules
- for character strings, to permit substring expressions like
- string(1:0).
- * news.texi: Document this as a new feature.
-
-Thu Sep 13 10:33:27 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Const-ification and/or static-ization.
- * intrin.c (ffeintrin_cmp_name_): Likewise.
- * stc.c (ffestc_R904): Likewise.
-
-Wed Sep 12 12:09:04 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bld.c (ffebld_op_string_): Const-ification.
- * com.c (ffecom_gfrt_name_, ffecom_gfrt_argstring_): Likewise.
- * fini.c (xspaces): Likewise.
- * global.c (ffeglobal_type_string_): Likewise.
- * info.c (ffeinfo_basictype_string_, ffeinfo_kind_message_,
- ffeinfo_kind_string_, ffeinfo_kindtype_string_,
- ffeinfo_where_string_): Likewise.
- * lex.c (ffelex_type_string_): Likewise.
- * malloc.c (malloc_types_): Likewise.
- * stc.c (ffestc_subr_binsrch_, ffestc_R904, ffestc_R904,
- ffestc_R907): Likewise.
- * symbol.c (ffesymbol_state_name_, ffesymbol_attr_name_):
- Likewise.
- * version.c (ffe_version_string): Likewise.
- * version.h (ffe_version_string): Likewise.
-
-2001-09-11 Richard Henderson <rth@redhat.com>
-
- * parse.c (finput): Mark extern.
-
-2001-09-11 Jakub Jelinek <jakub@redhat.com>
-
- * com.c (ffe_init_options): Default to -fmerge-all-constants
- if optimizing.
-
-2000-08-14 Ulrich Weigand <uweigand@de.ibm.com>
-
- * target.h (FFETARGET_32bit_longs): Don't define
- for 64-bit S/390.
-
-2001-07-20 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_expr_intrinsic_):
- case FFEINTRIN_impIBITS: Remove TREE_SHIFT_FULLWIDTH define.
- case FFEINTRIN_impISHFT: Ditto. Change LT_EXPR to NE_EXPR.
- case FFEINTRIN_impISHFTC: Ditto.
- case FFEINTRIN_impMVBITS: Ditto.
-
-2001-07-19 Jakub Jelinek <jakub@redhat.com>
-
- * top.c (ffe_decode_option): Disallow lang-independent processing
- for -ffixed-form.
-
-2001-07-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * f/com.c (ffecom_expr_intrinsic_): Deal (correctly) with
- {L|R}SHIFT_EXPR not working when shift > size of type.
-
-2001-07-17 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (lang_print_error_function): Argument context
- is unused.
-
-2001-07-14 Tim Josling <tej@melbpc.org.au>
-
- * com.c (ffecom_overlap_): Remove references to EXPON_EXPR.
- (ffecom_tree_canonize_ref_): Likewise.
-
-2001-07-10 James Smaby <jsmaby@virgo.umeche.maine.edu>
-
- * intdoc.in: Fix the definition of COMPLEX ABS.
- Remove `the' where inappropriate.
- * intdoc.texi: Rebuilt.
-
-2001-07-04 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Use gpl.texi and funding.texi. Remove Look and Feel
- section. Add Funding Free Software to invariant sections.
- * Make-lang.in ($(srcdir)/f/g77.info, f/g77.dvi): Update
- dependencies and use doc/include in search path.
-
-2001-06-28 Gabriel Dos Reis <gdr@codesourcery.com>
-
- * Make-lang.in (f/com.o): Depend on diagnostic.h
- * com.c: #include diagnostic.h
- (lang_print_error_function): Take a 'diagnostic_context *'.
-
-Wed Jun 13 11:22:39 2001 Mark Mitchell <mark@codesourcery.com>
-
- * BUGS: Remove.
- * NEWS: Likewise.
-
-2001-06-10 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77install.texi: Remove.
- * Make-lang.in: Remove all mention of g77install.texi.
- * g77.texi: Add documentation on how to get output always
- flushed and how to increase the maximum unit number.
- Remove all mention of g77install.texi.
- * bugs.texi: Add documentation on how to change the threshold
- for putting local arrays on the stack.
-
-2001-06-03 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi: Fix typo in patches e-mail address.
-
-2001-06-03 Toon Moene <toon@moene.indiv.nluug.nl>
- Jan van Male <jan.vanmale@fenk.wau.nl>
-
- * root.texi: Define `help' and `patches' mailing list
- addresses.
- * news.texi: Remove `prerelease' from 0.5.26
- * g77.texi: Use two spaces between command options, eliminate
- some 'overfull hboxes'. Use help and patches mailing list
- addresses where appropriate.
-
-2001-06-02 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Move contents to just after title page.
-
-2001-06-02 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_init_0): Make CHARACTER*1 unsigned.
-
-2001-05-23 Theodore Papadopoulo <Theodore.Papadopoulo@sophia.inria.fr>
-
- * Make-lang.in ($(srcdir)/f/g77.info): Added dependencies on
- fdl.texi.
- (f/g77.dvi): Use TEXI2DVI instead of custom tex calls. Create the
- dvi file in the f directory.
-
-2001-05-25 Sam TH <sam@uchicago.edu>
-
- * bad.h: Fix header include guards.
- * bit.h bld.h com.h data.h equiv.h expr.h global.h
- implic.h info.h intrin.h lab.h lex.h malloc.h name.h
- proj.h src.h st.h sta.h stb.h stc.h std.h ste.h
- storag.h stp.h str.h sts.h stt.h stu.h stv.h stw.h
- symbol.h target.h top.h type.h version.h
- where.h: Likewise.
-
-2001-05-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Update last-changed date.
- * news.texi: Update copyright years, last-changed date.
- * bugs.texi: Update copyright years, last-changed date.
-
-2001-05-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77.texi: Update maintenance information for
- GNU Fortran. Remove all mention of -fdebug-kludge.
- * news.texi: Make more news in 0.5.26 `user visible
- changes'. Acknowledge work by important contributors.
- * bugs.texi: Remove all mention of -fdebug-kludge.
-
-2001-05-20 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (f/g77.dvi): Include $(srcdir) in TEXINPUTS.
-
-2001-05-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * Make-lang.in: Have $(MAKEINFO) look into the parent
- directory for includes.
- * g77.texi: Use the GFDL.
-
-Sun May 13 12:25:06 2001 Mark Mitchell <mark@codesourcery.com>
-
- * Make-lang.in: Replace all uses of `touch' with $(STAMP).
-
-Wed May 2 10:20:08 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c: NULL_PTR -> NULL.
-
-Sun Apr 22 20:18:01 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_subscript_check_): Use concat in lieu of
- xmalloc/sprintf.
-
-2001-04-21 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * news.texi: Update release information for 0.5.27.
-
-Thu Apr 19 12:49:24 2001 Mark Mitchell <mark@codesourcery.com>
-
- * top.c (ffe_decode_option): Do not permit language-independent
- processing for -ffixed-line-length.
-
-Thu Apr 12 17:57:55 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (inhibit_warnings): Delete redundant declaration.
-
- * com.c (skip_redundant_dir_prefix): Likewise.
-
- * com.h (mark_addressable): Likewise.
-
-2001-04-02 Jakub Jelinek <jakub@redhat.com>
-
- * lex.c (ffelex_hash_): Avoid eating one whole line after
- #line.
-
-Mon Apr 2 22:38:09 2001 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (duplicate_decls): Fix thinko in lazy DECL_RTL patch
- of 2001-03-04.
-
-Tue Mar 27 17:40:08 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in: Depend on $(SYSTEM_H), not system.h.
-
-Mon Mar 26 18:13:30 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (duplicate_decls): Don't copy DECL_FRAME_SIZE.
-
-Mon Mar 19 15:05:39 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (builtin_function): Use SET_DECL_ASSEMBLER_NAME.
-
-Wed Mar 14 09:29:27 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_member_phase_2): Use COPY_DECL_RTL,
- DECL_RTL_SET_P, etc.
- (duplicate_decls): Likewise.
- (start_decl): Likewise.
-
-Fri Mar 9 22:52:55 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * fini.c (main): Use really_call_malloc, not malloc.
-
-Thu Mar 8 13:27:47 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c: Don't rely on the POSIX macro to define autoconf stuff.
-
-2001-03-07 Brad Lucier <lucier@math.purdue.edu>
-
- * g77.texi: Document new options -funsafe-math-optimizations
- and -fno-trapping-math. Revise documentation for -ffast-math.
-
-2001-03-01 Zack Weinberg <zackw@stanford.edu>
-
- * proj.h: Delete 'bool' type. Don't include stddef.h here.
- * com.c: Rename variables named 'true' and/or 'false'.
- * intdoc.c: Delete 'bool' type.
-
-2001-03-01 Zack Weinberg <zackw@stanford.edu>
-
- * lang-specs.h: Add zero initializer for cpp_spec field to all
- array elements.
-
-2001-02-24 Zack Weinberg <zackw@stanford.edu>
-
- * com.c: Don't define STDC_HEADERS, autoconf handles it.
-
-Fri Feb 23 15:28:39 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (set_block): Set NAMES and BLOCKS from BLOCK.
-
-2001-02-19 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * version.c, root.texi: Update GCC version number to 3.1. Update
- G77 version number to 0.5.27.
- * BUGS, NEWS: Regenerate.
-
-Sun Feb 4 15:52:44 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_init_0): Call fatal_error instead of fatal.
- * com.c (init_parse): Call fatal_io_error instead of
- pfatal_with_name.
- (ffecom_decode_include_option_): Make errors non-fatal.
- * lex.c (ffelex_cfelex_, ffelex_get_directive_line_): Likewise.
- (ffelex_hash_): Likewise.
-
-Sat Jan 27 20:52:18 2001 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in: Remove all dependencies on defaults.h.
- * com.c: Don't include defaults.h.
-
-2001-01-23 Michael Sokolov <msokolov@ivan.Harhan.ORG>
-
- * com.c: Don't explicitly include any time headers, the right ones are
- already included by proj.h.
-
-2001-01-15 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_lookup_label): Set DECL_CONTEXT for FORMAT
- label to current_function_decl.
-
-Fri Jan 12 17:21:33 2001 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lang_specific_driver): Update copyright year to 2001.
-
-Wed Jan 10 14:39:45 2001 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_init_zero_): Remove last argument in call to
- make_decl_rtl; use make_function_rtl instead of make_decl_rtl.
- (ffecom_lookup_label_): Likewise.
- (builtin_function): Likewise.
- (start_function): Likewise.
-
-Thu Dec 21 21:19:42 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77install.texi, g77.texi: Update last-updated dates for
- installation information and the manual as a whole.
- * bugs.texi, news.texi: Update copyright years in the comments at
- the top of the file.
-
-2000-12-21 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77install.texi: Adjust wording of an EGCS reference.
-
-Thu Dec 21 20:00:48 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * BUGS, NEWS: Regenerate.
-
-2000-12-18 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * com.c [VMS]: Remove definition of BSTRING.
-
-2000-12-18 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77.texi: Update GPL copy not to refer to years 19@var{yy}.
-
-2000-12-18 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bugs.texi: Correct copyright years.
- * g77.texi: Likewise.
- * news.texi: Likewise.
-
-2000-12-18 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77install.texi: Remove obsolete parts only used for INSTALL,
- and DOC-G77 conditionals. Update last-update-install date.
-
-Sat Dec 9 10:20:11 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * .cvsignore: New file; add info files.
-
-2000-12-08 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (f77.info): Depend on info files in source
- directory.
- (f/g77.info): Build info files in source directory; don't build
- them unless BUILD_INFO is "info".
- (f77.install-info): Install info files from source directory.
-
-2000-12-07 Zack Weinberg <zack@wolery.stanford.edu>
-
- * Make-lang.in: Link f/fini with safe-ctype.o.
- * bad.c: Don't test ISUPPER(c) || ISLOWER(c) before calling TOUPPER(c).
- * com.c: Use TOUPPER, not ffesrc_toupper.
- * fini.c: Don't test ISALPHA(c) before calling TOUPPER(c)/TOLOWER(c).
- * intrin.c: Don't test IN_CTYPE_DOMAIN(c).
- * src.c: Delete ffesrc_toupper_ and ffesrc_tolower_ and their
- initializing code; use TOUPPER and TOLOWER instead of
- ffesrc_toupper and ffesrc_tolower.
- * src.h: Don't declare ffesrc_toupper_ or ffesrc_tolower_.
- Don't define ffesrc_toupper or ffesrc_tolower.
-
-2000-11-28 Richard Henderson <rth@redhat.com>
-
- * com.c (ffecom_member_phase2_): Set TREE_USED on the debugging decl.
-
-2000-11-26 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * RELEASE-PREP: Remove obsolete EGCS reference.
- * g77.texi: Adjust reference to EGCS as something current.
- * lang-options.h (FTNOPT): Remove macro and obsolete comment.
- Include doc strings directly in option listing instead of through
- this macro.
- * root.texi: Remove support for multiple different (FSF and EGCS)
- distributions of g77.
- * g77install.texi: Remove conditioned out instructions applying
- only to obsolete distributions of g77 not as part of GCC. Change
- "superceded" to the correct spelling "superseded".
-
-Sun Nov 26 19:25:56 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * g77spec.c (lang_specific_driver): Update copyright year to 2000.
-
-Thu Nov 23 02:18:57 2000 J"orn Rennecke <amylaar@redhat.com>
-
- * Make-lang.in (g77spec.o): Depend on $(CONFIG_H).
-
-2000-11-21 David Billinghurst <David.Billinghurst@riotinto.com)
-
- * Make-lang.in: Add $(build_exeext) to f/fini target
-
-2000-11-21 Andreas Jaeger <aj@suse.de>
-
- * g77.texi (Floating-point Exception Handling): Use feenableexcept
- in example.
- (Floating-point precision): Change to match above change.
-
-Sun Nov 19 17:29:22 2000 Matthias Klose <doko@marvin.itso-berlin.de>
-
- * g77.texi (Floating-point precision): Adjust example
- to work with glibc (>= 2.1).
-
-Sat Nov 18 13:54:49 2000 Matthias Klose <doko@cs.tu-berlin.de>
-
- * g77.texi (Floating-point Exception Handling): Adjust
- example to work with glibc (>= 2.1).
-
-2000-11-18 Alexandre Oliva <aoliva@redhat.com>
-
- * Make-lang.in (INTDOC_DEPS): New macro.
- (f/intdoc.texi): Depend on $(INTDOC_DEPS). Build f/intdoc.
- (f/intdoc): Likewise. Add $(build_exeext).
-
-2000-11-17 Zack Weinberg <zack@wolery.stanford.edu>
-
- * lex.c (ffelex_hash_): Change ggc_alloc_string (var, -1) to
- ggc_strdup (var).
-
-Thu Nov 16 23:14:07 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * malloc.c (malloc_init): Call xmalloc, not malloc.
-
-2000-11-10 Rodney Brown <RodneyBrown@mynd.com>
-
- * Make-lang.in: Remove OUTPUT_OPTION from g77version.o target.
-
-2000-11-10 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi: Remove non-historical EGCS reference.
- Set current g77 version to 0.5.26.
-
-2000-11-10 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_stabilize_aggregate_) case RTL_EXPR: Abort.
-
-2000-11-10 Zack Weinberg <zack@wolery.stanford.edu>
-
- * Make-lang.in (f/fini.o, f/proj-h.o): Remove pointless sed
- munging of source file name.
- ($(srcdir)/f/intdoc.texi): Break up into several rules each of
- which builds just one thing. Don't mess with $(LANGUAGES).
- (f/ansify.o, f/intdoc.o): Remove unnecessary rules.
-
-2000-11-05 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * root.texi, news.texi, g77install.texi, g77.texi, bugs.texi:
- Remove non-historical references to egcs/EGCS.
-
-2000-11-05 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in: Remove f77.distdir and f/INSTALL.
- * INSTALL, install0.texi: Remove.
-
-2000-11-02 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * com.c (open_include_file, ffecom_open_include_): Use strchr ()
- and strrchr () instead of index () and rindex ().
-
-2000-10-27 Zack Weinberg <zack@wolery.stanford.edu>
-
- * Make-lang.in: Move all build rules here from Makefile.in,
- adapt to new context. Wrap all rules that change the current
- directory in parentheses. Expunge all references to $(P).
- When one command depends on another and they're run all at
- once, use && to separate them, not ;. Add OUTPUT_OPTION to
- all object-file generation rules. Delete obsolete variables.
-
- * Makefile.in: Delete.
- * config-lang.in: Delete outputs= line.
-
-Sat Oct 21 18:07:48 2000 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Makefile.in, g77spec.c: Remove EGCS references in comments.
-
-Thu Oct 12 22:28:51 2000 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (ffecom_do_entry_): Don't mess with obstacks.
- (ffecom_finish_global_): Likewise.
- (ffecom_finish_symbol_transform_): Likewise.
- (ffecom_gen_sfuncdef_): Likewise.
- (ffecom_init_zero_): Likewise.
- (ffecom_start_progunit_): Likewise.
- (ffecom_sym_transform_): Likewise.
- (ffecom_sym_transform_assign_): Likewise.
- (ffecom_transform_equiv_): Likewise.
- (ffecom_transform_namelist_): Likewise.
- (ffecom_vardesc_): Likewise.
- (ffecom_vardesc_array_): Likewise.
- (ffecom_vardesc_dims_): Likewise.
- (ffecom_end_transition): Likewise.
- (ffecom_make_tempvar): Likewise.
- (bison_rule_pushlevel_): Likewise.
- (bison_rule_compstmt_): Likewise.
- (finish_decl): Likewise.
- (finish_function): Likewise.
- (push_parm_decl): Likewise.
- (start_decl): Likewise.
- (start_function): Likewise.
- (ggc_p): Don't define.
- * std.c (ffestd_stmt_pass_): Likewise.
- * ste.c (ffeste_end_block_): Likewise.
- (ffeste_end_stmt_): Likewise.
- (ffeste_begin_iterdo_): Likewise.
- (ffeste_io_ialist_): Likewise.
- (ffeste_io_cilist_): Likewise.
- (ffeste_io_inlist_): Likewise.
- (ffeste_io_olist_): Likewise.
- (ffeste_R810): Likewise.
- (ffeste_R838): Likewise.
- (ffeste_R839): Likewise.
- (ffeste_R842): Likewise.
- (ffeste_R843): Likewise.
- (ffeste_R1001): Likewise.
-
-2000-10-05 Richard Henderson <rth@cygnus.com>
-
- * com.c (finish_function): Don't init can_reach_end.
-
-Sun Oct 1 11:43:44 2000 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (lang_mark_false_label_stack): Remove.
-
-2000-09-10 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c: Include defaults.h.
- * com.h: Don't define the *_TYPE_SIZE macros.
- * Makefile.in: Update dependencies.
-
-2000-08-29 Zack Weinberg <zack@wolery.cumb.org>
-
- * ansify.c: Use #line, not # <number>.
-
-2000-08-24 Greg McGary <greg@mcgary.org>
-
- * intdoc.c (ARRAY_SIZE): Remove macro.
- * proj.h (ARRAY_SIZE): Remove macro.
- * com.c (init_decl_processing): Use ARRAY_SIZE.
-
-2000-08-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com-rt.def: Adapt macro DEFGFRT to accept CONST boolean.
- * com.c (macro DEFGFRT): Use CONST boolean.
- (ffecom_call_binop_): Choose between call by value
- and call by reference.
- (ffecom_expr_): Use direct calls to (g)libc functions for
- POW_DD, LOG10, (float) MOD.
- (ffecom_make_gfrt_): Add const indication to table of
- intrinsics.
- * com.h (macro DEFGFRT): Use CONST boolean.
- * intrin.def: Adjust DEFIMP definition of LOG10, (float) MOD.
-
-2000-08-21 Nix <nix@esperi.demon.co.uk>
-
- * lang-specs.h: Do not process -o or run the assembler if
- -fsyntax-only. Use %j instead of /dev/null.
-
-2000-08-21 Jakub Jelinek <jakub@redhat.com>
-
- * lang-specs.h: Pass -I* options to f771.
-
-2000-08-19 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * top.c (ffe_decode_option): Disable -fdebug-kludge
- and warn about it.
- * lang-options.h: Document the fact.
- * g77.texi: Ditto.
-
-2000-08-13 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bugs.texi: Describe new ability to emit debug info
- for EQUIVALENCE members.
- * news.texi: Ditto.
-
-2000-08-11 G. Helffrich <george@gly.bris.ac.uk>
- Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_transform_equiv_): Make EQUIVALENCEs addressable
- so that debug info can be attached to their storage.
- Unconditionally list the storage set aside for them.
-
-2000-08-07 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77spec.c (lang_specific_driver): Clearer g77 version message.
-
-2000-08-04 Zack Weinberg <zack@wolery.cumb.org>
-
- * Make-lang.in (f771): Depend on $(BACKEND), not stamp-objlist.
- * Makefile.in: Add BACKEND; delete OBJS, OBJDEPS.
- (f771): Link with $(BACKEND).
-
-2000-08-02 Zack Weinberg <zack@wolery.cumb.org>
-
- * g77spec.c: Adjust type of second argument to
- lang_specific_driver, and update code as necessary.
-
- * expr.c (ffeexpr_finished_): Cast signed side of ?:
- expression to bool.
-
-2000-07-31 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Rename cpp to cpp0 and/or tradcpp to tradcpp0.
-
-Thu Jul 27 11:50:08 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * fini.c (main): Avoid automatic aggregate initialization.
-
- * proj.h: Indent #error directive.
-
-2000-07-26 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * lang-specs.h: Remove one /dev/null from tradcpp invocation.
-
-Sun Jul 23 15:47:30 2000 Billinghurst, David <David.Billinghurst@riotinto.com>
-
- * Make-lang.in: Put $(build_exeext) suffix on programs which run
- on the build machine.
-
-2000-07-22 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * com.c (ffecom_expr_intrinsic_): case FFEINTRIN_impFGETC_subr,
- FFEINTRIN_impFPUTC_subr: Check for arg3 being NULL.
-
-2000-07-13 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Use the new named specs. Remove unnecessary braces.
-
-2000-07-02 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * version.c: Bump version number.
-
-2000-06-21 Zack Weinberg <zack@wolery.cumb.org>
-
- * Make-lang.in (F77_SRCS): Remove all .j files.
- * Makefile.in (ASSERT_H, CONFIG_H, CONVERT_H, FLAGS_H, GGC_H,
- GLIMITS_H, HCONFIG_H, INPUT_H, OUTPUT_H, RTL_H, SYSTEM_H,
- TOPLEV_H, TREE_H): Remove references to .j files.
- (TCONFIG_H, TM_H): Remove entirely.
- (deps-kinda): Delete rule.
- Correct commentary.
-
- * assert.j, config.j, convert.j. flags.j, ggc.j, glimits.j,
- hconfig.j, input.j, output.j, rtl.j, system.j, toplev.j,
- tree.j, tconfig.j, tree.j: Delete.
-
- * ansify.c, bad.c, bit.c, com.c, com.h, intdoc.c, lex.c,
- parse.c, proj.c, proj.h, ste.c, target.c, target.h, top.c,
- where.c, where.h: Include parent-directory headers directly.
- * lex.c: Don't include tree.h twice.
-
-2000-05-17 H.J. Lu (hjl@gnu.org)
-
- * Make-lang.in: Use a unique stamp for each target to support
- parallel make.
-
-Thu Jun 15 14:03:14 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * ste.c (gbe_block): Constify.
-
-2000-06-13 Jakub Jelinek <jakub@redhat.com>
-
- * com.c (ffecom_transform_common_): Set DECL_USER_ALIGN.
- (ffecom_transform_equiv_, ffecom_decl_field): Likewise.
- (ffecom_init_0): Set DECL_USER_ALIGN resp. TYPE_USER_ALIGN.
- (duplicate_decls): Set DECL_USER_ALIGN.
-
-Sun Jun 11 00:03:00 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (lang_get_alias_set): Mark parameter with ATTRIBUTE_UNUSED.
-
-2000-06-04 Philipp Thomas <pthomas@suse.de>
-
- * Makefile.in(INTLLIBS): New macro.
- (LIBS): Add INTLLIBS.
- (DEPLIBS): Likewise.
-
-2000-06-02 Richard Henderson <rth@cygnus.com>
-
- * com.c (lang_get_alias_set): New.
-
-2000-05-28 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * bugs.texi: Note that debugging information for
- common block items is emitted now.
- * news.texi: Ditto.
-
-2000-05-18 Chris Demetriou <cgd@sibyte.com>
-
- * com.h (FFECOM_f2cINTEGER, FFECOM_f2cLONGINT): Note that
- these types correspond to built-in types now defined in
- the C front end (for libf2c).
-
-Wed May 17 17:27:44 2000 Andrew Cagney <cagney@b1.cygnus.com>
-
- * top.c (ffe_decode_option): Update -Wall unused flags by calling
- set_Wunused.
-
-2000-05-09 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c (ffecom_subscript_check_): Constify array_name
- parameter. Clean up string bashing.
- (ffecom_arrayref_, ffecom_char_args_x_): Constify array_name
- parameter.
- (ffecom_do_entry_, ffecom_gen_sfuncdef_, ffecom_start_progunit_,
- ffecom_sym_transform_, ffecom_sym_transform_assign_): Constify
- local char *.
- (init_parse): Constify parameter and return value.
- * lex.c: Include dwarfout.h instead of prototyping dwarfout_*
- functions here.
- (ffelex_file_pop_, ffelex_file_push_): Constify filename parameter.
- (ffelex_hash_, ffelex_include_): Constify local char *.
- * std.c (ffestd_exec_end): Constify local char *.
- * where.c (ffewhere_file_new): Constify filename parameter.
- * where.h: Update prototypes.
-
-2000-05-06 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c (ffecom_overlap_): Set source_offset to
- bitsize_zero_node.
- (ffecom_tree_canonize_ptr_): Use size_binop. Convert to
- bitsizetype before multiplying by TYPE_SIZE.
- (ffecom_tree_canonize_ref_) [case ARRAY_REF]: Break up offset
- calculation. Convert to bitsizetype before multiplying by
- TYPE_SIZE.
-
-2000-04-18 Zack Weinberg <zack@wolery.cumb.org>
-
- * lex.c: Remove references to cccp.c.
- * g77install.texi: Remove references to cexp.c/cexp.y.
-
-2000-04-15 David Edelsohn <edelsohn@gnu.org>
-
- * target.h (FFETARGET_32bit_longs): Define for 64-bit PowerPC
- as well.
-
-Wed Apr 12 15:15:26 2000 Mark Mitchell <mark@codesourcery.com>
-
- * com.h (FFECOM_f2cINTEGER): Avoid using LONG_TYPE_SIZE as a
- preprocessor constant.
- (FFECOM_f2cLOGICAL): Likewise.
- (FFECOM_f2cLONGINT): Likewise.
-
-Wed Apr 5 17:46:39 2000 Mark Mitchell <mark@codesourcery.com>
-
- * Makefile.in (GGC_H): Add varray.h.
-
-2000-04-03 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Pass -fno-show-column to the preprocessor.
-
-2000-03-28 Franz Sirl <Franz.Sirl-kernel@lauterbach.com>
-
- * com.c (ffecom_decl_field): Use DECL_ALIGN for a FIELD_DECL.
- (ffecom_init_0): Likewise.
-
-Sat Mar 25 09:12:10 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_tree_canonize_ptr_): Use bitsize_zero_node.
- (ffecom_tree_canonize_ref_): Likewise.
-
-Mon Mar 20 15:49:40 2000 Jim Wilson <wilson@cygnus.com>
-
- * f/target.h (FFETARGET_32bit_longs): New. Define for alpha, sparc64,
- and ia64.
- (ffetargetInteger1, ffetargetLogical1, ffetargetReal1, ffetargetReal2,
- ffetarget_integerdefault_is_magical): Use FFETARGET_32bit_longs.
-
-Fri Mar 10 00:43:55 2000 Jason Merrill <jason@casey.cygnus.com>
-
- * com.c (ffecom_stabilize_aggregate_): Don't refer to TREE_RAISES.
-
-Mon Mar 6 18:05:19 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_f2c_set_lio_code_): Use compare_tree_int.
- (ffecom_sym_transform_, ffecom_transform_common_): Likewise.
- (ffecom_transform_equiv_): Likewise.
-
-Mon Mar 6 13:01:19 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * ansify.c (die_unless): Don't use ANSI string concatenation.
- (die): Mark with ATTRIBUTE_NORETURN.
-
-Wed Mar 1 00:31:44 2000 Martin von Loewis <loewis@informatik.hu-berlin.de>
-
- * com.c (current_function_decl): Move to toplev.c.
-
-Sun Feb 27 16:40:33 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_arrayref_): Convert args to size_binop to proper type.
- (ffecom_tree_canonize_ptr_): Don't use size_binop for non-sizes.
- (ffecom_tree_canonize_ref_): Likewise.
- (type_for_mode): Handle TImode.
- * ste.c (ffeste_io_dofio_, ffeste_io_douio_): Use TYPE_SIZE_UNIT.
- (ffeste_io_ciclist_): Likewise.
-
-2000-02-23 Zack Weinberg <zack@wolery.cumb.org>
-
- * com.c (ffecom_type_permanent_copy_): Delete unused function.
- (finish_decl): Don't change TREE_PERMANENT (DECL_INITIAL (decl)).
-
-Sat Feb 19 18:43:13 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * com.c (ffecom_sym_transform): Use DECL_SIZE_UNIT.
- (ffecom_transform_common_, ffecom_transform_equiv_): Likewise.
- (duplicate_decls): Likewise.
- (ffecom_tree_canonize_ptr_): Delete extra arg to bitsize_int.
- (finish_decl): Delete -Wlarger-than processing.
-
-Fri Feb 18 13:19:34 2000 Martin von Loewis <loewis@informatik.hu-berlin.de>
-
- * g77spec.c (lang_specific_driver): Use GCCBUGURL.
-
-2000-02-17 Andy Vaught <andy@maxwell.la.asu.edu>
-
- * com.c (ffecom_member_phase2_): Re-enable COMMON debug code.
- (ffecom_finish_symbol_transform_): Likewise.
- (ffecom_transform_common_): Call ffestorag_set_hook.
-
-Wed Feb 16 11:09:38 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (g77spec.o): Depend on $(GCC_H), not gcc.h.
-
-2000-02-15 Jonathan Larmour <jlarmour@redhat.co.uk>
-
- * lang-specs.h: Add new __GNUC_PATCHLEVEL__ define to default spec.
-
-Tue Feb 15 11:14:17 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * g77spec.c: Don't declare `version_string'.
-
-Sat Feb 5 23:27:25 2000 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (mark_tracker_head, mark_binding_level): Protoize.
-
- * where.c (mark_ffewhere_head): Likewise.
-
-Wed Jan 12 09:32:59 2000 Zack Weinberg <zack@wolery.cumb.org>
-
- * lang-specs.h: Pass -lang-fortran to preprocessor.
-
-Thu Dec 30 13:14:31 1999 Richard Henderson <rth@cygnus.com>
-
- * stw.h (struct _ffestw_): Change type of uses_ to int.
-
-Thu Dec 30 11:42:05 1999 Geoff Keating <geoffk@cygnus.com>
-
- * com.c (ffecom_init_0): Make double_ftype_double,
- float_ftype_float, ldouble_ftype_ldouble,
- ffecom_tree_ptr_to_fun_type_void local.
- (tracker_head): New static variable.
- (mark_tracker_head): New, marker procedure for tracker_head.
- (ffecom_save_tree_forever): New procedure.
- (ffecom_init_zero_): Remove obstack use.
- (ffecom_make_gfrt_): Remove obstack use.
- (ffecom_sym_transform_): Remove obstack use, save appropriate trees.
- (ffecom_transform_common_): Remove obstack use, save appropriate
- trees.
- (ffecom_type_namelist_): Remove obstack use, save appropriate
- trees.
- (ffecom_type_vardesc_): Remove obstack use, save appropriate trees.
- (ffecom_lookup_label): Remove obstack use, save appropriate trees.
- (duplicate_decls): Remove obstack use.
- (finish_function): push & pop ggc context around
- rest_of_compilation when building nested function.
- (mark_binding_level): New function.
- (init_decl_processing): Mark all the GC roots.
- (ggc_p): Set to 1.
- (lang_mark_tree): New function.
- (lang_mark_false_label_stack): New trivial function.
- * com.h (ffecom_save_tree_forever): Declare as external.
- * lex.c (ffelex_hash_): Use GC to allocate the filename string
- even when ffelex_kludge_flag_.
- * ste.c (ffeste_io_ialist_): Register a static root.
- (ffeste_io_inlist_): Likewise.
- (ffeste_io_icilist_): Likewise.
- (ffeste_io_cllist_): Likewise.
- (ffeste_io_cilist_): Likewise.
- (ffeste_io_olist_): Likewise.
- * Makefile.in (OBJS): Don't use ggc-callbacks.o.
- (OBJDEPS): Likewise.
- (GGC_H): New variable.
- Update dependencies.
- * where.c (ffewhere_head): New global.
- (mark_ffewhere_head): New marker procedure for ffewhere_head.
- (ffewhere_file_kill): Use GC to do memory management.
- (ffewhere_file_new): Use GC to do memory management.
- * ggc.j: New file.
-
-Wed Dec 29 19:29:26 1999 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * g77.texi (C Interfacing Tools): Fix an incorrect link.
-
-1999-12-13 Jakub Jelinek <jakub@redhat.com>
-
- * target.h: Handle sparc64 the same way as alpha.
-
-Sun Nov 28 21:39:05 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_file_, ffecom_file, file_buf,
- ffecom_open_include_): Constify a char*.
- (ffecom_possible_partial_overlap_): Mark parameter `expr2' with
- ATTRIBUTE_UNUSED.
- (ffecom_init_0): Use a fully prototyped cast in call to bsearch.
- (lang_print_error_function): ANSI-fy.
-
- * com.h (ffecom_file): Constify a char*.
-
- * fini.c (main): Call return, not exit.
-
- * g77spec.c (lang_specific_driver): Use non-const *in_argv in
- assignment.
-
- * intrin.c (ffeintrin_cmp_name_): Don't needlessly cast away
- const-ness.
-
-Sun Nov 28 21:15:29 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (ffecom_get_invented_identifier): Rewrite to take an ellipses.
-
- (ffecom_char_enhance_arg_, ffecom_do_entry_,
- ffecom_f2c_make_type_, ffecom_gen_sfuncdef_,
- ffecom_start_progunit_, ffecom_start_progunit_,
- ffecom_start_progunit_, ffecom_sym_transform_assign_,
- ffecom_transform_equiv_, ffecom_transform_namelist_,
- ffecom_vardesc_, ffecom_vardesc_array_, ffecom_vardesc_dims_,
- ffecom_end_transition, ffecom_lookup_label, ffecom_temp_label):
- Adjust accordingly.
-
- * com.h (ffecom_get_invented_identifier): Likewise.
-
- * sts.c (ffests_printf): New function taking ellipses.
- (ffests_printf_1D, ffests_printf_1U, ffests_printf_1s,
- ffests_printf_2Us): Delete.
-
- * sts.h: Likewise.
-
- * std.c (ffestd_R1001dump_, ffestd_R1001dump_1005_1_,
- ffestd_R1001dump_1005_2_, ffestd_R1001dump_1005_3_,
- ffestd_R1001dump_1005_4_, ffestd_R1001dump_1005_5_,
- ffestd_R1001dump_1010_2_, ffestd_R1001dump_1010_3_,
- ffestd_R1001dump_1010_4_, ffestd_R1001dump_1010_5_,
- ffestd_R1001rtexpr_): Call `ffests_printf', not `ffests_printf_*'.
-
- * ste.c (ffeste_io_ialist_, ffeste_io_cilist_, ffeste_io_cllist_,
- ffeste_io_icilist_, ffeste_io_inlist_, ffeste_io_olist_): Likewise.
-
-Wed Nov 10 12:43:21 1999 Philippe De Muyter <phdm@macqel.be>
- Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * proj.h: Test `GCC_VERSION', not `HAVE_GCC_VERSION'.
-
-Tue Oct 26 01:32:19 1999 Mark Mitchell <mark@codesourcery.com>
-
- * com.c (poplevel): Don't call remember_end_note.
-
-Fri Oct 15 15:18:12 1999 Greg McGary <gkm@gnu.org>
-
- * top.h (ffe_is_subscript_check_): Remove extern decl.
- (ffe_is_subscript_check, ffe_set_is_subscript_check): Remove macros.
- * top.c (ffe_is_subscript_check_): Remove global variable.
- (ffe_decode_option): Remove "(no-)bounds-check" flag handling.
- Set flag_bounds_check for "(no-)fortran-bounds-check".
- * com.c
- (ffecom_arrayref_): s/ffe_is_subscript_check ()/flag_bounds_check/
- (ffecom_char_args_x_): Ditto.
-
-Sun Oct 10 08:40:18 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * proj.h: Use HAVE_GCC_VERSION instead of explicitly testing
- __GNUC__ and __GNUC_MINOR__. Don't define BUILT_WITH_270. Define
- macro UNUSED in terms of ATTRIBUTE_UNUSED.
-
-Fri Sep 24 10:48:10 1999 Bernd Schmidt <bernds@cygnus.co.uk>
-
- * com.c (duplicate_decls): Use DECL_BUILT_IN_CLASS rather than
- DECL_BUILT_IN.
- (builtin_function): No longer static. New arg CLASS. Arg
- FUNCTION_CODE now of type int. All callers changed.
- Set the builtin's DECL_BUILT_IN_CLASS.
-
-Tue Sep 21 09:08:30 1999 Toon Moene <toon@moene.indiv.nluug.nl>
-
- * g77spec.c (lang_specific_driver): Initialize return value.
-
-Thu Sep 16 18:07:11 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Use uppercase ctype macro from system.h.
-
- * fini.c (main): Likewise.
-
- * intrin.c (ffeintrin_init_0): Likewise.
-
- * lex.c (ffelex_hash_): Likewise.
-
- * src.c (ffesrc_init_1): Likewise.
-
-Tue Sep 14 12:14:28 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * g77spec.c (lang_specific_driver): Remove unnecessary argument in
- call to function `fatal'.
-
-Sun Sep 12 23:29:47 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (g77spec.o): Depend on system.h and gcc.h.
-
- * g77spec.c: Include gcc.h.
- (g77_xargv): Constify.
- (g77_fn): Add parameter prototypes.
- (lookup_option, append_arg): Add static prototypes.
- (g77_newargv): Constify.
- (lookup_option, append_arg, lang_specific_driver): Constify a char*.
- (lang_specific_driver): All calls to the function pointer
- parameter now explicitly call `fatal'.
-
-Fri Sep 10 10:32:32 1999 Bernd Schmidt <bernds@cygnus.co.uk>
-
- * com.h: Delete declarations for all tree nodes now moved to
- global_trees.
- * com.c: Delete their definitions.
- (ffecom_init_0): Call build_common_tree_nodes and
- build_common_tree_nodes_2 instead of building their nodes here.
- Override their decisions for complex nodes.
-
-Sat Sep 4 13:46:27 1999 Mark Mitchell <mark@codesourcery.com>
-
- * Make-lang.in (f771): Depend on ggc-callbacks.o.
- * Makefile.in (OBJS): Add ggc-callbacks.o.
- (OBJDEPS): Likewise.
-
-Mon Aug 30 22:05:53 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (language_string): Constify.
-
-Mon Aug 30 20:29:30 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Makefile.in (LIBS, LIBDEPS): Link with & depend on libiberty.a.
- Remove hacks for stuff which now comes from libiberty.
-
-Sun Aug 29 09:47:45 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (lang_printable_name): Constify a char*.
-
-Wed Aug 25 01:21:06 1999 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
-
- * lang-specs.h: Pass cc1 spec to f771.
-
-Mon Aug 9 19:44:08 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (lang_print_error_function): Constify a char*.
- (init_parse): Remove redundant prototype for `print_error_function'.
- (lang_identify): Constify a char*.
-
-Thu Aug 5 02:40:42 1999 Jeffrey A Law (law@cygnus.com)
-
- * g77spec.c: Update URLS and mail addresses.
- * root.texi: Update URLS and mail addresses.
-
-1999-07-25 Richard Henderson <rth@cygnus.com>
-
- * com.c (ptr_type_node, va_list_type_node): New.
- (ffecom_init_0): Init and use ptr_type_node.
-
-1999-07-17 Alexandre Oliva <oliva@dcc.unicamp.br>
-
- * root.texi: Update e-mail addresses to gcc.gnu.org.
- * g77spec.c (lang_specific_driver): Updated URL with bug reporting
- instructions to gcc.gnu.org. Removed e-mail address.
-
-Sat Jul 17 11:28:43 1999 Craig Burley <craig@jcb-sc.com>
-
- * root.texi, g77install.texi: Switchover to GCC terminology.
- Also, FSF-G77 had been mistakenly set at some point.
-
-Thu Jul 8 15:38:50 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Describe DATE intrinsic fix.
-
-Mon Jun 28 21:44:19 1999 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Denote experimental version.
-
-Mon Jun 28 10:43:11 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (ffecom_prepare_expr_): A COMPLEX intrinsic needs
- a temp even if -fno-f2c.
-
- * version.c: Bump version.
-
-Mon Jun 28 21:31:35 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Doc upgrade to netlib libf2c as of today.
- Explain that this fixes the NAMELIST-read bug.
-
-Fri Jun 25 11:06:32 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi: Describe K(5)=10*3 NAMELIST-read bug.
-
-Mon Jun 21 12:40:17 1999 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
-
- * g77.texi: Update links.
-
-Mon Jun 21 05:33:51 1999 Jeffrey A Law (law@cygnus.com)
-
- * news.texi: Add missing @end ifclear.
-
-Fri Jun 18 11:43:46 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Doc TtyNam fix.
-
-Fri Jun 18 11:26:50 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: New heading for development version.
- Doc upgrade to netlib libf2c as of today.
-
-Wed Jun 16 11:43:02 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Mention BACKSPACE fix to libg2c.
-
-Mon Jun 7 08:42:40 1999 Craig Burley <craig@jcb-sc.com>
-
- * Make-lang.in: Any target using libsubdir must depend
- on installdirs.
-
-Sat Jun 5 23:50:36 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Describe a few more missing features people
- have emailed me about.
-
-Sat Jun 5 17:03:23 1999 Craig Burley <craig@jcb-sc.com>
-
- From Dave Love to egcs-patches on 20 May 1999 17:38:38 +0100:
- * g77.texi: Clean up fossil text vis-a-vis Intel CPUs.
-
-Fri Jun 4 13:56:56 1999 Craig Burley <craig@jcb-sc.com>
-
- * Make-lang.in: Use libsubdir, not prefix, to store
- temporary lang-f77 `flag' file.
-
-Fri Jun 4 10:26:04 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi (News): Mention GCC 2.95 in favor of EGCS 1.2.
- Mention that libg2c is multilibbed.
-
-Fri Jun 4 10:09:50 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Missing Features): Add `Better Warnings'
- item.
-
-Fri May 28 16:51:41 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Fix thinko.
-
-Wed May 26 14:43:27 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Document Tue May 18 03:52:04 1999 patch.
- Fix a grammo.
-
-Wed May 26 14:25:07 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi, news.texi, root.texi, version.c: Start renaming
- EGCS 1.2 to GCC 2.95, and start using 0.5.25 to designate
- the version of g77 within GCC 2.95.
-
-Wed May 26 11:45:21 1999 Craig Burley <craig@jcb-sc.com>
-
- Rename -fsubscript-check to -fbounds-check and
- -ff2c-subscript-check to -ffortran-bounds-check:
- * g77.texi: Rename options in docs, clarify usage.
- * lang-options.h: Rename options, clarify doclets.
- * news.texi: Rename options, don't bother with fortran-specific
- option.
- * top.c (ffe_decode_option): Rename recognized strings.
-
-Tue May 25 18:21:09 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (FFECOM_FASTER_ARRAY_REFS): Delete this vestige,
- now that -fflatten-arrays exists.
-
-Tue May 25 17:48:34 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix 19990525-0.f:
- * com.c (ffecom_arg_ptr_to_expr): Strip off parens around
- CHARACTER expression.
- (ffecom_prepare_expr_): Ditto.
-
-Tue May 18 03:52:04 1999 Craig Burley <craig@jcb-sc.com>
-
- Support use of back end's improved open-coding of complex divide:
- * com.c (ffecom_tree_divide_): Use RDIV_EXPR for complex divide,
- instead of run-time call to [cz]_div, if `-Os' option specified.
- (lang_init_options): Tell back end we want support for wide range
- of inputs to complex divide.
-
- * Bump version.
-
-Tue May 18 00:21:34 1999 Zack Weinberg <zack@rabi.phys.columbia.edu>
-
- * lang-specs.h: Define __GNUC__ and __GNUC_MINOR__ only if -no-gcc
- was not given.
-
-Thu May 13 12:23:20 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix INTEGER*8 subscripts in array references:
- * com.c (ffecom_subscript_check_): Convert low, high, and
- element as necessary to make comparison work.
- (ffecom_arrayref_): Do more of the work.
- Properly handle subscript expr that's wider than int,
- if pointers are wider than int.
- (ffecom_expr_): Leave more work to ffecom_arrayref_.
- (ffecom_init_0): Record sizes of pointers and ints for
- convenience.
- Use set_sizetype etc. as done by gcc front end.
- (ffecom_ptr_to_expr): Leave more work to ffecom_arrayref_.
- * expr.c (ffeexpr_finished_): Don't convert INTEGER subscript
- expressions in run-time contexts.
- (ffeexpr_token_elements_, ffeexpr_token_substring_1_): Cope with
- non-default INTEGER subscript expressions.
- * news.texi: Announce.
-
- Finish accepting -fflatten-arrays option:
- * com.c (ffecom_arrayref_): Flatten references if requested.
- * g77.texi: Describe.
- * lang-options.h: Allow.
- * news.texi: Announce.
- * top.c, top.h: Recognize.
-
- * version.c: Bump version.
-
-Wed May 12 07:30:05 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (lang_init_options): Disable back end's maintenance
- of errno.
- * news.texi: Document dropping of errno.
-
-1999-05-10 18:21 -0400 Zack Weinberg <zack@rabi.phys.columbia.edu>
-
- * lang-specs.h: Pass -$ to the preprocessor.
-
-Mon May 10 18:14:28 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Fix various @xref's per proper style.
- Go ahead and use nested braces in @xref's, with care.
- * g77install.texi: Fix @xref per proper style.
-
-Mon May 10 17:38:39 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Doc upgrade to netlib libf2c as of today.
-
-Sun May 9 18:52:13 1999 Hans-Peter Nilsson <hp@bitrange.com>
-
- * f/g77spec.c (lang_specific_driver): Correct bug-report address
- and point to the FAQ.
-
-Thu May 6 12:40:21 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Arbitrary Concatenation): Put this under
- "Missing Features" instead of "Projects".
- (Internals Documentation): Point to new "Front End" chapter.
-
-Thu May 6 08:23:52 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Automatic arrays reportedly working
- on HP-UX systems.
-
-Thu May 6 08:19:31 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Advantages Over f2c): Expand on this topic.
-
-Mon May 3 19:41:48 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (ffecom_expr_intrinsic_): Fix test of CTIME_subr.
-
-Mon May 3 18:11:48 1999 Craig Burley <craig@jcb-sc.com>
-
- Reverse order of two arguments to CTIME_subr, DTIME_subr,
- ETIME_subr, and TTYNAM_subr:
- * com.c (ffecom_expr_intrinsic_): Reverse the arguments.
- While at it, set TREE_SIDE_EFFECTS for CTIME_subr and
- TTYNAM_subr.
- * intdoc.in: Document the new calling sequences.
- * intrin.def: Reverse the arguments.
- * news.texi: Document the fact that they changed.
- * version.c: Bump version.
-
-Mon May 3 11:28:14 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Doc upgrade to netlib libf2c as of today.
-
-Sun May 2 17:04:28 1999 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Bump version.
-
-Sun May 2 16:53:01 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix compile/19990502-1.f:
- * ste.c (ffeste_R819B): Don't overwrite tree for temp
- variable when expanding the assignment into it.
-
-Sun Apr 25 20:55:10 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix 19990325-0.f and 19990325-1.f:
- * com.c (ffecom_possible_partial_overlap_): New function.
- (ffecom_expand_let_stmt): Use it to determine whether to assign
- to a COMPLEX operand through a temp.
- * news.texi: Document fix.
-
- * version.c: Bump version.
-
-Sat Apr 24 12:19:53 1999 Craig Burley <craig@jcb-sc.com>
-
- * expr.c (ffeexpr_finished_): Convert DATA implied-do
- start/end/incr expressions to default INTEGER.
- Fix some broken conditionals.
- Clean up some code in the region.
- * news.c: Document the fix.
-
- * version.c: Bump version.
-
-Fri Apr 23 02:08:32 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Compiler Prototypes): Replace "missing" subscript-
- checking option with something else.
-
-Fri Apr 23 01:48:28 1999 Craig Burley <craig@jcb-sc.com>
-
- Support new -fsubscript-check and -ff2c-subscript-check options:
- * com-rt.def (FFECOM_gfrtRANGE): Describe s_rnge, in libf2c/libF77.
- * com.c (ffecom_subscript_check_, ffecom_arrayref_): New functions.
- (ffecom_char_args_x_): Use new ffecom_arrayref_ function for
- FFEBLD_opARRAYREF case.
- Compute character name, array type, and use new
- ffecom_subscript_check_ function for FFEBLD_opSUBSTRING case.
- (ffecom_expr_): Use new ffecom_arrayref_ function.
- (ffecom_ptr_to_expr): Use new ffecom_arrayref_ function.
- * g77.texi, news.texi: Document new options.
- * top.c, top.h: Support new options.
-
- * news.texi: Fix up some items to not be in "User-Visible Changes".
-
- * ste.c (ffeste_R819B): Fix type for loop variable, to avoid
- warnings.
-
- * version.c: Bump version.
-
-Tue Apr 20 01:38:57 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Clarify -malign-double situation.
-
-Tue Apr 20 01:15:25 1999 Craig Burley <craig@jcb-sc.com>
-
- * stb.c (ffestb_R5282_): Convert DATA repeat count
- to default INTEGER, to avoid problems downstream.
-
- * version.c: Bump version.
-
-Mon Apr 19 21:36:48 1999 Craig Burley <craig@jcb-sc.com>
-
- * ste.c (ffeste_R819B): Start the loop before expanding
- the termination expression.
-
- * version.c: Bump version.
-
-Sun Apr 18 21:53:58 1999 Craig Burley <craig@jcb-sc.com>
-
- * com.c (ffecom_sym_transform_): COMMON and EQUIVALENCE
- variables have constant addresses (EQUIVALENCE only if
- containing aggregate is static).
-
-Sat Apr 17 16:55:59 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, ffe.texi, g77.texi, g77install.texi, news.texi:
- Clean up @code{} vs. @samp{}.
- Clean up dashes (`--') vs. @minus{} vs. `---'.
-
- * ffe.texi: Add copyright header.
-
- * g77.texi, lang-options.h, news.texi, top.c (ffe_decode_option):
- Remove support for -fugly option.
- Clarify that -fugly-logint is needed instead of -fugly
- to work around using .EQ./.NE. on LOGICAL operands.
- Explain more about why -fugly-logint is bad juju.
-
- * g77.texi (Missing Features): Describe READONLY as a missing
- feature. Describe AUTOMATIC better.
-
- * news.texi: Mention libf2c upgrade.
-
-Sat Apr 17 14:05:53 1999 Craig Burley <craig@jcb-sc.com>
-
- Make a place for front-end internals documentation:
- * Make-lang.in (f/g77.info, f/g77.dvi): Depend on f/ffe.texi.
- * ffe.texi: New file, containing docs on front-end internals.
- * g77.texi: New chapter for, and inclusion of, ffe.texi.
-
- * g77.texi: Fix an index entry.
-
-Sat Apr 17 13:53:43 1999 Craig Burley <craig@jcb-sc.com>
-
- Rewrite to use block/scope structure of GBE and to ensure
- variables (especially those going on stack/reg) are declared
- before executable code generated:
- * bld.c (ffebld_new_item, ffebld_new_one, ffebld_new_two):
- Support new hooks.
- * bld.h (ffebld_item_hook, ffebld_item_set_hook,
- ffebld_nonter_hook, ffebld_nonter_set_hook): Ditto.
- * bld.h (ffebld_basictype, ffebld_kind, ffebld_kindtype,
- ffebld_rank, ffebld_where): New convenience macros (used
- by rest of this patch).
- * com.c, com.h (ffecom_push_calltemps, ffecom_pop_calltemps,
- ffecom_push_tempvar, ffecom_pop_tempvar): Remove temp-var-
- handling mechanism.
- * com.c (ffecom_call_, ffecom_call_binop_, ffecom_tree_divide_,
- ffecom_call_gfrt): Support passing hooks for temp-var info.
- (ffecom_expr_power_integer_): Takes opPOWER expression, instead
- of its left and right operands, so it can get at the hook.
- (ffecom_prepare_let_char_, ffecom_prepare_arg_ptr_to_expr,
- ffecom_prepare_end, ffecom_prepare_expr_, ffecom_prepare_expr_rw,
- ffecom_prepare_expr_w, ffecom_prepare_return_expr,
- ffecom_prepare_ptr_to_expr): New functions supporting expression
- pre-scanning.
- (bison_rule_compstmt_): Return the tree, as in the CFE.
- (delete_block): New function, from CFE.
- (kept_level_p): New function, from CFE, modified.
- (ffecom_start_compstmt, ffecom_end_compstmt): New functions,
- replacing ffecom_start_compstmt_ and ffecom_end_compstmt_ macros,
- and they do real work.
- (struct binding_level): Add prep_state member. Initialize to 0.
- (ffecom_get_invented_identifier): Now takes either or both a
- string and an integer, using -1 to denote no integer.
- (ffecom_do_entry_): Disallow temp-var generation via expressions
- in body of function, since the exprs aren't prescanned.
- (ffecom_expr_rw): Now takes destination tree.
- (ffecom_expr_w): New function, now used in some places
- ffecom_expr_rw had been used.
- (ffecom_expr_intrinsic_): Move huge f2c-related comment to bottom
- of source file, to avoid annoying problems editing com.c using
- Emacs C-mode.
- (ffecom_expr_power_integer_): Make a temp var for division, if
- necessary.
- Handle expanded statement expression as does CFE.
- (ffecom_start_progunit_): Disallow temp-var generation in body
- of function, since expressions are not prescanned at this level.
- (ffecom_sym_transform_): Transform ASSIGN variables as well,
- so these are all transformed up front, before code-generation
- begins.
- (ffecom_arg_ptr_to_const_expr, ffecom_const_expr,
- ffecom_ptr_to_const_expr): New functions to transform expressions
- only if the results will surely be constants.
- (ffecom_arg_ptr_to_expr): Precompute size, for convenience
- obtaining temp vars.
- (ffecom_expand_let_stmt): Guess at usability of destination
- pre-expansion, to provide better prescan preparation (fewer
- spurious temp vars).
- (ffecom_init_0): Disallow temp-var generation in global scope.
- (ffecom_type_expr): New function, returns just the type tree
- for the expression.
- (start_function): Disallow temp-var generation in parm scope.
- (incomplete_type_error): Fix introductory comment.
- (poplevel): Update (somewhat) from CFE.
- (pushlevel): Update (somewhat) from CFE.
- * stc.c (ffestc_R838): Mark ASSIGNed variable as so.
- * std.c (ffestd_stmt_pass_, ffestd_R803, ffestd_R804, ffestd_R805,
- ffestd_R806): Remember and pass through the ffestw block info
- for these (IFTHEN, ELSEIF, ELSE, and ENDIF) statements.
- * ste.c (ffeste_end_iterdo_): Now takes ffestw block argument.
- (ffeste_io_inlist_): Add prototype.
- (ffeste_f2c_*): Macros rewritten, new ones added.
- (ffeste_start_block_, ffeste_end_block_, ffeste_start_stmt_,
- ffeste_end_stmt_): New macros/functions, depending on whether
- checking is enabled, to keep track of symmetry of other ste.c code.
- (ffeste_begin_iterdo_, ffeste_end_iterdo_, ffeste_io_impdo_,
- ffeste_io_dofio_, ffeste_io_dolio_, ffeste_io_douio_,
- ffeste_io_ialist_, ffeste_io_cilist_, ffeste_io_cllist_,
- ffeste_icilist_, ffeste_io_inlist_, ffeste_io_olist_,
- ffeste_subr_beru_, ffeste_do, ffeste_end_R807, ffeste_R737A,
- ffeste_R803, ffeste_R804, ffeste_R805, ffeste_R806, ffeste_R807,
- ffeste_R809, ffeste_R810, ffeste_R811, ffeste_R819A, ffeste_R819B,
- ffeste_R837, ffeste_R838, ffeste_R839, ffeste_R840, ffeste_R904,
- ffeste_R907, ffeste_R909_start, ffeste_R909_item, ffeste_R909_finish,
- ffeste_R910_start, ffeste_R910_item, ffeste_R910_finish,
- ffeste_R911_start, ffeste_R911_item, ffeste_R911_finish,
- ffeste_R923A, ffeste_R1212, ffeste_R1227): Prescan/prepare
- all pertinent expressions, update to new com.c interface, etc.
- (ffeste_io_impdo_): Relocate.
- (ffeste_R834, ffeste_R835, ffeste_R836, ffeste_R1226): Don't
- bother calling clear_momentary, nothing was generated.
- (ffeste_R842, ffeste_R843): Update to new com.c interface.
- (ffeste_R1226): Don't try to stuff error_mark_node's DECL_INITIAL.
- (ffeste_terminate_2): When checking enabled, make sure all blocks
- and statements have been ended.
- * ste.h (ffeste_R803, ffeste_R804, ffeste_R805, ffeste_R806):
- These now take ffestw block argument.
- (ffeste_terminate_2): When checking enabled, it's a function, not
- a macro.
- * stw.h (struct _ffestw_): New variable for IFTHEN.
- (ffestw_ifthen_fake_else, ffestw_set_ifthen_fake_else): New
- accessor macros.
- * symbol.c, symbol.h: Support new ASSIGN'ed-to info.
-
- * com.c: Clean up commentary per GNU coding standards.
-
- * bld.h (ffebld_size, ffebld_size_known): Canonize.
-
- * version.c: Bump version.
-
-Sun Apr 11 21:33:33 1999 Mumit Khan <khan@xraylith.wisc.edu>
-
- * g77spec.c (lang_specific_driver): Check whether MATH_LIBRARY is
- null to decide whether to use it.
-
-Wed Apr 7 09:47:09 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * ansify.c (die): Specify void argument.
-
- * intdoc.c (family_name, dumpgen, dumpspec, dumpimp,
- argument_info_ptr, argument_info_string, argument_name_ptr,
- argument_name_string, elaborate_if_complex,
- elaborate_if_maybe_complex, elaborate_if_real, print_type_string):
- Const-ify a char*.
- (main): Mark parameter `argv' with ATTRIBUTE_UNUSED.
- (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, cc_pair, descriptions, summaries): Const-ify a char*.
-
-Mon Apr 5 11:57:54 1999 Donn Terry (donn@interix.com)
-
- * Make-lang.in (HOST_CFLAGS): compute dynamically.
-
-Mon Apr 5 02:11:23 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix bugs exposed by configuring with --enable-checking:
- * com.c (ffecom_do_entry_, ffecom_expr_, ffecom_arg_ptr_to_expr,
- ffecom_list_expr, ffecom_list_ptr_to_expr, finish_function,
- pop_f_function_context, store_parm_decls, poplevel): Handle
- error_mark_node properly.
- * ste.c (ffeste_begin_iterdo_, ffeste_end_iterdo_): Ditto.
- * version.c: Bump version.
-
-Sat Apr 3 23:57:56 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Fix up docs for -fset-g77-defaults, and
- describe how internal consistency checking now happens.
- (Should have been done for EGCS version 1.1.)
-
-Sat Apr 3 23:29:33 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, g77.texi, lang-options.h, news.texi, top.c:
- Make -fno-emulate-complex the default, as COMPLEX support
- in the back end is now believed to be working.
-
- * version.c: Bump version.
-
-Fri Apr 2 13:33:16 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: -malign-double now works.
- Give URL for alignment-testing package.
- * news.texi: -malign-double now works.
-
-Fri Apr 2 12:49:12 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Funding GNU Fortran): Dude's got a web page.
- * root.texi: Ditto.
-
-Tue Mar 30 12:04:11 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * sta.c (ffesta_ffebad_1sp, ffesta_ffebad_1st, ffesta_ffebad_2st):
- Const-ify a char*.
-
- * sta.h (ffesta_ffebad_1sp, ffesta_ffebad_1st, ffesta_ffebad_2st):
- Likewise.
-
- * stb.c (ffestb_local_u_): Likewise.
- (ffestb_do, ffestb_dowhile, ffestb_else, ffestb_elsexyz,
- ffestb_else3_, ffestb_endxyz, ffestb_goto, ffestb_let,
- ffestb_type, ffestb_type1_, ffestb_varlist, ffestb_R423B,
- ffestb_R522, ffestb_R528, ffestb_R542, ffestb_R834, ffestb_R835,
- ffestb_R838, ffestb_R841, ffestb_R1102, ffestb_blockdata,
- ffestb_R1212, ffestb_R1228, ffestb_V009, ffestb_module,
- ffestb_R809, ffestb_R810, ffestb_R10014_, ffestb_R10015_,
- ffestb_R10018_, ffestb_R1107, ffestb_R1202, ffestb_R12026_,
- ffestb_S3P4, ffestb_V012, ffestb_V014, ffestb_V025, ffestb_V0255_,
- ffestb_V020, ffestb_dimlist, ffestb_dummy, ffestb_R524,
- ffestb_R547, ffestb_decl_chartype, ffestb_decl_dbltype,
- ffestb_decl_gentype, ffestb_decl_recursive, ffestb_decl_entsp_2_,
- ffestb_decl_func_, ffestb_V003, ffestb_V016, ffestb_V027,
- ffestb_decl_R539): Likewise.
-
- * stb.h (_ffestb_args_): Likewise.
-
- * stc.c (ffestc_subr_binsrch_, ffestc_subr_is_present_,
- ffestc_subr_speccmp_, ffestc_R904, ffestc_R907): Likewise.
-
- * std.c (ffestd_R1001dump_1005_1_, ffestd_R1001dump_1005_2_,
- ffestd_R1001dump_1005_3_, ffestd_R1001dump_1005_4_,
- ffestd_R1001dump_1005_5_, ffestd_R1001dump_1010_1_,
- ffestd_R1001dump_1010_2_, ffestd_R1001dump_1010_3_,
- ffestd_R1001dump_1010_4_, ffestd_R1001dump_1010_5_): Likewise.
-
- * ste.c (ffeste_begin_iterdo_, ffeste_subr_file_): Likewise.
-
- * sts.c (ffests_printf_1D, ffests_printf_1U, ffests_printf_1s,
- ffests_printf_2Us, ffests_puts, ffests_puttext): Likewise.
-
- * sts.h (ffests_printf_1D, ffests_printf_1U, ffests_printf_1s,
- ffests_printf_2Us, ffests_puts, ffests_puttext): Likewise.
-
- * stt.c (ffestt_exprlist_drive, ffestt_implist_drive,
- ffestt_tokenlist_drive): Add prototype arguments.
-
- * stt.h (ffestt_exprlist_drive, ffestt_implist_drive,
- ffestt_tokenlist_drive): Likewise.
-
- * stu.c (ffestu_dummies_transition_): Likewise.
- (ffestu_sym_end_transition): Const-ify a char*.
-
- * stw.c (ffestw_display_state, ffestw_new, ffestw_pop): Add
- prototype arguments.
-
- * stw.h (ffestw_display_state, ffestw_new, ffestw_pop): Likewise.
-
- * version.c (ffe_version_string): Const-ify a char*.
-
- * version.h (ffe_version_string): Likewise.
-
-Sat Mar 27 13:00:43 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (_ffebad_message_, ffebad_string_, ffebad_message_,
- ffebad_bufputs_, ffebad_bufputs_, ffebad_start_, ffebad_string,
- ffebad_finish): Const-ify a char*.
-
- * bld.c (ffebld_op_string_, ffebld_op_string): Likewise.
-
- * bld.h (ffebld_op_string): Likewise.
-
- * com.c (ffecom_arglist_expr_, ffecom_build_f2c_string_,
- ffecom_debug_kludge_, ffecom_f2c_make_type_,
- ffecom_get_appended_identifier_, ffecom_get_identifier_,
- ffecom_gfrt_args_): Likewise.
- (ffecom_convert_narrow_, ffecom_convert_widen_): Add prototype.
- (builtin_function, ffecom_gfrt_name_, ffecom_gfrt_argstring_,
- ffecom_arglist_expr_, ffecom_build_f2c_string_,
- ffecom_debug_kludge_, ffecom_f2c_make_type_,
- ffecom_get_appended_identifier_, ffecom_get_external_identifier_,
- ffecom_get_identifier_, ffecom_decl_field,
- ffecom_get_invented_identifier, lang_print_error_function,
- skip_redundant_dir_prefix, read_name_map, print_containing_files):
- Const-ify a char*.
- (savestring): Remove, use `xstrdup' instead.
-
- * com.h (ffecom_decl_field, ffecom_get_invented_identifier):
- Const-ify a char*.
-
- * data.c (ffebld, ffedata_gather_): Make explicitly static.
-
- * expr.c (ffeexpr_isdigits_, ffeexpr_percent_,
- ffeexpr_reduced_concatenate_, ffeexpr_nil_real_,
- ffeexpr_nil_number_, ffeexpr_nil_number_period_,
- ffeexpr_nil_number_real_, ffeexpr_token_real_,
- ffeexpr_token_number_, ffeexpr_token_number_period_,
- ffeexpr_token_number_real_): Const-ify a char*.
-
- * fini.c (xspaces): Likewise.
-
- * global.c (ffeglobal_type_string_): Likewise.
- (ffeglobal_drive): Protoize.
- (ffeglobal_proc_def_arg): Const-ify a char*.
-
- * global.h (ffeglobal_drive): Protoize.
- (ffeglobal_proc_def_arg): Const-ify a char*.
-
- * implic.c (ffeimplic_none, ffeimplic_peek_symbol_type):
- Likewise.
-
- * implic.h (ffeimplic_peek_symbol_type): Likewise.
-
- * info.c (ffeinfo_basictype_string_, ffeinfo_kind_message_,
- ffeinfo_kind_string_, ffeinfo_kindtype_string_,
- ffeinfo_where_string_, ffeinfo_basictype_string,
- ffeinfo_kind_message, ffeinfo_kind_string,
- ffeinfo_kindtype_string, ffeinfo_where_string): Likewise.
-
- * info.h (ffeinfo_basictype_string, ffeinfo_kind_message,
- ffeinfo_kind_string, ffeinfo_kindtype_string,
- ffeinfo_where_string): Likewise.
-
- * intrin.c (_ffeintrin_name_, _ffeintrin_gen_, _ffeintrin_spec_,
- _ffeintrin_imp_, ffeintrin_check_, ffeintrin_cmp_name_,
- ffeintrin_fulfill_specific, ffeintrin_init_0,
- ffeintrin_is_actualarg, ffeintrin_is_intrinsic,
- ffeintrin_name_generic, ffeintrin_name_implementation,
- ffeintrin_name_specific): Likewise.
-
- * intrin.h (ffeintrin_is_intrinsic, ffeintrin_name_generic,
- ffeintrin_name_implementation, ffeintrin_name_specific): Likewise.
-
- * lex.c (ffelex_type_string_, ffelex_token_new_character,
- ffelex_token_new_name, ffelex_token_new_names,
- ffelex_token_new_number): Likewise.
-
- * lex.h (ffelex_token_new_character, ffelex_token_new_name,
- ffelex_token_new_names, ffelex_token_new_number): Likewise.
-
- * malloc.c (malloc_types_, malloc_pool_new, malloc_new_inpool_,
- malloc_new_zinpool_): Likewise.
-
- * malloc.h (malloc_new_inpool_, malloc_new_zinpool_,
- malloc_pool_new): Likewise.
-
- * name.c (ffename_space_drive_global, ffename_space_drive_symbol):
- Protoize.
-
- * name.h (ffename_space_drive_global, ffename_space_drive_symbol):
- Likewise.
-
- * symbol.c (ffesymbol_state_name_, ffesymbol_attr_name_,
- ffesymbol_attrs_string): Const-ify a char*.
- (ffesymbol_drive, ffesymbol_drive_sfnames): Protoize.
- (ffesymbol_state_string): Const-ify a char*.
-
- * symbol.h (ffesymbol_attrs_string): Likewise.
- (ffesymbol_drive, ffesymbol_drive_sfnames): Protoize.
- (ffesymbol_state_string): Const-ify a char*.
-
- * target.c (ffetarget_layout): Likewise.
-
- * target.h (ffetarget_layout): Likewise.
-
-1999-03-25 Zack Weinberg <zack@rabi.columbia.edu>
-
- * Make-lang.in: Remove all references to g77.o/g77.c.
- Link g77 from gcc.o.
-
-1999-03-21 Manfred Hollstein <manfred@s-direktnet.de>
-
- * Makefile.in (g77$(exeext)): Depend on intl.o. Link in intl.o.
-
-Wed Mar 17 11:39:44 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Editorial fix.
-
-Mon Mar 15 17:12:07 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, g77.texi, news.texi: Editorial fixes.
-
-Sat Mar 13 17:51:55 1999 Craig Burley <craig@jcb-sc.com>
-
- Fix 19990313-0.f, 19990313-1.f, 19990313-2.f, 19990313-3.f:
- * bad.def (FFEBAD_NOCANDO): New error code for internal use only.
- * expr.c (ffeexpr_collapse_convert): If FFEBAD_NOCANDO returned
- by convertor, just return original expr.
- * target.h: Return FFEBAD_NOCANDO for (usually) 64-bit
- conversions that aren't yet working properly.
- * news.texi: Explain.
-
- * version.c: Bump version.
-
-Sat Mar 13 14:26:55 1999 Craig Burley <craig@jcb-sc.com>
-
- * RELEASE-PREP: New file, lists things to do for a release.
-
- * Make-lang.in, bugs.texi, bugs0.texi, g77.texi, g77install.texi,
- install0.texi, news.texi, news0.texi: Accommodate new doc
- architecture.
- Consolidate news items. Don't describe old news items in
- various generated docs.
- Don't describe FSF-g77 installation stuff in various EGCS-g77
- generated docs.
- Move description of AUTOMATIC to more suitable location.
- * root.texi: New file for new doc architecture.
-
-Thu Mar 11 17:32:55 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Add AUTOMATIC to list of unsupported extensions.
-
-Sat Mar 6 02:28:35 1999 Craig Burley <craig@jcb-sc.com>
-
- Warn about non-Y2K-compliant intrinsics:
- * bad.def (FFEBAD_INTRINSIC_Y2KBAD): New diagnostic.
- * intrin.def (FFEINTRIN_impDATE, FFEINTRIN_impIDATE_vxt):
- Use new DEFIMPY macro to flag these as non-Y2K-compliant.
- * intdoc.c (DEFIMPY): Support new Y2K macro.
- * intrin.h (DEFIMPY): Ditto.
- * intrin.c (DEFIMPY): Ditto.
- (ffeintrin_fulfill_generic, ffeintrin_fulfill_specific):
- Warn about invocation of non-Y2K-compliant intrinsic.
- * com-rt.def (FFECOM_gfrtDATE, FFECOM_gfrtVXTIDATE):
- Rename external procedure names, to keep previously-
- compiled (sans-new-warnings) code from linking to
- new library.
- * g77.texi: Document all this stuff.
- * news.texi: Spread the joy.
- * version.c: Bump version.
-
-Fri Mar 5 13:22:44 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Relocate IDATE (VXT) fix: we put it in 1.1.2
- so describe it there, instead of under 1.2.
-
-Wed Mar 3 00:57:56 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: IDATE (VXT) fixed to return year as 0..99.
-
-Wed Mar 3 00:43:49 1999 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Add remaining changes pending from Dave Love.
-
-Wed Mar 3 00:38:42 1999 Craig Burley <craig@jcb-sc.com>
-
- * bugs.texi, news.texi: Conditionalize cross-references
- on non-html processing, providing temporary HTML "links".
-
- * g77.texi: Fix up a reference.
-
-Wed Mar 3 00:12:31 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi, bugs.texi: Delete fixed bugs, make one
- of them into the appropriate news item.
-
-Wed Mar 3 00:05:52 1999 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Copy over 1.1.2 news.
-
-1999-03-02 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi (Bug Reporting): Clarify whether to use -E.
- Clarify other instructions.
-
-1999-02-27 Craig Burley <craig@jcb-sc.com>
-
- * lang-specs.h: Fix specs to pass `-ax' as well as `-a' option.
-
-1999-02-26 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (STAT_func, STAT_subr,
- FSTAT_func, FSTAT_subr, LSTAT_func, LSTAT_subr):
- Properly order array elements. Specify N/A return values.
-
-1999-02-26 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (DATE_AND_TIME): Explain that VALUES(7) holds
- seconds, and VALUES(8), therefore, milliseconds.
-
-1999-02-26 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Clarify IOSTAT= fix.
-
-1999-02-25 Richard Henderson <rth@cygnus.com>
-
- * lang-specs.h: Define __FAST_MATH__ when appropriate.
-
-1999-02-25 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Clarify/index lack of run-time allocation for
- concatenation.
-
-1999-02-25 Andreas Jaeger <aj@arthur.rhein-neckar.de>
-
- * f/intdoc.in: Add missing `,' after cross references.
-
-1999-02-20 Craig Burley <craig@jcb-sc.com>
-
- * Make-lang.in (f77.install-common, f77.install-info,
- f77.install-man, f77.uninstall): Use `$(prefix)/lang-f77'
- instead of `lang-f77' for flag file, to be sure of a
- writable directory, and remove the flag file after each
- operation to keep things clean.
-
-1999-02-20 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Properly attribute Priest document; clarify
- that it is in the .ps version of the Goldberg document.
-
-1999-02-19 Craig Burley <craig@jcb-sc.com>
-
- * bugs0.texi, bugs.texi, install0.texi, g77install.texi,
- news0.texi, news.texi: Update copyright dates.
- Clarify which files are source, which are derived,
- and remind maintainers where copyright dates are sourced.
- * BUGS, INSTALL, NEWS: Regenerated.
-
-1999-02-19 Craig Burley <craig@jcb-sc.com>
-
- * global.c (ffeglobal_ref_progunit_): Warn about a function
- definition that disagrees with the type of a previous reference.
- Improve commentary. Fix a couple of minor bugs. Clean up
- some code.
- * news.texi: Spread the joy.
-
-1999-02-18 Craig Burley <craig@jcb-sc.com>
-
- * expr.c (ffeexpr_finished_): Disallow non-default INTEGER
- as argument for FILEINT and FILEASSOC as lhs.
- * news.texi: Document fix.
- * version.c: Bump.
-
-1999-02-18 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi: Clarify -fno-globals vs. -Wno-globals.
-
-1999-02-18 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (LOG10): Fix typo.
-
-1999-02-17 Ulrich Drepper <drepper@cygnus.com>
-
- * intdoc.in: Fix typo.
-
-1999-02-17 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi, intdoc.in: Document Y2K and some other known
- limitations.
- * intrin.def (DTIME, FDATE): Fix capitalization of
- case-sensitive forms of these intrinsics' names.
-
-1999-02-17 Dave Love <fx@gnu.org>
-
- * intdoc.in: Say `common' logarithm for log10.
-
-1999-02-16 Ulrich Drepper <drepper@cygnus.com>
-
- * g77.texi: Add missing @ in email addresses.
-
-1999-02-15 Craig Burley <craig@jcb-sc.com>
-
- * *.*: Delete my (old) email address in most places, change it
- in a few.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Bump.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * version.c: Bump for 1998-10-02 change (forgot to do this
- before).
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * lang-specs.h, g77.1, g77.texi, news.texi: Recognize `.FOR'
- and `.FPP' as well as `.for' and `.fpp'.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (LOG10): Fix description.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * news.texi: Mention fix for SIGNAL invocation circa egcs-1.1.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * g77.texi, g77install.texi, bugs.texi, g77install.texi: Clean
- up and improve indexing, and some other areas of docs.
-
-1999-02-14 Craig Burley <craig@jcb-sc.com>
-
- * intdoc.in (MCLOCK8, TIME8): Warn about lower range on
- 32-bit systems.
-
-Sat Feb 6 18:02:17 1999 Jeffrey A Law (law@cygnus.com)
-
- * g77.texi: Update email addresses.
-
-Wed Feb 3 22:50:17 1999 Marc Espie <Marc.Espie@liafa.jussieu.fr>
-
- * Make-lang.in (g77$(exeext)): Get choose-temp.o, pexecute.o and
- mkstemp.o from libiberty.
-
-1999-02-01 Zack Weinberg <zack@rabi.columbia.edu>
-
- * top.c: Don't define ffe_is_ident_. Don't process
- -f(no-)ident here.
- * top.h: Remove declaration of ffe_is_ident_ and macros
- ffe_is_ident() and ffe_set_is_ident().
- * lex.c: Use flag_no_ident instead of ffe_is_ident().
-
-Sun Jan 31 20:34:29 1999 Zack Weinberg <zack@rabi.columbia.edu>
-
- * lang-specs.h: Map -Qn to -fno-ident.
-
-Tue Jan 5 22:12:41 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (g77.o): Depend on prefix.h.
-
-Fri Nov 27 13:10:32 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * fini.c: Rename variable `spaces' to `xspaces' to avoid
- conflicting with function `spaces' from libiberty.
-
- * g77spec.c: Don't prototype libiberty functions.
- * malloc.c: Likewise.
-
-1998-11-20 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Assorted minor changes.
-
-1998-11-19 Dave Love <d.love@dl.ac.uk>
-
- * bugs.texi: Formatting changes from Craig.
-
- * intdoc.in: Terminate some @xrefs with `,'.
-
-1998-11-19 Manfred Hollstein <manfred@s-direktnet.de>
-
- * Make-lang.in (mandir): Replace all uses of $(mandir) by $(man1dir).
-
-Mon Nov 9 23:15:39 1998 Jeffrey A Law (law@cygnus.com)
-
- * g77.texi, news.texi: Updates from Craig.
-
-Sun Nov 8 17:47:56 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Makefile.in (INCLUDES): Add "-I$(srcdir)/../../include".
-
-Sat Nov 7 15:58:54 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * g77spec.c: Don't include gansidecl.h.
- * output.j: Likewise.
-
-1998-11-04 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Small formatting/indexing fixes.
-
-Mon Oct 12 20:41:59 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * bad.c (ffebad_finish): Change type of variable `c' to unsigned
- char, change type of variable `s' to unsigned char *.
-
- * com.c (ffecom_symbol_null_): Add missing initializers.
-
- * fini.c (MAXNAMELEN): Undef it before defining.
-
- * implic.c (ffeimplic_lookup_): Change type of parameter `c' to
- unsigned char.
-
- * intrin.c (ffeintrin_init_0): Cast the argument of ctype macros
- to (unsigned char).
-
- * lex.c (ffelex_splice_tokens): Change type of variable `p' to
- unsigned char *.
- (ffelex_token_name_from_names): Cast the argument of
- `ffelex_is_firstnamechar' to (unsigned char).
- (ffelex_token_names_from_names): Likewise.
- (ffelex_token_new_name): Likewise.
- (ffelex_token_new_names): Likewise.
-
- * malloc.c (malloc_root_): Add missing initializer.
-
- * stb.c (ffestb_do): Change type of variable `p' to unsigned char *.
- (ffestb_else) Likewise.
- (ffestb_else3_) Likewise.
- (ffestb_endxyz) Likewise.
- (ffestb_goto) Likewise.
- (ffestb_let) Likewise.
- (ffestb_varlist) Likewise.
- (ffestb_R522) Likewise.
- (ffestb_R528) Likewise.
- (ffestb_R834) Likewise.
- (ffestb_R835) Likewise.
- (ffestb_R838) Likewise.
- (ffestb_R1102) Likewise.
- (ffestb_blockdata) Likewise.
- (ffestb_R1212) Likewise.
- (ffestb_R810) Likewise.
- (ffestb_R10014_): Cast the argument of `ffelex_is_firstnamechar'
- to (unsigned char).
- (ffestb_V014): Change type of variable `p' to unsigned char *.
- (ffestb_dummy) Likewise.
- (ffestb_R524) Likewise.
- (ffestb_R547) Likewise.
- (ffestb_decl_chartype) Likewise.
- (ffestb_decl_dbltype) Likewise.
- (ffestb_decl_gentype) Likewise.
- (ffestb_decl_entsp_2_) Likewise.
- (ffestb_V027) Likewise.
- (ffestb_decl_R539) Likewise.
-
- * top.c (ffe_decode_option): Mark parameter `argc' with
- ATTRIBUTE_UNUSED.
-
- * where.c (ffewhere_unknown_line_): Add missing initializers.
-
-1998-10-02 Dave Love <d.love@dl.ac.uk>
-
- * com.c (ffecom_expr_intrinsic_): Fix return type for RAND.
-
-Thu Oct 1 10:43:45 1998 Nick Clifton <nickc@cygnus.com>
-
- * lex.c: Replace occurances of HANDLE_SYSV_PRAGMA with
- HANDLE_GENERIC_PRAGMAS.
-
-Mon Sep 28 04:22:00 1998 Jeffrey A Law (law@cygnus.com)
-
- * news.texi: Update from Craig.
-
-1998-09-23 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Additions about `/*', trailing comments and cpp.
-
-1998-09-18 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Various additions and some small fixes.
-
-Thu Sep 10 14:55:44 1998 Kamil Iskra <iskra@student.uci.agh.edu.pl>
-
- * Make-lang.in (f77.install-common): Add missing "else true;".
-
-1998-09-07 Dave Love <d.love@dl.ac.uk>
-
- * ChangeLog.egcs: Deleted. Entries merged here.
-
-1998-09-05 Dave Love <d.love@dl.ac.uk>
-
- * Makefile.in (LDFLAGS): Set from BOOT_LDFLAGS.
- (F771_LDFLAGS): Variable dispensed with.
-
-Fri Sep 4 19:53:34 1998 Craig Burley <burley@gnu.org>
-
- * intdoc.in: Minor editorial tweaks.
-
-Fri Sep 4 18:35:52 1998 Craig Burley <burley@gnu.org>
-
- * lang-options.h: Convert to wrap option and doc string
- in a new macro invocation, FTNOPT, so the nearly identical
- list can be used in FSF-g77.
-
-Fri Sep 4 18:35:52 1998 Craig Burley <burley@gnu.org>
-
- * Makefile.in (fini.o): Don't define USE_HCONFIG here.
- * fini.c: Define USE_HCONFIG here instead, so deps-kinda
- picks up correct dependency.
-
- * Makefile.in (proj-h.o): Fix dependencies list.
-
-Wed Sep 02 09:25:29 1998 Nick Clifton <nickc@cygnus.com>
-
- * lex.c (ffe_lex_hash): Change how HANDLE_PRAGMA and
- HANDLE_SYSV_PRAGMA would be called if they pragma parsing was
- enabled in this code.
- Generate warning messages if unknown pragmas are encountered.
- (pragma_getc): New function: retrieves characters from the
- input stream. Defined when HANDLE_PRAGMA is defined.
- (pragma_ungetc): New function: replaces characters back into the
- input stream. Defined when HANDLE_PRAGMA is defined.
-
-Tue Sep 1 10:00:21 1998 Craig Burley <burley@gnu.org>
-
- * bugs.texi, g77.1, g77.texi, intdoc.in, news.texi: Doc updates
- from Craig.
-
-1998-08-23 Dave Love <d.love@dl.ac.uk>
-
- * g77.texi: Increment `version-g77' and fix a few typos.
-
-Tue Aug 18 21:41:31 1998 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in: Add several "else true" clauses to deal with lame
- systems.
-
-Tue Aug 11 08:12:14 1998 H.J. Lu (hjl@gnu.org)
-
- * Make-lang.in (g77.o): Touch lang-f77 before checking it.
-
-1998-08-09 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (f/g77.dvi): Replace non-working use of texi2dvi
- with explicit use of tex.
- (f77.mostlyclean): Remove TeX index files.
-
- * g77install.texi (Prerequisites): Kluge round TeX lossage with
- hyphen in @value in @code.
-
-Tue Aug 4 16:59:39 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_convert_narrow_, ffecom_convert_widen_):
- Allow conversion from pointer to same-sized integer,
- to fix invoking SIGNAL as a function.
-
-1998-07-26 Dave Love <d.love@dl.ac.uk>
-
- * BUGS, INSTALL, NEWS: Rebuilt.
-
-Sat Jul 25 17:23:55 1998 Craig Burley <burley@gnu.org>
-
- Fix 980615-0.f:
- * stc.c (ffestc_R1229_start): Set info to ANY as well.
-
-Tue Jul 21 04:33:37 1998 Craig Burley <burley@gnu.org>
-
- * g77spec.c (lang_specific_driver): Return unmolested
- command line when --help seen.
- Comment out code that printed g77-specific --help info.
-
-Sat Jul 18 19:16:48 1998 Craig Burley <burley@gnu.org>
-
- * lang-options.h: Fix up doc strings.
- Remove the unimplemented -fdcp-intrinsics-* options.
-
- * str-1t.fin: Change mixed-case spelling of `GoTo' from
- `Goto'.
-
-Thu Jul 16 13:26:36 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_finish_symbol_transform_): Revert change
- of 1998-05-23, as it was too aggressive, in that it
- prevented transformation of (used) functions before
- primary code generation.
-
-1998-07-15 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.texi: Regenerated.
-
-Mon Jul 13 18:45:06 1998 Craig Burley <burley@gnu.org>
-
- * Make-lang.in (f77.rebuilt): Fix to depend on
- build-dir-based, not source-based, g77.info.
-
- * g77.texi: Merge docs with 0.5.24.
- * g77install.texi: Ditto.
-
-Mon Jul 13 18:02:29 1998 Craig Burley <burley@gnu.org>
-
- Cleanups vis-a-vis g77-0.5.24:
- * g77spec.c (lang_specific_driver): Tabify source.
- * top.c (ffe_decode_option): Use fixed macro to set
- internal-checking flag.
- * top.h (ffe_set_is_do_internal_checks): Fix macro.
-
-Mon Jul 13 17:33:44 1998 Craig Burley <burley@gnu.org>
-
- Cleanups vis-a-vis system.h cutover and g77-0.5.24:
- * Makefile.in (fini.o): Define USE_HCONFIG macro
- so source code doesn't have to.
- * fini.c: Don't define USE_HCONFIG here, since
- source code usually shouldn't care about this.
- * ansify.c: Include stddef.h only if we have it.
- * intdoc.c: Ditto.
- * proj.h: Ditto.
-
-Mon Jul 13 17:30:29 1998 Nick Clifton <nickc@cygnus.com>
-
- * lang-options.h: Format changed to work with --help support added
- to gcc/toplev.c
-
-Mon Jul 13 11:54:03 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_push_tempvar): Replace kludge that
- munged back-end globals directly with proper calls
- to push_topmost_sequence and pop_topmost_sequence.
-
-1998-07-12 Dave Love <d.love@dl.ac.uk>
-
- * version.c: Bump version.
-
-Sat Jul 11 19:24:32 1998 Craig Burley <burley@gnu.org>
-
- Fix 980616-0.f:
- * equiv.c (ffeequiv_offset_): Don't crash on various
- possible ANY operands.
-
-Sat Jul 11 18:24:37 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_expr_) [FFEBLD_opCONTER]: Die if padding
- for constant is nonzero.
-
- * com.c (__eprintf): Delete this function, it is obsolete.
-
-1998-07-09 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.in (HOSTNM_func, HOSTNM_subr): Update last change.
-
-Thu Jul 9 00:45:59 1998 Craig Burley <burley@gnu.org>
-
- Fix debugging of CHARACTER*(*), etc., which requires
- emitting debug info on types like `ftnlen':
- * com.c (ffecom_start_progunit_): Don't bother
- resetting "invented" flag for identifier.
- (ffecom_transform_equiv_): Don't bother zeroing
- "ignored" flag for decl.
- (pushdecl): No longer set "ignored", "used", or
- "suppressed debug" flags for decls having "invented"
- identifiers.
-
-1998-07-06 Mike Stump <mrs@wrs.com>
-
- * Make-lang.in (f77.stage?): Use mv -f instead of just mv so that
- we can move g77.c.
-
-1998-07-06 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.in (HOSTNM_func, HOSTNM_subr): Note possible need for
- -lsocket.
-
-1998-07-05 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.in: Add entry for DATE_AND_TIME.
-
- * intrin.def: Add implementation for DATE_AND_TIME. Make second
- and third args of SYSTEM_CLOCK optional.
-
- * com.c (ffecom_expr_intrinsic_): New case for DATE_AND_TIME.
-
- * com-rt.def (FFECOM_gfrtSYSTEM_CLOCK): Call G77_system_clock_0,
- not system_clock_.
- (FFECOM_gfrtDATE_AND_TIME): New DEFGFRT.
-
-Wed Jul 1 11:19:13 1998 Craig Burley <burley@gnu.org>
-
- Fix 980701-1.f (which was producing "unaligned trap"
- on an Alpha running GNU/Linux, as predicted):
- * equiv.c (ffeequiv_layout_local_): Don't bother
- coping with pre-padding of entire area while building
- it; do that instead after the building is done, and
- do it by modifying only the modulo field. This covers
- the case of alignment stringency being increased without
- lowering the starting offset, unlike the previous changes,
- and even more elegantly than those.
-
- * target.c (ffetarget_align): Make sure alignments
- are nonzero, just in case.
-
-See ChangeLog.0 for earlier changes.
-
-Local Variables:
-add-log-time-format: current-time-string
-End:
+++ /dev/null
-Mon Jun 29 09:47:33 1998 Craig Burley <burley@gnu.org>
-
- Fix 980628-*.f:
- * bld.h: New `pad' field and accessor macros for
- ACCTER, ARRTER, and CONTER ops.
- * bld.c (ffebld_new_accter, ffebld_new_arrter,
- ffebld_new_conter_with_orig): Initialize `pad' field
- to zero.
- * com.c (ffecom_transform_common_): Include initial
- padding (aka modulo aka offset) in size calculation.
- Copy initial padding value into FFE initialization expression
- so the GBE transformation of that expression includes it.
- Make array low bound 0 instead of 1, for consistency.
- (ffecom_transform_equiv_): Include initial
- padding (aka modulo aka offset) in size calculation.
- Copy initial padding value into FFE initialization expression
- so the GBE transformation of that expression includes it.
- Make array low bound 0 instead of 1, for consistency.
- (ffecom_expr_, case FFEBLD_opACCTER): Delete unused `size'
- variable.
- Track destination offset separately, allowing for
- initial padding.
- Don't bother setting initial PURPOSE offset if zero.
- Include initial padding in size calculation.
- (ffecom_expr_, case FFEBLD_opARRTER): Allow for
- initial padding.
- Include initial padding in size calculation.
- Make array low bound 0 instead of 1, for consistency.
- (ffecom_finish_global_): Make array low bound 0 instead
- of 1, for consistency.
- (ffecom_notify_init_storage): Copy `pad' field from old
- ACCTER to new ARRTER.
- (ffecom_notify_init_symbol): Ditto.
- * data.c (ffedata_gather_): Initialize `pad' field in new
- ARRTER to 0.
- (ffedata_value_): Ditto.
- * equiv.c (ffeequiv_layout_local_): When lowering start
- of equiv area, extend lowering to maintain needed alignment.
- * target.c (ffetarget_align): Handle negative offset correctly.
-
- * global.c (ffeglobal_pad_common): Warn about nonzero
- padding only the first time its seen.
- If new padding larger than old, update old.
- (ffeglobal_save_common): Use correct type for size throughout.
- * global.h: Use correct type for size throughout.
- (ffeglobal_common_pad): New macro.
- (ffeglobal_pad): Delete this unused and broken macro.
-
-Sat Jun 27 12:18:33 1998 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in (g77): Depend on mkstemp.o. Link in mkstemp.o.
-
-Fri Jun 26 11:54:19 1998 Craig Burley <burley@gnu.org>
-
- * g77spec.c (lang_specific_driver): Put `-lg2c' in
- front of any `-lm' that is seen.
-
-Wed Jun 24 01:01:23 1998 Jeffrey A Law (law@cygnus.com)
-
- * g77spec.c (lang_specific_driver): Revert last change.
-
-Mon Jun 22 23:12:05 1998 H.J. Lu (hjl@gnu.org)
-
- * Make-lang.in (G77STAGESTUFF): Add g77.c.
-
-Fri Jun 19 07:54:40 1998 H.J. Lu (hjl@gnu.org)
-
- * g77spec.c (lang_specific_driver): Check n_infiles before
- appending args.
-
-Mon Jun 15 23:39:24 1998 Craig Burley <burley@gnu.org>
-
- * Make-lang.in (f/g77.info): Use -f when removing
- pre-existing Info files, if any. (This rm command
- can go away once makeinfo has been changed to delete
- .info-N files beyond the last one it creates.)
-
- * Make-lang.in ($(srcdir)/f/intdoc.texi): Compile
- using $(INCLUDES) macro to get the new hconfig.h
- and system.h headers.
-
-Mon Jun 15 22:21:57 1998 Craig Burley <burley@gnu.org>
-
- Cutover to system.h:
- * Make-lang.in:
- * Makefile.in:
- * ansify.c:
- * bad.c:
- * bld.c:
- * com.c:
- * com.h:
- * expr.c:
- * fini.c:
- * g77spec.c:
- * implic.c:
- * intdoc.c:
- * intrin.c:
- * lex.c:
- * lex.h:
- * parse.c:
- * proj.c:
- * proj.h:
- * src.c:
- * src.h:
- * stb.c:
- * ste.c:
- * target.c:
- * top.c:
- * system.j: New file.
-
- Use toplev.h where appropriate:
- * Make-lang.in:
- * Makefile.in:
- * bad.c:
- * bld.c:
- * com.c:
- * lex.c:
- * ste.c:
- * top.c:
- * toplev.j: New file.
-
- Conditionalize all dumping/reporting routines so they don't
- get built for gcc/egcs:
- * bld.c:
- * bld.h:
- * com.c:
- * equiv.c:
- * equiv.h:
- * sta.c:
- * stt.c:
- * stt.h:
- * symbol.c:
- * symbol.h:
-
- Use hconfig.h instead of config.h where appropriate:
- * Makefile.in (proj-h.o): Compile with -DUSE_HCONFIG.
- * fini.c: Define USE_HCONFIG before including proj.h.
-
- * Makefile.in (deps-kinda): Redirect stderr to stdout,
- to eliminate diagnostics vis-a-vis g77spec.c.
-
- * Makefile.in: Regenerate dependencies via deps-kinda.
-
- * lex.c (ffelex_file_fixed, ffelex_file_free): Eliminate
- apparently spurious warnings about uninitialized variables
- `c', `column', and so on.
-
-Sat Jun 13 03:13:18 1998 Craig Burley <burley@gnu.org>
-
- * g77spec.c (lang_specific_driver): Print out egcs
- version info first, to be compatible with what some
- test facilities expect.
-
-Wed Jun 10 13:17:32 1998 Dave Brolley <brolley@cygnus.com>
-
- * top.h (ffe_decode_option): New argc/argv interface.
- * top.c (ffe_decode_option): New argc/argv interface.
- * parse.c (yyparse): New argc/argv interface for ffe_decode_option.
- * com.c (lang_decode_option): New argc/argv interface.
-
-Sun Jun 7 14:04:34 1998 Richard Henderson <rth@cygnus.com>
-
- * com.c (lang_init_options): New function.
- * top.c (ffe_decode_option): Remove all trace of -fset-g77-defaults.
- Set ffe_is_do_internal_checks_ with -version.
- * lang-options.h: Likewise.
- * lang-specs.h: Likewise.
-
-Fri Jun 5 15:53:17 1998 Per Bothner <bothner@cygnus.com>
-
- * g77spec.c (lang_specific_pre_link, lang_specific_extra_ofiles):
- Define - update needed by gcc.c change.
-
-Mon Jun 1 19:37:42 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_init_0): Fix setup of INTEGER(KIND=7)
- pointer type.
- * info.c (ffeinfo_type): Don't crash on null type.
- * expr.c (ffeexpr_fulfill_call_): Don't special-case
- %LOC(expr) or LOC(expr).
- Delete FFEGLOBAL_argsummaryPTR.
- * global.c, global.h: Delete FFEGLOBAL_argsummaryPTR.
-
-Thu May 28 21:32:18 1998 Craig Burley <burley@gnu.org>
-
- Restore circa-0.5.22 capabilities of `g77' driver:
- * Make-lang.in (g77spec.o): Depend on f/version.h.
- (g77version.o): New rule to compile g77 version info.
- (g77$(exeext)): Depend on and link in g77version.o.
- * g77spec.c: Rewrite to be more like 0.5.22 version
- of g77.c, making filtering of command line smarter
- so mixed Fortran and C (etc.) can be compiled, verbose
- version info can be obtained, etc.
- * lang-specs.h (f77-version): New "language" to support
- "g77 -v" command under new gcc 2.8 regime.
- * lex.c (ffelex_file_fixed): If -fnull-version, just
- substitute a "source file" that prints out version info.
- * top.c, top.h: Support -fnull-version.
-
- * lang-specs.h: Use "%O" instead of OO macro to specify
- object extension. Remove old stringizing cruft.
-
- * Make-lang.in (g77.c, g77spec.o, g77.o, g77$(exeext),
- g77-cross$(exeext), f771,
- $(srcdir)/f/g77.info, $(srcdir)/f/g77.dvi,
- $(srcdir)/f/intdoc.texi,
- f77.install-common, f77.install-info, f77.install-man,
- f77.uninstall, $(G77STAGESTUFF), f77.stage1, f77.stage2,
- f77.stage3, f77.stage4, f77.distdir): Don't do anything
- unless user specified "f77" or "F77" in $LANGUAGES either
- during configuration or explicitly. For convenience of
- various tests and to work around lack of the assignment
- "LANGUAGES=$(BOOT_LANGUAGES)" in the "make stage1" command
- of "make bootstrap" in gcc, use a touch file named "lang-f77"
- to communicate whether this is the case.
-
- * Make-lang.in (F77_FLAGS_TO_PASS): Delete this macro,
- replace with minimal expansion of its former self in
- each of the two instances where it was used.
-
- * Makefile.in (HOST_CC): Delete this definition.
-
- * com.c (index, rindex): Delete these declarations.
-
- * proj.h: (isascii): Delete this.
-
- * Make-lang.in (f77.install-common): Warn if `f77-install-ok'
- flag-file exists, since it no longer triggers any activity.
-
- Rename libf2c.a and f2c.h to libg2c.a and g2c.h,
- normalize and simplify g77/libg2c build process:
- * Make-lang.in: Remove all support for overwriting
- /usr/bin/f77 etc., or whatever the actual names are
- via $(prefix) and $(local_prefix). (g++ overwrites
- /usr/bin/c++, but then it's often the only C++ compiler
- on the system; f77 often exists on systems that are
- installing g77.)
- (f77.realclean): Remove obsolete target.
- (g77.c, g77$(exeext)): Minor changes to look more like g++'s
- stuff.
- (f771): Now built with srcdir=gcc/f, not srcdir=gcc, to be
- more like g++ and such.
- (f/Makefile): Removed, as g++ doesn't need this rule.
- (f77.install-common): No longer install f77, etc.
- (f77.install-man): No longer install f77.1.
- (f77.uninstall): No longer uninstall f77, f77.1, etc.
- (f77.stage1, f77.stage2, f77.stage3, f77.stage4): Do work
- only if "f77" appears in $(LANGUAGES).
- (Note: gcc's Makefile.in's bootstrap target should set
- LANGUAGES=$(BOOT_LANGUAGES) when making the stage1 target.)
- * Makefile.in: Update vis-a-vis gcc/cp/Makefile.in.
- (none): Remove.
- (g77-only): Relocate.
- (all.indirect, f771, *.o): Now assumes current directory
- is this dir (gcc/f), not the parent directory.
- (TAGS): Remove "echo 'parse.y,0' >> TAGS ;" line.
- * config-lang.in: Delete commented-out code.
- Fix stagestuff definition. Add more stuff to
- diff_excludes definition. Don't create any directories.
- Set outputs to f/Makefile, to get variable substition
- to happen (what does that really do, anyway?!).
- * g77spec.c: Rename libf2c to libg2c.
-
- * com.h: Remove all of the gcc back-end decls,
- since egcs should have all of them correct.
-
- * com.c: Include "proj.h" before anything else,
- as that's how things are supposed to work.
- * ste.c: Ditto.
-
- * bad.c: Include "flags.j" here, since some diagnostics
- check flag_pedantic_errors.
-
- * Makefile.in (f/*.o): Rebuild dependencies via
- deps-kinda.
-
- * output.j: New source file.
- * Make-lang.in (F77_SRCS): Update accordingly.
- * Makefile.in (OUTPUT_H): Ditto.
- (deps-kinda): Ditto.
- * com.c: Include "output.j" here.
- * lex.c: Ditto.
-
-Mon May 25 03:34:42 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_expr_): Fix D**I and Z**I cases to
- not convert (DOUBLE PRECISION) D and (DOUBLE COMPLEX) Z
- to INTEGER. (This is dead code here anyway.)
-
-Sat May 23 06:32:52 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_finish_symbol_transform_): Don't transform
- statement (nested) functions, to avoid gcc compiling them
- and thus producing linker errors if they refer to undefined
- external functions. But warn if they're unused and -Wunused.
- * bad.def (FFEBAD_SFUNC_UNUSED): New diagnostic.
-
-Wed May 20 12:12:55 1998 Craig Burley <burley@gnu.org>
-
- * Version 0.5.23 released.
-
-Tue May 19 14:52:41 1998 Craig Burley <burley@gnu.org>
-
- * bad.def (FFEBAD_OPEN_UNSUPPORTED, FFEBAD_INQUIRE_UNSUPPORTED,
- FFEBAD_READ_UNSUPPORTED, FFEBAD_WRITE_UNSUPPORTED,
- FFEBAD_QUAD_UNSUPPORTED, FFEBAD_BLOCKDATA_STMT,
- FFEBAD_TRUNCATING_CHARACTER, FFEBAD_TRUNCATING_HOLLERITH,
- FFEBAD_TRUNCATING_NUMERIC, FFEBAD_TRUNCATING_TYPELESS,
- FFEBAD_TYPELESS_OVERFLOW): Change these from warnings
- to errors.
-
-Tue May 19 14:51:59 1998 Craig Burley <burley@gnu.org>
-
- * Make-lang.in (f77.install-info, f77.uninstall):
- Use install-info as appropriate.
-
-Tue May 19 12:56:54 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_init_0): Rename xargc to f__xargc,
- in accord with same-dated change to f/runtime.
-
-Fri May 15 10:52:49 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_convert_narrow_, ffecom_convert_widen_):
- Be even more persnickety in checking for internal bugs.
- Also, if precision isn't changing, just return the expr.
-
- * expr.c (ffeexpr_token_number_): Call
- ffeexpr_make_float_const_ to make an integer.
- (ffeexpr_make_float_const_): Handle making an integer.
-
- * intrin.c (ffeintrin_init_0): Distinguish between
- crashes on bad arg base and kind types.
-
-Fri May 15 01:44:22 1998 Mumit Khan <khan@xraylith.wisc.edu>
-
- * Make-lang.in (f77.mostlyclean): Add missing exeext.
-
-Thu May 14 13:30:59 1998 Craig Burley <burley@gnu.org>
-
- * Make-lang.in (f/expr.c): Now depends on f/stamp-str.
- * expr.c: Use ffestrOther in place of ffeexprDotdot_.
- * str-ot.fin: Add more keywords for expr.c.
-
- * intdoc.c (dumpimp): Trivial fix.
-
- * com.c (ffecom_expr_): Add ltkt variable for clarity.
-
-Wed May 13 13:05:34 1998 Craig Burley <burley@gnu.org>
-
- * Make-lang.in (G77STAGESTUFF): Add g77.o, g77spec.o,
- and g77version.o.
- (f77.clean): Add removal of g77.c, g77.o, g77spec.o,
- and g77version.o.
- (f77.distclean): Delete removal of g77.c.
-
-Thu Apr 30 18:59:43 1998 Jim Wilson <wilson@cygnus.com>
-
- * Make-lang.in (g77.info, g77.dvi, BUGS, INSTALL, NEWS): Put -o
- option before input file.
-
-Tue Apr 28 09:23:10 1998 Craig Burley <burley@gnu.org>
-
- Fix 980427-0.f:
- * global.c (ffeglobal_ref_progunit_): When transitioning
- from EXT to FUNC, discard hook, since the decl, if any, is
- probably wrong.
-
-Sun Apr 26 09:05:50 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_char_enhance_arg_): Wrap the upper bound
- (the PARM_DECL specifying the length of the CHARACTER*(*)
- dummy arg) in a variable_size invocation, to prevent
- dwarf2out.c crashing when compiling code with -g.
-
-Sat Apr 18 15:26:57 1998 Jim Wilson <wilson@cygnus.com>
-
- * g77spec.c (lang_specific_driver): New argument in_added_libraries.
- New local added_libraries. Increment count when add library to
- arglist.
-
-Sat Apr 18 05:03:21 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_check_size_overflow_): Ignore overflow
- as well if dummy argument.
-
-Fri Apr 17 17:18:04 1998 Craig Burley <burley@gnu.org>
-
- * version.h: Get rid of the overly large headers
- here too, as done in version.c.
-
-Tue Apr 14 15:51:37 1998 Dave Brolley <brolley@cygnus.com>
-
- * com.c (init_parse): Now returns char* containing filename;
-
-Tue Apr 14 14:40:40 1998 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_start_progunit_): Mark function decl
- as used, to avoid spurious warning (-Wunused) for ENTRY.
-
-Tue Apr 14 14:19:34 1998 Craig Burley <burley@gnu.org>
-
- * sta.c (ffesta_second_): Check for CASE DEFAULT
- as well as CASE, or it won't be recognized.
-
-Thu Apr 9 00:18:44 1998 Dave Brolley (brolley@cygnus.com)
-
- * com.c (finput): New variable.
- (init_parse): Handle !USE_CPPLIB.
- (finish_parse): New function.
- (lang_init): No longer declare finput.
-
-Sat Apr 4 17:45:01 1998 Richard Henderson <rth@cygnus.com>
-
- * com.c (ffecom_expr_): Revert Oct 22 change. Instead take a WIDENP
- argument so that we can respect the signedness of the original type.
- (ffecom_init_0): Do sizetype initialization first.
-
-1998-03-28 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (f771$(exeext)): Fix typo.
-
-1998-03-24 Martin von Loewis <loewis@informatik.hu-berlin.de>
-
- * com.c (lang_print_xnode): New function.
-
-Mon Mar 23 21:20:35 1998 Craig Burley <burley@gnu.org>
-
- * version.c: Reduce to a one-line file, like
- gcc's version.c, since there's really no content
- there.
-
-Mon Mar 23 11:58:43 1998 Craig Burley <burley@gnu.org>
-
- * bugs.texi: Various updates.
-
- * com.c (ffecom_tree_canonize_ptr_): Fix up spacing a bit.
-
-Sun Mar 22 00:50:42 1998 Nick Clifton <nickc@cygnus.com>
- Geoff Noer <noer@cygnus.com>
-
- * Makefile.in: Various fixes for building cygwin32 native toolchains.
- * Make-lang.in: Likewise.
-
-Mon Mar 16 21:20:35 1998 Craig Burley <burley@gnu.org>
-
- * expr.c (ffeexpr_sym_impdoitem_): Don't blindly
- reset symbol info after calling ffesymbol_error,
- to avoid crash.
-
-Mon Mar 16 15:38:50 1998 Craig Burley <burley@gnu.org>
-
- * Version 0.5.22 released.
-
-Mon Mar 16 14:36:02 1998 Craig Burley <burley@gnu.org>
-
- Make -g work better for ENTRY:
- * com.c (ffecom_start_progunit_): Master function
- for ENTRY-laden procedure is not really invented,
- so it can be debugged.
- (ffecom_do_entry_): Push/set/pop lineno for each
- entry point.
-
-Sun Mar 15 05:48:49 1998 Craig Burley <burley@gnu.org>
-
- * intrin.def: Fix spelling of mixed-case form
- of `CPU_Time' (was `Cpu_Time').
-
-Thu Mar 12 13:50:21 1998 Craig Burley <burley@gnu.org>
-
- * lang-options.h: Sort all -f*-intrinsics-* options,
- for consistency with other g77 versions.
-
-Thu Mar 12 09:39:40 1998 Manfred Hollstein <manfred@s-direktnet.de>
-
- * lang-specs.h: Properly put brackets around array elements in initializer.
-
-1998-03-09 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in: Set CONFIG_SITE to a non-existent file since
- /dev/null loses with bash 2.0/autoconf 2.12. Put
- F77_FLAGS_TO_PASS before CC.
-
-Sun Mar 8 16:35:34 1998 Craig Burley <burley@gnu.org>
-
- * intrin.def: Use tabs instead of blanks more
- consistently (excepting DEFGEN section for now).
-
-Wed Mar 4 17:38:21 1998 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in: Remove more references to libf77.
-
-Tue Mar 3 10:52:35 1998 Manfred Hollstein <manfred@s-direktnet.de>
-
- * g77.texi: Use @url for citing URLs.
-
-Sat Feb 28 15:24:38 1998 Craig Burley <burley@gnu.org>
-
- * intrin.def: Make CPU_TIME's arg generic real to be just
- like SECOND_subr.
-
-Fri Feb 20 12:45:53 1998 Craig Burley <burley@gnu.org>
-
- * expr.c (ffeexpr_token_arguments_): Make sure
- outer exprstack isn't null.
-
-1998-02-16 Dave Love <d.love@dl.ac.uk>
-
- * Makefile.in (f/fini): Don't use -W -Wall with HOST_CC.
-
-Fri Feb 13 00:14:56 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * com.c (type_for_mode): Add explicit braces to avoid ambiguous `else'.
-
- * expr.c (ffeexpr_type_combine): Likewise.
- (ffeexpr_reduce_): Likewise.
- (ffeexpr_declare_parenthesized_): Likewise.
-
- * src.c (ffesrc_strcmp_1ns2i): Likewise.
- (ffesrc_strcmp_2c): Likewise.
- (ffesrc_strncmp_2c): Likewise.
-
- * stb.c (ffestb_halt1_): Likewise.
- (ffestb_R90910_): Likewise.
- (ffestb_R9109_): Likewise.
-
- * stc.c (ffestc_R544_equiv_): Likewise.
-
- * std.c (ffestd_subr_copy_easy_): Likewise.
- (ffestd_R1001dump_): Likewise.
- (ffestd_R1001dump_1005_1_): Likewise.
- (ffestd_R1001dump_1005_2_): Likewise.
- (ffestd_R1001dump_1005_3_): Likewise.
- (ffestd_R1001dump_1005_4_): Likewise.
- (ffestd_R1001dump_1005_5_): Likewise.
- (ffestd_R1001dump_1010_2_): Likewise.
-
- * ste.c (ffeste_R840): Likewise.
-
- * sts.c (ffests_puttext): Likewise.
-
- * symbol.c (ffesymbol_check_token_): Likewise.
-
- * target.c (ffetarget_real1): Likewise.
- (ffetarget_real2): Likewise.
-
-Wed Feb 11 01:44:48 1998 Richard Henderson (rth@cygnus.com)
-
- * com.c (ffecom_ptr_to_expr) [FFEBLD_opARRAYREF]: Do upper - lower
- in the native type, so as to properly handle negative indices.
-
-Tue Feb 3 20:13:05 1998 Richard Henderson <rth@cygnus.com>
-
- * config-lang.in: Remove references to runtime/.
-
-Sun Feb 1 12:43:49 1998 J"orn Rennecke <amylaar@cygnus.co.uk>
-
- * com.c (ffecom_tree_canonize_ptr_): Place bitsizetype typed expr
- as first agument in MULT_EXPR.
- Use bitsize_int (0L, 0L) as zero for bitsizes.
- (ffecom_tree_canonize_ref_):
- Use bitsize_int (0L, 0L) as zero for bitsizes.
- (ffecom_init_0): Use set_sizetype.
-
-Sun Feb 1 02:26:58 1998 Richard Henderson <rth@cygnus.com>
-
- * runtime directory -- moved into "libf2c" in the toplevel
- directory.
- * Make-lang.in: Remove all runtime related stuff.
-
-Sun Jan 25 12:32:15 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * Make-lang.in (f77.stage1): Depend on stage1-start so parallel
- make works better.
- * (f77.stage2): Likewise for stage2-start.
- * (f77.stage3): Likewise for stage3-start.
- * (f77.stage4): Likewise for stage4-start.
-
-Sat Jan 17 21:28:08 1998 Pieter Nagel <pnagel@epiuse.co.za>
-
- * Makefile.in (FLAGS_TO_PASS): Pass down gcc_include_dir and
- local_prefix to sub-make invocations.
-
-Tue Jan 13 22:07:54 1998 Jeffrey A Law (law@cygnus.com)
-
- * lang-options.h: Add missing options.
-
-Sun Jan 11 02:14:47 1998 Craig Burley <burley@gnu.org>
-
- Support FORMAT(I<1+2>) (constant variable-FORMAT
- expressions):
- * bad.def (FFEBAD_FORMAT_VARIABLE): New diagnostic.
- * std.c (ffestd_R1001rtexpr_): New function.
- (ffestd_R1001dump_, ffestd_R1001dump_1005_1_,
- ffestd_R1001dump_1005_2_, ffestd_R1001dump_1005_3_,
- ffestd_R1001dump_1005_4_, ffestd_R1001dump_1005_5_,
- ffestd_R1001dump_1010_2_, ffestd_R1001dump_1010_3_,
- ffestd_R1001dump_1010_4_, ffestd_R1001dump_1010_5_):
- Use new function instead of ffestd_R1001error_.
-
- * stb.c (ffestb_R10014_, ffestb_R10016_, ffestb_R10018_,
- ffestb_R100110_): Restructure `for' loop for style.
-
- Fix 970626-2.f by not doing most back-end processing
- when current_function_decl is an ERROR_MARK, and by
- making that the case when its type would be an ERROR_MARK:
- * com.c (ffecom_start_progunit_, finish_function,
- lang_printable_name, start_function,
- ffecom_finish_symbol_transform_): Test for ERROR_MARK.
- * std.c (ffestd_stmt_pass_): Don't do any downstream
- processing if ERROR_MARK.
-
- * Make-lang.in (f77.install-common): Don't install, and
- don't uninstall existing, Info files if f/g77.info
- doesn't exit. (This is a somewhat modified version
- of an egcs patch on 1998-01-07 12:05:51 by Bruno Haible
- <bruno@linuix.mathematik.uni-karlsruhe.de>.)
-
-Fri Jan 9 19:09:07 1998 Craig Burley <burley@gnu.org>
-
- Fix -fpedantic combined with `F()' invocation,
- also -fugly-comma combined with `IARGC()' invocation:
- * bad.def (FFEBAD_NULL_ARGUMENT_W): New diagnostic.
- * expr.c (ffeexpr_finished_): Don't reject null expressions
- in the argument-expression context -- let outer context
- handle that.
- (ffeexpr_token_arguments_): Warn about null expressions
- here if -fpedantic (as appropriate).
- Obey -fugly-comma for only external-procedure invocations.
- * intrin.c (ffeintrin_check_): No longer ignore explicit
- omitted trailing args.
-
-Tue Dec 23 14:58:04 1997 Craig Burley <burley@gnu.org>
-
- * intrin.c (ffeintrin_fulfill_generic): Don't generate
- FFEBAD_INTRINSIC_TYPE for CHARACTER*(*) intrinsic.
-
- * com.c (ffecom_gfrt_basictype):
- (ffecom_gfrt_kindtype):
- (ffecom_make_gfrt_):
- (FFECOM_rttypeVOIDSTAR_): New return type `void *', for
- the SIGNAL intrinsic.
- * com-rt.def (FFECOM_rttypeSIGNAL): Now returns `void *'.
- * intdoc.c: Replace `p' kind specifier with `7'.
- * intrin.c (ffeintrin_check_, ffeintrin_init_0): Replace
- `p' kind specifier with `7'.
- * intrin.def (FFEINTRIN_impLOC, FFEINTRIN_impSIGNAL_func,
- FFEINTRIN_impSIGNAL_subr): Replace `p' specifier with `7'.
- Also, SIGNAL now returns a `void *' status, not `int'.
-
- Improve run-time diagnostic for "PRINT '(I1', 42":
- * com.c (ffecom_char_args_x_): Renamed from ffecom_char_args_,
- which is now a macro (to avoid lots of changes to other code)
- with new arg, ffecom_char_args_with_null_ being another new
- macro to call same function with different value for new arg.
- This function now appends a null byte to opCONTER expression
- if the new arg is TRUE.
- (ffecom_arg_ptr_to_expr): Support NULL length pointer.
- * ste.c (ffeste_io_cilist_):
- (ffeste_io_icilist_): Pass NULL length ptr for
- FORMAT expression, so null byte gets appended where
- feasible.
- * target.c (ffetarget_character1):
- (ffetarget_concatenate_character1):
- (ffetarget_substr_character1):
- (ffetarget_convert_character1_character1):
- (ffetarget_convert_character1_hollerith):
- (ffetarget_convert_character1_integer4):
- (ffetarget_convert_character1_logical4):
- (ffetarget_convert_character1_typeless):
- (ffetarget_hollerith): Append extra phantom null byte as
- part of FFETARGET-NULL-BYTE kludge.
-
- * intrin.def (FFEINTRIN_impCPU_TIME): Point to
- FFECOM_gfrtSECOND as primary run-time routine.
-
-Mon Dec 22 12:41:07 1997 Craig Burley <burley@gnu.org>
-
- * intrin.c (ffeintrin_init_0): Remove duplicate
- check for `!'.
-
-Fri Dec 19 00:12:01 1997 Richard Henderson <rth@cygnus.com>
-
- * com.c (ffecom_sym_transform_): Assumed arrays have no upper bound.
-
-Mon Dec 15 17:35:35 1997 Richard Henderson <rth@cygnus.com>
-
- * com.c (ffecom_type_vardesc_): Vardesc.dims is a `ftnlen*'.
-
-Sun Dec 14 02:49:58 1997 Craig Burley <burley@gnu.org>
-
- * intrin.c (ffeintrin_init_0): Fix up indentation a bit.
- Fix bug that prevented checking of arguments other
- than the first.
-
- * intdoc.c: Fix up indentation a bit.
-
-Tue Dec 9 16:20:57 1997 Richard Henderson <rth@cygnus.com>
-
- * com.c (ffecom_type_vardesc_): Vardesc.dims is a `ftnlen*'.
-
-Tue Dec 2 09:57:16 1997 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in (f77.clean): Remove g77.c.
-
-Mon Dec 1 19:12:36 1997 Craig Burley <burley@gnu.org>
-
- * intrin.c (ffeintrin_check_): Fix up indentation a bit more.
-
-Mon Dec 1 16:21:08 1997 Craig Burley <burley@gnu.org>
-
- * com.c (ffecom_arglist_expr_): Crash if non-supplied
- optional arg isn't passed as an address.
- Pass null pointer explicitly, instead of via ffecom routine.
- If incoming argstring is NULL, substitute pointer to "0".
- Recognize '0' as ending the usual arg stuff, just like '\0'.
-
-Sun Nov 30 22:22:22 1997 Craig Burley <burley@gnu.org>
-
- * intdoc.c: Minor fix-ups.
-
- * intrin.c (ffeintrin_check_): Fix up indentation a bit.
-
- * intrin.def: Fix up spacing a bit.
-
-Tue Nov 25 15:33:28 1997 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in (f77.all.build): Add $(exeext) to binary files.
- (f77.all.cross, f77.start.encap): Simliarly.
-
-Fri Nov 21 09:35:20 1997 Fred Fish <fnf@cygnus.com>
-
- * Make-lang.in (stmp-f2c.h): Move inclusion of F77_FLAGS_TO_PASS
- to before override of CC so that the override works.
-
-Thu Nov 20 00:58:14 1997 H.J. Lu (hjl@gnu.ai.mit.edu)
-
- * Make-lang.in (f77.install-info): Depend on f77.info.
-
-1997-11-17 Dave Love <d.love@dl.ac.uk>
-
- * com.c (ffecom_arglist_expr_): Pass null pointers for optional
- args which aren't supplied.
-
-Sun Nov 16 21:45:43 1997 H.J. Lu (hjl@gnu.ai.mit.edu)
-
- * Make-lang.in (f77.install-info): Depend on f77.info.
-
-1997-11-14 Dave Love <d.love@dl.ac.uk>
-
- * intrin.def: Supply gfrt for CPU_TIME. Generalize arg types of
- INT2, INT8, per doc.
-
-1997-11-06 Dave Love <d.love@dl.ac.uk>
-
- * intrin.def: Allow non-integer args for INT2 and INT8 (per
- documentation).
-
-Sun Nov 2 19:49:51 1997 Richard Henderson <rth@cygnus.com>
-
- * com.c (ffecom_expr_): Only use TREE_TYPE argument for simple
- arithmetic; convert types as necessary; recurse with target tree type.
-
-Tue Oct 28 02:21:25 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * lang-options.h: Add -fgnu-intrinsics-* and
- -fbadu77-intrinsics-* options.
-
-Sun Oct 26 02:36:21 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (lang_print_error_function): Fix to more
- reliably notice when the diagnosed region changes.
-
-Sat Oct 25 23:43:36 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix 950327-0.f:
- * sta.c, sta.h (ffesta_outpooldisp): New function.
- * std.c (ffestd_stmt_pass_): Don't kill NULL pool.
- (ffestd_R842): If pool already preserved, save NULL
- for pool, because it should be killed only once.
-
- * malloc.c [MALLOC_DEBUG]: Put initializer for `name'
- component in braces, to avoid compiler warning.
-
-Wed Oct 22 11:37:41 1997 Richard Henderson <rth@cygnus.com>
-
- * com.c (ffecom_expr_): Take an new arg TREE_TYPE that if non-null
- specifies the type in which to do the calculation. Change all callers.
- [FFEBLD_opARRAYREF]: Force the index expr to use sizetype.
-
-Thu Oct 16 02:04:08 1997 Paul Koning <pkoning@xedia.com>
-
- * Make-lang.in (stmp-f2c.h): Don't configure the runtime
- directory if LANGUAGES does not include f77.
-
-Mon Oct 13 12:12:41 1997 Richard Henderson <rth@cygnus.com>
-
- * Make-lang.in (g77*): Copied from cp/Make-lang.in g++*.
- * g77spec.c: New file, mostly copied from g++spec.c
- * g77.c: Removed.
-
-Fri Oct 10 13:00:48 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * ste.c (ffeste_begin_iterdo_): Fix loop setup so iteration
- variable is modified only after the #iterations is calculated;
- otherwise if the iteration variable is aliased to any of the
- operands in the start, end, or increment expressions, the
- wrong #iterations might be calculated.
-
- * com.c (ffecom_save_tree): Fix indentation.
-
-Mon Oct 6 14:15:03 1997 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in (f77.mostlyclean): Clean up stuff in the
- object tree too.
- (f77.clean, f77.distclean, f77.maintainer-clean): Likewise.
-
-1997-10-05 Dave Love <d.love@dl.ac.uk>
-
- * intrin.def: Make SECOND_subr's arg generic real for people
- porting from Cray and making everything double precision.
-
-Wed Oct 1 01:45:36 1997 Philippe De Muyter <phdm@info.ucl.ac.be>
-
- * g77.c (pexecute, main): Use unlink, not remove.
-
-Mon Sep 29 16:18:21 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * stu.c (ffestu_list_exec_transition_,
- ffestu_dummies_transition_): Specify `bool' type for
- `in_progress' variables.
-
- * com.h (assemble_string): Declare this routine (instead
- of #include'ing "output.h" from gcc) to eliminate warnings
- from lex.c.
-
-Mon Sep 29 10:37:07 1997 Jeffrey A Law (law@cygnus.com)
-
- * intdoc.c (main): Remove unused attribute for main's arguments.
-
-Sun Sep 28 01:47:17 1997 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in (G77_FLAGS_TO_PASS): Pass down RANLIB, RANLIB_TEST
- and AR instead of the _FOR_TARGET versions.
-
-Tue Sep 23 00:39:57 1997 Alexandre Oliva <oliva@dcc.unicamp.br>
-
- * Make-lang.in: install.texi was renamed to g77install.texi
- * install0.texi: Likewise.
-
-Fri Sep 19 01:12:27 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c (ffeexpr_reduced_eqop2_):
- (ffeexpr_reduced_relop2_): Minor fixes to diagnostic code.
-
- * fini.c (main): Change return type to `int'.
-
-Thu Sep 18 17:31:38 1997 Jeffrey A Law (law@cygnus.com)
-
- * proj.h (FFEPROJ_BSEARCH): Delete all references.
- (FFEPROJ_STRTOUL): Likewise.
- * proj.c (bsearch): Compile this if no bsearch is provided by the
- host system.
- (strtoul): Similarly.
-
- * g77install.texi: Renamed from install.texi
- * g77.texi: Corresponding changes.
-
- * fini.c (main): Return type is int.
-
- * com.c (lang_printable_name): Use verbosity argument.
-
-Thu Sep 18 16:08:40 1997 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in: Fix merge problems.
-
-Wed Sep 17 10:47:08 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com-rt.def (FFECOM_gfrtDSIGN, FFECOM_gfrtISIGN,
- FFECOM_gfrtSIGN): Add second argument.
-
- * expr.c (ffeexpr_cb_comma_c_): Trivial fixes.
-
-Sun Sep 14 21:01:23 1997 Jeffrey A Law (law@cygnus.com)
-
- * Make-lang.in: Various changes to build info files
- in the object tree rather than the source tree.
-
- * proj.h: Include ctype.h.
-
-Sun Sep 14 12:35:20 1997 Fred Fish (fnf@ninemoons.com)
-
- * proj.h (isascii): Provide a default definition if none is available.
-
-Thu Sep 11 19:26:10 1997 Dave Love <d.love@dl.ac.uk>
-
- * config-lang.in: Remove the messages about possible build problems.
-
-Wed Sep 10 16:39:47 1997 Jim Wilson <wilson@cygnus.com>
-
- * Make-lang.in (LN, LN_S): New macros, use where appropriate.
-
-Tue Sep 9 13:20:40 1997 Jim Wilson <wilson@cygnus.com>
-
- * g77.c (pexecute, doit): Add checks for __CYGWIN32__.
-
-Tue Sep 9 01:59:35 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Version 0.5.21 released.
-
-Tue Sep 9 00:31:01 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * intdoc.c (dumpem): Put appropriate commentary in
- output file, so readers know it isn't source.
-
-Wed Aug 27 20:32:03 1997 Jeffrey A Law (law@cygnus.com)
-
- * top.c (ffe_decode_option): Turn on flag_move_all_moveables
- and flag_reduce_all_givs.
-
-Wed Aug 27 08:08:25 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * proj.h: Always #include "config.j" first, to pick up
- gcc's configuration.
- * com.c: Change bcopy() and bzero() calls to memcpy()
- and memset() calls, to make more of g77 ANSI C.
-
-1997-08-26 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in ($(srcdir)/f/runtime/configure,
- $(srcdir)/f/runtime/libU77/configure): Fix for when srcdir isn't
- relative.
-
-Tue Aug 26 05:59:21 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * ansify.c (main): Make sure readers of stdout know
- it's derived from stdin; omit comment text; get source
- line numbers in future stderr output to be correct.
-
-Tue Aug 26 01:36:01 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix 970825-0.f:
- * stb.c (ffestb_R5284_): Allow OPEN_PAREN after closing
- SLASH as well as NAME.
-
-Mon Aug 25 23:48:17 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Changes to allow g77 docs to be built entirely from scratch
- using any ANSI C compiler, not requiring GNU C:
- * Make-lang.in ($(srcdir)/f/intdoc.texi): "Pipe" new
- location of intrinsic documentation data base, f/intdoc.in,
- through new `ansify' program to append `\n\' to quoted
- newlines, into f/intdoc.h0. Do appropriate cleanups. Explain.
- (f77.mostlyclean): Add f/ansify and f/intdoc.h0 to cleanups.
- * f/ansify.c: New program.
- * f/intdoc.c: Fix so it conforms to ANSI C.
- #include f/intdoc.h0 instead of f/intdoc.h.
- Avoid some warnings.
- * f/intdoc.h, f/intdoc.in: Rename the former to the latter; no
- changes made to the content in this patch!
- * f/intrin.h (ffeintrinFamily): Fix to conform to ANSI C.
-
-Mon Aug 25 23:24:32 1997 H.J. Lu (hjl@gnu.ai.mit.edu)
-
- * Make-lang.in ($(srcdir)/f/runtime/configure,
- $(srcdir)/f/runtime/libU77/configure, f77.mostlyclean,
- f77.clean, f77.distclean, f77.maintainer-clean, f77.realclean):
- Handle absolute pathname of $(srcdir).
- (stmp-f2c.h): New.
- (include/f2c.h, f/runtime/Makefile, f/runtime/libF77/Makefile,
- f/runtime/libI77/Makefile, f/runtime/libU77/Makefile): Only
- depend on stmp-f2c.h.
- (f77.maintainer-clean): Don't make itself.
-
-Sun Aug 24 17:00:27 1997 Jim Wilson <wilson@cygnus.com>
-
- * Make-lang.in (f77.install-info): Don't cd into srcdir. Add srcdir
- to filenames. Use sed to extract base filename for install.
-
-Sun Aug 24 06:52:48 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix up g77 compiler data base for libf2c routines:
- * com-rt.def (FFECOM_gfrtSIGNAL): Change return type to
- FTNINT to match actual code.
-
- * com.c (ffecomRttype_): Replace FFECOM_rttypeINT_ with
- FFECOM_rttypeFTNINT_.
- Add and fix up comments.
- (ffecom_make_gfrt_, ffecom_gfrt_basictype,
- ffecom_gfrt_kindtype): Replace FFECOM_rttypeINT_ with
- FFECOM_rttypeFTNINT_; add FFECOM_rttypeDOUBLEREAL_.
-
-Thu Aug 21 13:15:29 1997 Jim Wilson <wilson@cygnus.com>
-
- * Make-lang.in (f77): Delete f77-runtime.
- (f77.all.build, f77.all.cross, f77.rest.encap): Add f77-runtime.
-
-Wed Aug 20 17:18:40 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * global.c (ffeglobal_ref_progunit_): It's okay to have
- a different CHARACTER*n length for a reference if the
- existing length is for another reference, not a definition.
-
-Wed Aug 20 16:36:59 1997 Jim Wilson <wilson@cygnus.com>
-
- * intdoc.texi: Readd generated file.
-
-Mon Aug 18 14:27:18 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix 970814-0.f:
- * global.c (ffeglobal_new_progunit_): Distinguish
- between previously defined, versus inferred, filewide
- when it comes to diagnostics.
-
- Fix 970816-1.f:
- * global.c (ffeglobal_ref_progunit_): Change BDATA into EXT
- right at the beginning, so EXTERNAL FOO followed later
- by SUBROUTINE FOO is not diagnosed.
-
- Fix 970813-0.f:
- * com-rt.def (FFECOM_gfrtALARM): Returns `integer', not
- `void'.
-
-Mon Aug 18 09:01:54 1997 Jeffrey A Law (law@cygnus.com)
-
- * Makefile.in (F77_OBJS): Re-alphabetize.
- * Make-lang.in (F77_SRCS): Likewise.
-
-Sun Aug 17 08:35:11 1997 Jeffrey A Law (law@cygnus.com)
-
- * INSTALL: Rebuilt.
- * install.texi: Remove "Object File Differences" section. Remove
- all references to zzz.o failing comparison tests.
- * version.c, version.h: Renamed from zzz.c and zzz.h. Remove
- date and time stamps so a 3 stage build reports no differences.
- * Make-lang.in: Corresponding changes.
- * Makefile.in: Likewise.
- * g77.c, parse.c: Likewise.
-
- * intdoc.texi: Remove generated file from distribution.
-
-Sun Aug 17 03:32:44 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix up problems when virtual memory exhausted:
- * malloc.c (malloc_new_): Use gcc's xmalloc(), so we
- print a nicer message when malloc returns no memory.
- (malloc_resize_): Ditto for xrealloc().
-
- * Make-lang.in, Makefile.in: Comment out lines containing
- just formfeeds.
-
-Sat Aug 16 19:41:33 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_make_gfrt_): For rttypeREAL_F2C_, return
- double_type_node; for rttypeREAL_GNU_, return
- _real_type_node.
-
-1997-08-13 Dave Love <d.love@dl.ac.uk>
-
- * config-lang.in (diff_excludes): Add some hints about known
- problematic platforms.
-
-1997-08-13 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.h: Document `alarm'.
-
-Tue Aug 12 10:23:02 1997 Jeffrey A Law (law@cygnus.com)
-
- * config-lang.in: Don't demand the backend patch.
- * com.c (lang_printable_name): Second argument is now an int. Don't
- store into the value of the second argument.
- * top.c (ffe_decode_option): Temporarily disable setting
- of "Toon" loop options until we figure out how to address
- them.
-
-Mon Aug 11 23:18:35 1997 Jeffrey A Law (law@cygnus.com)
-
- * g77-0.5.21-19970811 Imported.
- This file describes changes to the front end necessary to make
- it work with egcs.
-
-Mon Aug 11 21:19:22 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in ($(RUNTIMESTAGESTUFF)): Add
- f/runtime/stamp-lib.
-
-Mon Aug 11 01:52:03 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_build_complex_constant_): Go with the
- new build_complex() approach used in gcc-2.8.
-
- * com.c (ffecom_sym_transform_): Don't set
- DECL_IN_SYSTEM_HEADER for a tree node that isn't
- a VAR_DECL, which happens when var is in common!
-
- * com.c (ffecom_expr_intrinsic_) (case FFEINTRIN_impALARM):
- No need to test codegen_imp -- there's only one valid here.
-
- * intrin.def (FFEINTRIN_impALARM): Specify `Status' argument
- as write-only.
-
-Fri Aug 8 05:40:23 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Substantial changes to accommodate distinctions among
- run-time routines that support intrinsics, and between
- routines that compute and return the same type vs. those
- that compute one type and return another (or `void'):
- * com-rt.def: Specify new return type REAL_F2C_ instead
- of many DOUBLE_, COMPLEX_F2C_ instead of COMPLEX_, and
- so on.
- Clear up the *BES* routines "once and for all".
- * com.c: New return types.
- (ffecom_convert_narrow_, ffecom_convert_widen_):
- New functions that are "safe" variants of convert(),
- to catch errors that ffecom_expr_intrinsic_() now
- no longer catches.
- (ffecom_arglist_expr_): Ensure arguments are not
- converted to narrower types.
- (ffecom_call_): Ensure return value is not converted
- to a wider type.
- (ffecom_char_args_): Use new ffeintrin_gfrt_direct()
- routine.
- (ffecom_expr_intrinsic_): Simplify how run-time
- routine is selected (via `gfrt' only now; lose the
- redundant `ix' variable).
- Eliminate the `library' label; any code that doesn't
- return directly just `break's out now with `gfrt'
- set appropriately.
- Set `gfrt' to default choice initially, either a
- fast direct form or, if not available, a slower
- indirect-callable form.
- (ffecom_make_gfrt_): No longer need to do special
- check for complex; it's built into the new return-type
- regime.
- (ffecom_ptr_to_expr): Use new ffeintrin_gfrt_indirect()
- routine.
- * intrin.c, intrin.h: `gfrt' field replaced with three fields,
- so it is easier to provide faster direct-callable and
- GNU-convention indirect-callable routines in the future.
- DEFIMP macro adjusted accordingly, along with all its uses.
- (ffeintrin_gfrt_direct): New function.
- (ffeintrin_gfrt_indirect): Ditto.
- (ffeintrin_is_actualarg): If `-fno-f2c' is in effect,
- require a GNU-callable version of intrinsic instead of
- an f2c-callable version, so indirect calling is still checked.
- * intrin.def: Replace one GFRT field with the three new fields,
- as appropriate for each DEFIMP intrinsic.
-
- * com.c (ffecom_stabilize_aggregate_,
- ffecom_convert_to_complex_): Make these `static'.
-
-Thu Aug 7 11:24:34 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Provide means for front end to determine actual
- "standard" return type for an intrinsic if it is
- passed as an actual argument:
- * com.h, com.c (ffecom_gfrt_basictype,
- ffecom_gfrt_kindtype): New functions.
- (ffecom_gfrt_kind_type_): Replaced with new function.
- All callers updated.
- (ffecom_make_gfrt_): No longer need do anything
- with kind type.
-
- * intrin.c (ffeintrin_basictype, ffeintrin_kindtype):
- Now returns correct type info for specific intrinsic
- (based on type of run-time-library implementation).
-
-Wed Aug 6 23:08:46 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * global.c (ffeglobal_ref_progunit_): Don't reset
- number of arguments just due to new type info,
- so useful warnings can be issued.
-
-1997-08-06 Dave Love <d.love@dl.ac.uk>
-
- * intrin.def: Fix IDATE_vxt argument order.
- * intdoc.h: Likewise.
-
-Thu Jul 31 22:22:03 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * global.c (ffeglobal_proc_ref_arg): If REF/DESCR
- disagreement, DESCR is CHARACTER, and types disagree,
- pretend the argsummary agrees so the message ends up
- being about type disagreement.
- (ffeglobal_proc_def_arg): Ditto.
-
- * expr.c (ffeexpr_token_first_rhs_3_): Set info for LABTOK
- to NONE of everything, to avoid misdiagnosing filewide
- usage of alternate returns.
-
-Sun Jul 20 23:07:47 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_sym_transform_): If type gets set
- to error_mark_node, just return that for transformed symbol.
- (ffecom_member_phase2_): If type gets set to error_mark_node,
- just return.
- (ffecom_check_size_overflow_): Add `dummy' argument to
- flag that type is for a dummy, update all callers.
-
-Sun Jul 13 17:40:53 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix 970712-1.f:
- * where.c (ffewhere_set_from_track): If start point
- is too large, just use initial start point. 0.6 should
- fix all this properly.
-
- Fix 970712-2.f:
- * com.c (ffecom_sym_transform_): Preserve error_mark_node for type.
- (ffecom_type_localvar_): Ditto.
- (ffecom_sym_transform_): If type is error_mark_node,
- don't error-check decl size, because back end responds by
- setting that to an integer 0 instead of error_mark_node.
- (ffecom_transform_common_): Same as earlier fix to _transform_
- in that size is checked by dividing BITS_PER_UNIT instead of
- multiplying.
- (ffecom_transform_equiv_): Ditto.
-
- Fix 970712-3.f:
- * stb.c (ffestb_R10014_): Fix flaky fall-through in error
- test for FFELEX_typeCONCAT by just replicating the code,
- and do FFELEX_typeCOLONCOLON while at it.
-
-1997-07-07 Dave Love <d.love@dl.ac.uk>
-
- * intdoc.h: Add various missing pieces; correct GMTIME, LTIME
- result ordering.
-
- * intrin.def, com-rt.def: Add alarm.
-
- * com.c (ffecom_expr_intrinsic_): Add case for alarm.
-
-Thu Jun 26 04:19:40 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix 970302-3.f:
- * com.c (ffecom_sym_transform_): For sanity-check compare
- of gbe size of local variable to g77 expectation,
- use varasm.c/assemble_variable technique of dividing
- BITS_PER_UNIT out of gbe info instead of multiplying
- g77 info up, to avoid crash when size in bytes is very
- large, and overflows an `int' or similar when multiplied.
-
- Fix 970626-2.f:
- * com.c (ffecom_finish_symbol_transform_): Don't bother
- transforming a dummy argument, to avoid a crash.
- * ste.c (ffeste_R1227): Don't return a value if the
- result decl, or its type, is error_mark_node.
-
- Fix 970626-4.f:
- * lex.c (ffelex_splice_tokens): `-fdollar-ok' is
- irrelevant to whether a DOLLAR token should be made
- from an initial character of `$'.
-
- Fix 970626-6.f:
- * stb.c (ffestb_do3_): DO iteration variable is an
- lhs, not rhs, expression.
-
- Fix 970626-7.f and 970626-8.f:
- * expr.c (ffeexpr_cb_comma_i_1_): Set IMPDO expression
- to have clean info, because undefined rank, for example,
- caused crash on mangled source on UltraSPARC but not
- on Alpha for a series of weird reasons.
- (ffeexpr_cb_close_paren_): If not CLOSE_PAREN, push
- opANY expression onto stack instead of attempting
- to mimic what program might have wanted.
- (ffeexpr_cb_close_paren_): Don't wrap opPAREN around
- opIMPDO, just warn that it's gratuitous.
- * bad.def (FFEBAD_IMPDO_PAREN): New warning.
-
- Fix 970626-9.f:
- * expr.c (ffeexpr_declare_parenthesized_): Must shut down
- parsing in kindANY case, otherwise the parsing engine might
- decide there's an ambiguity.
- (ffeexpr_token_name_rhs_): Eliminate parentypeSUBROUTINE_
- case, so we crash right away if it comes through.
- * st.c, st.h, sta.c, sta.h (ffest_shutdown, ffesta_shutdown):
- New functions.
-
-Tue Jun 24 19:47:29 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_check_size_overflow_): New function
- catches some cases of the size of a type getting
- too large. varasm.c must catch the rest.
- (ffecom_sym_transform_): Use new function.
- (ffecom_type_localvar_): Ditto.
-
-Mon Jun 23 01:09:28 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * global.c (ffeglobal_proc_def_arg): Fix comparison
- of argno to #args.
- (ffeglobal_proc_ref_arg): Ditto.
-
- * lang-options.h, top.c: Rename `-fdebug' to `-fxyzzy',
- since it's an unsupported internals option and some
- poor user might guess that it does something.
-
- * bad.def: Make a warning for each filewide diagnostic.
- Put all filewides together.
- * com.c (ffecom_sym_transform_): Don't substitute
- known global tree for global entities when `-fno-globals'.
- * global.c (ffeglobal_new_progunit_): Don't produce
- fatal diagnostics about globals when `-fno-globals'.
- Instead, produce equivalent warning when `-Wglobals'.
- (ffeglobal_proc_ref_arg): Ditto.
- (ffeglobal_proc_ref_nargs): Ditto.
- (ffeglobal_ref_progunit_): Ditto.
- * lang-options.h, top.c, top.h: New `-fno-globals' option.
-
-Sat Jun 21 12:32:54 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c (ffeexpr_fulfill_call_): Set array variable
- to avoid warning about uninitialized variable.
-
- * Make-lang.in: Get rid of any setting of HOST_* macros,
- since these will break gcc's build!
- * makefile: New file to make building derived files
- easier.
-
-Thu Jun 19 18:19:28 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * g77.c (main): Install Emilio Lopes' patch to support
- Ratfor, and to fix the printing of the version string
- to go to stderr, not stdout.
- * lang-specs.h: Install Emilio Lopes' patch to support
- Ratfor, and patch the result to support picking up
- `*f771' from the `specs' file.
-
-Thu Jun 12 14:36:25 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * storag.c (ffestorag_update_init, ffestorag_update_save):
- Also update parent, in case equivalence processing
- has already eliminated pointers to it via the
- local equivalence info.
-
-Tue Jun 10 14:08:26 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * intdoc.c: Add cross-reference to end of description
- of any generic intrinsic pointing to other intrinsics
- with the same name.
-
- Warn about explicit type declaration for intrinsic
- that disagrees with invocation:
- * expr.c (ffeexpr_paren_rhs_let_): Preserve type info
- for intrinsic functions.
- (ffeexpr_token_funsubstr_): Ditto.
- * intrin.c (ffeintrin_fulfill_generic): Warn if type
- info of fulfilled intrinsic invocation disagrees with
- explicit type info given symbol.
- (ffeintrin_fulfill_specific): Ditto.
- * stc.c (ffestc_R1208_item): Preserve type info
- for intrinsics.
- (ffestc_R501_item): Ditto.
-
-Mon Jun 9 17:45:44 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_expr_intrinsic_): Fix several of the
- libU77/libF77-unix handlers to properly convert their
- arguments.
-
- * com-rt.def (FFECOM_gfrtFSTAT): Append missing "i" to
- arg string.
-
-Fri Jun 6 14:37:30 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_expr_intrinsic_): Have a case statement
- for every intrinsic implementation, so missing ones
- are caught via gcc warnings.
- Don't call ffeintrin_codegen_imp anymore.
- * intrin.c (ffeintrin_fulfill_generic): Remove cg_imp
- stuff from here.
- (ffeintrin_codegen_imp): Delete this function.
- * intrin.def, intrin.h: Remove DEFIMQ stuff from here
- as well.
-
-Thu Jun 5 13:03:07 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * top.c (ffe_decode_option): New -fbadu77-intrinsics-*
- options.
- * top.h: Ditto.
- * intrin.h: New BADU77 family.
- * intrin.c (ffeintrin_state_family): Ditto.
-
- Implement new scheme to track intrinsic names vs. forms:
- * intrin.c (ffeintrin_fulfill_generic),
- (ffeintrin_fulfill_specific), (ffeintrin_is_intrinsic),
- intrin.def: The documented name is now either in the
- generic info or, if no generic, in the specific info.
- For a generic, the specific info contains merely the
- distinguishing form (usually "function" or "subroutine"),
- used for diagnostics about ambiguous references and
- in the documentation.
-
- * intrin.def: Clean up formatting of DEFNAME block.
- Convert many libU77 intrinsics into generics that
- support both subroutine and function forms.
- Put the function forms of side-effect routines into
- the new BADU77 family.
- Make MCLOCK and TIME return INTEGER*4 again, and add
- INTEGER*8 equivalents called MCLOCK8 and TIME8.
- Fix up more status return values to be written and
- insist on them being I1 as well.
- * com.c (ffecom_expr_intrinsic_): Lots of changes to
- support new libU77 intrinsic interfaces.
-
-Mon Jun 2 00:37:53 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_init_0): Pointer type is now INTEGER(KIND=7),
- not INTEGER(KIND=0), since we want to reserve KIND=0 for
- future use.
-
-Thu May 29 14:30:33 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix bugs preventing CTIME(I*4) from working correctly:
- * com.c (ffecom_char_args_): For FUNCREF case, process
- args to intrinsic just as they would be in
- ffecom_expr_intrinsic_.
- * com-rt.def (FFECOM_gfrtCTIME, FFECOM_gfrtTTYNAM): Fix
- argument decls to specify `&'.
-
-Wed May 28 22:19:49 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix gratuitous warnings exposed by dophot aka 970528-1:
- * global.c (ffeglobal_proc_def_arg, ffeglobal_proc_ref_arg):
- Support distinct function/subroutine arguments instead of
- just procedures.
- * global.h: Ditto.
- * expr.c (ffeexpr_fulfill_call_): A SYMTER with kindNONE
- also is a procedure (either function or subroutine).
-
-Mon May 26 20:25:31 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * bad.def: Have several lexer diagnostics refer to
- documentation for people who need more info on what Fortran
- source code is supposed to look like.
-
- * expr.c (ffeexpr_reduced_bool1_), bad.def: New diagnostics
- specific to .NOT. now mention only one operand instead
- of two.
-
- * g77.c: Recognize -fsyntax-only, similar to -c etc.
- (lookup_option): Fix bug that prevented non-`--' options
- from being recognized.
-
-Sun May 25 04:29:04 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * intrin.def (FFEINTRIN_impCTIME): Accept `I*' expression
- for STime instead of requiring `I2'.
-
-Tue May 20 16:14:40 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * symbol.c (ffesymbol_reference): All references to
- standard intrinsics are considered explicit, so as
- to avoid generating basically useless warnings.
- * intrin.c, intrin.h (ffeintrin_is_standard): Returns TRUE
- if intrinsic is standard.
-
-Sun May 18 21:14:59 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com-rt.def: Changed all external names of the
- form `"\([a-z0-9]*\)_' to `"G77_\1_0"' so as to
- allow any name valid as an intrinsic to be used
- as such and as a user-defined external procedure
- name or common block as well.
-
-Thu May 8 13:07:10 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c (ffeexpr_cb_end_notloc_): For %VAL, %REF, and
- %DESCR, copy arg info into new node.
-
-Mon May 5 14:42:17 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- From Uwe F. Mayer <mayer@math.Vanderbilt.Edu>:
- * Make-lang.in (g77-cross): Fix typo in g77.c path.
-
- From Brian McIlwrath <bkm@star.rl.ac.uk>:
- * lang-specs.h: Have g77 pick up options from a section
- labeled `*f771' of the `specs' file.
-
-Sat May 3 02:46:08 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * intrin.def (FFEINTRIN_defSIGNAL): Add optional `Status'
- argument that com.c already expects (per Dave Love).
-
- More changes to support better tracking of (filewide)
- globals, in particular, the arguments to procedures:
- * bad.def (FFEBAD_FILEWIDE_NARGS, FFEBAD_FILEWIDE_NARGS_W,
- FFEBAD_FILEWIDE_ARG, FFEBAD_FILEWIDE_ARG_W): New diagnostics.
- * expr.c (ffebad_fulfill_call_): Provide info on each
- argument to ffeglobal.
- * global.c, global.h (ffeglobal_proc_def_arg,
- ffeglobal_proc_def_nargs, ffeglobal_proc_ref_arg,
- ffeglobal_proc_ref_args): New functions.
- (ffeglobalArgSummary, ffeglobalArgInfo_): New types.
-
-Tue Apr 29 18:35:41 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- More changes to support better tracking of (filewide)
- globals:
- * expr.c (ffeexpr_fulfill_call_): New function.
- (ffeexpr_token_name_lhs_): Call after building procedure
- reference expression. Also leave info field for ANY-ized
- expression alone.
- (ffeexpr_token_arguments_): Ditto.
-
-Mon Apr 28 20:04:18 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Changes to support better tracking of (filewide)
- globals, mainly to avoid crashes due to inlining:
- * bad.def: Go back to quoting intrinsic names,
- (FFEBAD_FILEWIDE_DISAGREEMENT, FFEBAD_FILEWIDE_TIFF,
- FFEBAD_FILEWIDE_TYPE_MISMATCH): New diagnostics.
- (FFEBAD_INTRINSIC_EXPIMP, FFEBAD_INTRINSIC_GLOBAL): Reword
- for clarity.
- * com.c (ffecom_do_entry_, ffecom_start_progunit_,
- ffecom_sym_transform_): Accommodate new FFEGLOBAL_typeEXT
- possibility.
- * expr.c (ffeexpr_sym_lhs_call_, ffeexpr_sym_lhs_extfunc_,
- ffeexpr_sym_rhs_actualarg_, ffeexpr_declare_parenthesized_,
- ffeexpr_paren_rhs_let_, ffeexpr_token_funsubstr_):
- Fill in real kind info instead of leaving NONE where
- appropriate.
- Register references to intrinsics and globals with ffesymbol
- using new ffesymbol_reference function instead of
- ffesymbol_globalize.
- * global.c (ffeglobal_type_string_): New array for
- new diagnostics.
- * global.h, global.c:
- Replace ->init mechanism with ->tick mechanism.
- Move other common-related members into a substructure of
- a union, so the proc substructure can be introduced
- to include members related to externals other than commons.
- Don't complain about ANY-ized globals; ANY-ize globals
- once they're complained about, in any case where code
- generation could become a problem.
- Handle global entries that have NONE type (seen as
- intrinsics), EXT type (seen as EXTERNAL), and so on.
- Keep track of kind and type of externals, both via
- definition and via reference.
- Diagnose disagreements about kind or type of externals
- (such as functions).
- (ffeglobal_ref_intrinsic, ffeglobal_ref_progunit_): New
- functions.
- * stc.c (ffestc_R1207_item, ffestc_R1208_item,
- ffestc_R1219, ffestc_R1226):
- Call ffesymbol_reference, not ffesymbol_globalize.
- * stu.c (ffestu_sym_end_transition,
- ffestu_sym_exec_transition):
- Call ffesymbol_reference, not ffesymbol_globalize.
- * symbol.c (ffesymbol_globalize): Removed...
- (ffesymbol_reference): ...to this new function,
- which more generally registers references to symbols,
- globalizes globals, and calls on the ffeglobal module
- to check globals filewide.
-
- * global.h, global.c: Rename some macros and functions
- to more clearly distinguish common from other globals.
- All callers changed.
-
- * com.c (ffecom_sym_transform_): Trees describing
- filewide globals must be allocated on permanent obstack.
-
- * expr.c (ffeexpr_token_name_lhs_): Don't generate
- gratuitous diagnostics for FFEINFO_whereANY case.
-
-Thu Apr 17 03:27:18 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * global.c: Add support for flagging intrinsic/global
- confusion via warnings.
- * bad.def (FFEBAD_INTRINSIC_EXPIMP,
- FFEBAD_INTRINSIC_GLOBAL): New diagnostics.
- * expr.c (ffeexpr_token_funsubstr_): Ditto.
- (ffeexpr_sym_lhs_call_): Ditto.
- (ffeexpr_paren_rhs_let_): Ditto.
- * stc.c (ffestc_R1208_item): Ditto.
-
-Wed Apr 16 22:40:56 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c (ffeexpr_declare_parenthesized_): INCLUDE
- context can't be an intrinsic invocation either.
-
-Fri Mar 28 10:43:28 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c (ffeexpr_token_arguments_): Make sure top of
- exprstack is operand before dereferencing operand field.
-
- * lex.c (ffelex_prepare_eos_): Fill up truncated
- hollerith token, so crash on null ->text field doesn't
- happen later.
-
- * stb.c (ffestb_R10014_): If NAMES isn't recognized (or
- the recognized part is followed in the token by a
- non-digit), don't try and collect digits, as there
- might be more than FFEWHERE_indexMAX letters to skip
- past to do so -- and the code is diagnosed anyway.
-
-Thu Mar 27 00:02:48 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_sym_transform_): Force local
- adjustable array onto stack.
-
- * stc.c (ffestc_R547_item_object): Don't actually put
- the symbol in COMMON if the symbol has already been
- EQUIVALENCE'd to a different COMMON area.
-
- * equiv.c (ffeequiv_add): Don't actually do anything
- if there's a disagreement over which COMMON area is
- involved.
-
-Tue Mar 25 03:35:19 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_transform_common_): If no explicit init
- of COMMON area, don't actually init it even though
- storage area suggests it.
-
-Mon Mar 24 12:10:08 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * lex.c (ffelex_image_char_): Avoid overflowing the
- column counter itself, as well as the card image.
-
- * where.c (ffewhere_line_new): Cast ffelex_line_length()
- to (size_t) so 255 doesn't overflow to 0!
-
- * stc.c (ffestc_labeldef_notloop_begin_): Don't gratuitously
- terminate loop before processing statement, so block
- doesn't disappear out from under EXIT/CYCLE processing.
- (ffestc_labeldef_notloop_): Has old code from above
- function, instead of just calling it.
-
- * expr.c (ffeexpr_cb_comma_i_4_): Don't skip over
- arbitrary token (such as EOS).
-
- * com.c (ffecom_init_zero_): Handle RECORD_TYPE and
- UNION_TYPE so -fno-zeros works with -femulated-complex.
-
-1997-03-12 Dave Love <d.love@dl.ac.uk>
-
- * intrin.def: New intrinsics INT2, INT8, CPU_TIME. Fix AND, OR,
- XOR. [Integrated by burley, AND/OR/XOR already fixed, INT8
- implementation changed/fixed.]
-
-Wed Mar 12 10:40:08 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in ($(srcdir)/f/intdoc.texi): Simplify rules
- so building f/intdoc is not always necessary; remove
- f/intdoc after running it if it is built.
-
-Tue Mar 11 23:42:00 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * intrin.def (FFEINTRIN_impAND, FFEINTRIN_impOR,
- FFEINTRIN_impXOR): Use the IAND, IOR, and IEOR implementations
- of these, instead of crashing in ffecom_expr_intrinsic_
- or adding case labels there.
-
-Mon Mar 10 22:51:23 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * intdoc.c: Fix so any C compiler can compile this.
-
-Fri Feb 28 13:16:50 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Version 0.5.20 released.
-
-Fri Feb 28 01:45:25 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in (RUNTIMESTAGESTUFF, LIBU77STAGESTUFF):
- Move some files incorrectly in the former to the latter,
- and add another file or two to the latter.
-
- New meanings for (KIND=n), and new denotations in the
- little language describing intrinsics:
- * com.c (ffecom_init_0): Assign new meanings.
- * intdoc.c: Document new meanings.
- Support the new denotations.
- * intrin.c: Employ new meanings, mapping them to internal
- values (which are the same as they ever were for now).
- Support the new denotations.
- * intrin.def: Switch DEFIMP table to the new denotations.
-
- * intrin.c (ffeintrin_check_): Fix bug that was leaving
- LOC() and %LOC() returning INTEGER*4 on systems where
- it should return INTEGER*8.
-
- * type.c: Canonicalize function definitions, for etags
- and such.
-
-Wed Feb 26 20:43:03 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_init_0): Choose INTEGER(KIND=n) types,
- where n is 2, 3, and 4, according to the new docs
- instead of according to the old C correspondences
- (which seem less useful at this point).
-
- * equiv.c (ffeequiv_destroy_): New function.
- (ffeequiv_layout_local_): Use this new function
- whenever the laying out of a local equivalence chain
- is aborted for any reason.
- Otherwise ensure that symbols no longer reference
- the stale ffeequiv entries that result when they
- are killed off in this procedure.
- Also, the rooted symbol is one that has storage,
- it really is irrelevant whether it has an equiv entry
- at this point (though the code to remove the equiv
- entry was put in at the end, just in case).
- (ffeequiv_kill): When doing internal checks, make
- sure the victim isn't named by any symbols it points
- to. Not as complete a check as looking through the
- entire symbol table (which does matter, since some
- code in equiv.c used to remove symbols from the lists
- for an ffeequiv victim but not remove that victim as the
- symbol's equiv info), but this check did find some
- real bugs in the code (that were fixed).
-
-Mon Feb 24 16:42:13 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_expr_intrinsic_): Fix a couple of
- warnings about uninitialized variables.
- * intrin.c (ffeintrin_check_): Ditto, but there were
- a couple of _real_ uninitialized-variable _bugs_ here!
- (ffeintrin_fulfill_specific): Ditto, no real bug here.
-
-Sun Feb 23 15:01:20 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Clean up diagnostics (especially about intrinsics):
- * bad.def (FFEBAD_UNIMPL_STMT): Remove.
- (FFEBAD_INTRINSIC_*, FFEBAD_NEED_INTRINSIC): Clean these
- up so they're friendlier.
- (FFEBAD_INTRINSIC_CMPAMBIG): New.
- * intrin.c (ffeintrin_fulfill_generic,
- ffeintrin_fulfill_specific, ffeintrin_is_intrinsic):
- Always choose
- generic or specific name text (which is for doc purposes
- anyway) over implementation name text (which is for
- internal use).
- * intrin.def: Use more descriptive name texts for generics
- and specifics in cases where the names themselves are not
- enough (e.g. IDATE, which has two forms).
-
- Fix some intrinsic mappings:
- * intrin.def (FFEINTRIN_specIDINT, FFEINTRIN_specAND,
- FFEINTRIN_specDFLOAT, FFEINTRIN_specDREAL, FFEINTRIN_specOR,
- FFEINTRIN_specXOR): Now have their own implementations,
- instead of borrowing from others.
- (FFEINTRIN_specAJMAX0, FFEINTRIN_specAJMIN0, FFEINTRIN_specBJTEST,
- FFEINTRIN_specDFLOTJ, FFEINTRIN_specFLOATJ, FFEINTRIN_specJIABS,
- FFEINTRIN_specJIAND, FFEINTRIN_specJIBCLR, FFEINTRIN_specJIBITS,
- FFEINTRIN_specJIBSET, FFEINTRIN_specJIDIM, FFEINTRIN_specJIDINT,
- FFEINTRIN_specJIDNNT, FFEINTRIN_specJIEOR, FFEINTRIN_specJIFIX,
- FFEINTRIN_specJINT, FFEINTRIN_specJIOR, FFEINTRIN_specJISHFT,
- FFEINTRIN_specJISHFTC, FFEINTRIN_specJISIN, FFEINTRIN_specJMAX0,
- FFEINTRIN_specJMAX1, FFEINTRIN_specJMIN0, FFEINTRIN_specJMIN1,
- FFEINTRIN_specJMOD, FFEINTRIN_specJNINT, FFEINTRIN_specJNOT,):
- Turn these implementations off, since it's not clear
- just what types they expect in the context of portable Fortran.
- (DFLOAT): Now in FVZ family, since f2c supports them
-
- Support intrinsic inquiry functions (BIT_SIZE, LEN):
- * intrin.c: Allow `i' in <arg_extra>.
- * intrin.def (FFEINTRIN_impBIT_SIZE, FFEINTRIN_impLEN):
- Mark args with `i'.
-
-Sat Feb 22 13:34:09 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Only warn, don't error, for reference to unimplemented
- intrinsic:
- * bad.def (FFEBAD_INTRINSIC_UNIMPLW): Warning version
- of _UNIMPL.
- * intrin.c (ffeintrin_is_intrinsic): Use new warning
- version of _UNIMPL (FFEBAD_INTRINSIC_UNIMPLW).
-
- Complain about REAL(Z) and AIMAG(Z) (Z is DOUBLE COMPLEX):
- * bad.def (FFEBAD_INTRINSIC_CMPAMBIG): New diagnostic.
- * expr.c: Needed #include "intrin.h" anyway.
- (ffeexpr_token_intrincheck_): New function handles delayed
- diagnostic for "REAL(REAL(expr)" if next token isn't ")".
- (ffeexpr_token_arguments_): Do most of the actual checking here.
- * intrin.h, intrin.c (ffeintrin_fulfill_specific): New
- argument, check_intrin, to tell caller that intrin is REAL(Z)
- or AIMAG(Z). All callers updated, mostly to pass NULL in
- for this.
- (ffeintrin_check_): Also has new arg check_intrin for same
- purpose. All callers updated the same way.
- * intrin.def (FFEINTRIN_impAIMAG): Change return type
- from "R0" to "RC", to accommodate f2c (and perhaps other
- non-F90 F77 compilers).
- * top.h, top.c: New option -fugly-complex.
-
- New GNU intrinsics REALPART, IMAGPART, and COMPLEX:
- * com.c (ffecom_expr_intrinsic_): Implement impCOMPLEX
- and impREALPART here. (specIMAGPART => specAIMAG.)
- * intrin.def: Add the intrinsics here.
-
- Rename implementations of VXTIDATE and VXTTIME to IDATEVXT
- and TIMEVXT, so they sort more consistently:
- * com.c (ffecom_expr_intrinsic_):
- * intrin.def:
-
- Delete intrinsic group `dcp', add `gnu', etc.:
- * intrin.c (ffeintrin_state_family): FFEINTRIN_familyGNU
- replaces FFEINTRIN_familyDCP, and gets state from `gnu'
- group.
- Get rid of FFEINTRIN_familyF2Z, nobody needs it.
- Move FFEINTRIN_specDCMPLX from DCP family to FVZ family,
- as f2c has it.
- Move FFEINTRIN_specDFLOAT from F2C family to FVZ family.
- (FFEINTRIN_specZABS, FFEINTRIN_specZCOS, FFEINTRIN_specZEXP,
- FFEINTRIN_specZLOG, FFEINTRIN_specZSIN, FFEINTRIN_specZSQRT):
- Move these from F2Z family to F2C family.
- * intrin.h (FFEINTRIN_familyF2Z, FFEINTRIN_familyDCP): Remove.
- (FFEINTRIN_familyGNU): Add.
- * top.h, top.c: Replace `dcp' with `gnu'.
-
- * com.c (ffecom_expr_intrinsic_): Clean up by collecting
- simple conversions into one nice, conceptual place.
- Fix up some intrinsic subroutines (MVBITS, KILL, UMASK) to
- properly push and pop call temps, to avoid wasting temp
- registers.
-
- * g77.c (doit): Toon says variables should be defined
- before being referenced. Spoilsport.
-
- * intrin.c (ffeintrin_check_): Now Dave's worried about
- warnings about uninitialized variables. Okay, so for
- basic return values 'g' and 's', they _were_
- uninitialized -- is determinism really _that_ useful?
-
- * intrin.def (FFEINTRIN_impFGETC): Fix STATUS argument
- so that it is INTENT(OUT) instead of INTENT(IN).
-
-1997-02-21 Dave Love <d.love@dl.ac.uk>
-
- * intrin.def, com.c: Support Sun-type `short' and `long'
- intrinsics. Perhaps should also do Microcruft-style `int2'.
-
-Thu Feb 20 15:16:53 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_expr_intrinsic_): Clean up indentation.
- Support SECONDSUBR intrinsic implementation.
- Rename SECOND to SECONDFUNC for direct support via library.
-
- * g77.c: Fix to return proper status value to shell,
- by obtaining it from processes it spawns.
-
- * intdoc.c: Fix minor typo.
-
- * intrin.def: Turn SECOND into generic that maps into
- function and subroutine forms.
-
- * intrin.def: Make FLOAT and SNGL into specific intrinsics.
-
- * intrin.def, intrin.h: Change the way DEFGEN and DEFSPEC
- macros work, to save on verbage.
-
-Mon Feb 17 02:08:04 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- New subsystem to automatically generate documentation
- on intrinsics:
- * Make-lang.in ($(srcdir)/f/g77.info,
- $(srcdir)/f/g77.dvi): Move g77 doc rules around.
- Add to g77 doc rules the new subsystem.
- (f77.mostlyclean, f77.maintainer-clean): Also clean up
- after new doc subsystem.
- * intdoc.c, intdoc.h: New doc subsystem code.
- * intrin.h [FFEINTRIN_DOC]: When 1, don't pull in
- stuff not needed by doc subsystem.
-
- Improve on intrinsics mechanism to both be more
- self-documenting and to catch more user errors:
- * intrin.c (ffeintrin_check_): Recognize new arg-len
- and arg-rank information, and check it.
- Move goto and signal indicators to the basic type.
- Permit reference to arbitrary argument number, not
- just first argument (for BESJN and BESYN).
- (ffeintrin_init_0): Check and accept new notations.
- * intrin.c, intrin.def: Value in COL now identifies
- arguments starting with number 0 being the first.
-
- Some minor intrinsics cleanups (resulting from doc work):
- * com.c (ffecom_expr_intrinsic_): Implement FLUSH
- directly once again, handle its optional argument,
- so it need not be a generic (awkward to handle in docs).
- * intrin.def (BESJ0, BESJ1, BESJN, BESY0, BESY1, BESYN,
- CHDIR, CHMOD, CTIME, DBESJ0, DBESJ1, DBESJN, DBESY0,
- DBESY1, DBESYN, DDIM, ETIME, FGETC, FNUM, FPUTC, FSTAT,
- GERROR, GETCWD, GETGID, GETLOG, GETPID, GETUID, GMTIME,
- HOSTNM, IDATE, IERRNO, IIDINT, IRAND, ISATTY, ITIME, JIDINT,
- LNBLNK, LSTAT, LTIME, MCLOCK, PERROR, SRAND, SYMLNK, TTYNAM,
- UMASK): Change capitalization of initcaps (official) name
- to be consistent with Burley's somewhat arbitrary rules.
- (BESJN, BESYN): These have return arguments of same type
- as their _second_ argument.
- (FLUSH): Now a specific, not generic, intrinsic, with one
- optional argument.
- (FLUSH1): Eliminated.
- Add arg-len and arg-rank info to several intrinsics.
- (ITIME): Change argument type from REAL to INTEGER.
-
-Tue Feb 11 14:04:42 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in (f771): Invocation of Makefile now done
- with $(srcdir)=gcc to go along with $(VPATH)=gcc.
- ($(srcdir)/f/runtime/configure,
- $(srcdir)/f/runtime/libU77/configure): Break these out
- so spurious triggers of this rule don't happen (as when
- configure.in is more recent than libU77/configure).
- (f77.rebuilt): Distinguish source versus build files,
- so this target can be invoked from build directory and
- still work.
- * Makefile.in: This now expects $(srcdir) to be the gcc
- source directory, not gcc/f, to agree with $(VPATH).
- Accordingly, $(INCLUDES) has been fixed, various cruft
- removed, the removal of f771 has been fixed to remove
- the _real_ f771 (not the one in gcc's parent directory),
- and so on.
-
- * lex.c: Part of ffelex_finish_statement_() now done
- by new function ffelex_prepare_eos_(), so that, in one
- popular case, the EOS can be prepared while the pointer
- is at the end of the non-continued line instead of the
- end of the line that marks no continuation. This improves
- the appearance of diagnostics substantially.
-
-Mon Feb 10 12:44:06 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in: runtime Makefile's, and include/f2c.h,
- also depend on f/runtime/configure and f/runtime/libU77/configure.
-
- Fix various libU77 routines:
- * com-rt.def (FFECOM_gfrtCTIME, FFECOM_gfrtMCLOCK,
- FFECOM_gfrtTIME): These now use INTEGER*8 for time values,
- for compatibility with systems like Alpha.
- (FFECOM_gfrtSYSTEM_CLOCK, FFECOM_gfrtTTYNAM): Delete incorrect
- trailing underscore in routine names.
- * intrin.c, intrin.def: Support INTEGER*8 return values and
- arguments ('4'). Change FFEINTRIN_impCTIME, FFEINTRIN_impMCLOCK,
- and FFEINTRIN_impTIME accordingly.
- (ffeintrin_is_intrinsic): Don't give caller a clue about
- form of intrinsic -- shouldn't be needed at this point.
-
- Cope with generic intrinsics that are subroutines and functions:
- * com.c (ffecom_finish_symbol_transform_, ffecom_expr_transform_):
- Don't transform an intrinsic that is not known to be a subroutine
- or a function. (Maybe someday have to avoid transforming
- any intrinsic with an undecided or unknown implementation.)
- * expr.c (ffeexpr_declare_unadorned_,
- ffeexpr_declare_parenthesized_): Ok to invoke generic
- intrinsic that has at least one subroutine form as a
- subroutine.
- Ok to pass intrinsic as actual arg if it has a known specific
- intrinsic form that is valid as actual arg.
- (ffeexpr_declare_parenthesized_): An unknown kind of
- intrinsic has a paren_type chosen based on context.
- (ffeexpr_token_arguments_): Build funcref/subrref based
- on context, not on kind of procedure being called.
- * intrin.h, intrin.c (ffeintrin_is_intrinsic): Undo changes of
- Tue Feb 4 23:12:04 1997 by me, change all callers to leave
- intrinsics as FFEINFO_kindNONE at this point. (Some callers
- also had unused variables deleted as a result.)
-
- Enable all intrinsic groups (especially f90 and vxt):
- * target.h (FFETARGET_defaultSTATE_DCP, FFETARGET_defaultSTATE_F2C,
- FFETARGET_defaultSTATE_F90, FFETARGET_defaultSTATE_MIL,
- FFETARGET_defaultSTATE_UNIX, FFETARGET_defaultSTATE_VXT):
- Delete these macros, let top.c set them directly.
- * top.c (ffeintrinsic_state_dcp_, ffe_intrinsic_state_f2c_,
- ffe_intrinsic_state_f90_, ffe_intrinsic_state_mil_,
- ffe_intrinsic_state_unix_, ffe_intrinsic_state_vxt_):
- Enable all these directly.
-
-Sat Feb 8 03:21:50 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * g77.c: Incorporate recent changes to ../gcc.c.
- For version magic (e.g. `g77 -v'), instead of compiling
- /dev/null, write, compile, run, and then delete a small
- program that prints the version numbers of the three
- components of libf2c (libF77, libI77, and libU77),
- so we get this info with bug reports.
- Also, this change reduces the chances of accidentally
- linking to an old (complex-alias-problem) libf2c.
- Fix `-L' so the argument is expected in `-Larg'.
-
- * com.h (FFECOM_f2cLONGINT): For INTEGER*8 support in f2c.h,
- dynamically determine proper type here, instead of
- assuming `long long int' is correct.
-
-Tue Feb 4 23:12:04 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Add libU77 library from Dave Love <d.love@dl.ac.uk>:
- * Make-lang.in (f77-runtime): Depend on new Makefile.
- (f/runtime/libU77/Makefile): New rule.
- Also configure libU77.
- ($(srcdir)/f/runtime/configure: Use Makefile.in,
- so configuration doesn't have to have happened.
- (f77.mostlyclean, f77.clean, f77.distclean,
- f77.maintainer-clean): Some fixups here, but more work
- needed.
- (RUNTIMESTAGESTUFF): Add libU77's config.status.
- (LIBU77STAGESTUFF, f77.stage1, f77.stage2, f77.stage3,
- f77.stage4): New macro, appropriate uses added.
- * com-rt.def: Add libU77 procedures.
- * com.c (ffecom_f2c_ptr_to_integer_type_node,
- ffecom_f2c_ptr_to_real_type_node): New type nodes.
- (FFECOM_rttypeCHARACTER_): New type of run-time function.
- (ffecom_char_args_): Handle CHARACTER*n intrinsics
- where n != 1 here, instead of in ffecom_expr_intrinsic_.
- (ffecom_expr_intrinsic_): New code to handle new
- intrinsics.
- In particular, change how FFEINTRIN_impFLUSH is handled.
- (ffecom_make_gfrt_): Handle new type of run-time function.
- (ffecom_init_0): Initialize new type nodes.
- * config-lang.in: New libU77 directory.
- * intrin.h, intrin.c (ffeintrin_is_intrinsic): Handle
- potential generic for subroutine _and_ function
- specifics via two new arguments. All callers changed.
- Properly ignore deleted/disabled intrinsics in resolving
- generics.
- (ffeintrin_check_, ffeintrin_init_0): Handle CHARACTER intrinsics of (*)
- length.
- * intrin.def: Permission granted by FSF to place this in
- public domain, which will allow it to serve as source
- for both g77 program and its documentation.
- Add libU77 intrinsics.
- (FLUSH): Now a generic, not specific, intrinsic.
- (DEFIMP): Now support return modifier for CHARACTER intrinsics.
-
- * com-rt.def (FFECOM_gfrtDIM, FFECOM_gfrtERF,
- FFECOM_gfrtERFC, FFECOM_gfrtEXP, FFECOM_gfrtSIGN,
- FFECOM_gfrtSIN, FFECOM_gfrtSINH, FFECOM_gfrtTAN,
- FFECOM_gfrtTANH, FFECOM_gfrtPOW_RI): Change "&r" to "&f".
-
-Sat Feb 1 12:15:09 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Version 0.5.19.1 released.
-
- * com.c (ffecom_expr_, ffecom_expr_intrinsic_,
- ffecom_tree_divide_): FFECOM_gfrtPOW_ZI,
- FFECOM_gfrtCONJG, FFECOM_gfrtDCONJG,
- FFECOM_gfrtCCOS, FFECOM_gfrtCDCOS,
- FFECOM_gfrtCLOG, FFECOM_gfrtCDLOG,
- FFECOM_gfrtCSIN, FFECOM_gfrtCDSIN,
- FFECOM_gfrtCSQRT, FFECOM_gfrtCDSQRT,
- FFECOM_gfrtDIV_CC, FFECOM_gfrtDIV_ZZ: These all require
- result to _not_ overlap one or more inputs.
-
-Sat Feb 1 00:25:55 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_init_0): Do internal checks only if
- -fset-g77-defaults not specified.
-
- Fix %LOC(), LOC() to return sufficiently wide type:
- * com.h, com.c (ffecom_pointer_kind_, ffecom_label_kind_,
- ffecom_pointer_kind(), ffecom_label_kind()): New globals
- and accessor macros hold kind for integer pointers on target
- machine.
- (ffecom_init_0): Determine narrowest INTEGER type that
- can hold a pointer (usually INTEGER*4 or INTEGER*8),
- store it in ffecom_pointer_kind_, etc.
- * expr.c (ffeexpr_cb_end_loc_): Use right type for %LOC().
- * intrin.c (ffeintrin_check_, ffeintrin_init_0): Support
- new 'p' kind for type of intrinsic.
- * intrin.def (FFEINTRIN_impLOC): Returns "Ip" instead of "I1",
- so LOC() type is correct for target machine.
-
- Support -fugly-assign:
- * lang-options.h, top.h, top.c (ffe_decode_option):
- Accept -fugly-assign and -fno-ugly-assign.
- * com.c (ffecom_expr_): Handle -fugly-assign.
- * expr.c (ffeexpr_finished_): Check right type for ASSIGN
- contexts.
-
-Fri Jan 31 14:30:00 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Remove last vestiges of -fvxt-not-f90:
- * stb.c (ffestb_R10012_, ffestb_R10014_, ffestb_V0201_):
- top.c, top.h:
-
-Fri Jan 31 02:13:54 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * top.c (ffe_decode_option): Warn if -fugly is specified,
- it'll go away soon.
-
- * symbol.h: No need to #include "bad.h".
-
- Reorganize features from -fvxt-not-f90 to -fvxt:
- * lang-options.h, top.h, top.c:
- Accept -fvxt and -fno-vxt, but not -fvxt-not-f90 or -ff90-not-vxt.
- Warn if the latter two are used.
- * expr.c (ffeexpr_nil_rhs_): Double-quote means octal constant.
- (ffeexpr_token_rhs_): Double-quote means octal constant.
- * target.h (FFETARGET_defaultIS_VXT_NOT_90): Delete macro
- definition, no longer needed.
-
- Make some -ff90 features the default:
- * data.c (ffedata_value): DATA implies SAVE.
- * src.h (ffesrc_is_name_noninit): Underscores always okay.
-
- Fix up some more #error directives by quoting their text:
- * bld.c (ffebld_constant_is_zero):
- * target.h:
-
-Sat Jan 18 18:22:09 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * g77.c (lookup_option, main): Recognize `-Xlinker',
- `-Wl,', `-l', `-L', `--library-directory', `-o',
- `--output'.
- (lookup_option): Don't depend on SWITCH_TAKES_ARG
- being correct, it might or might not have `-x' in
- it depending on host.
- Return NULL argument if it would be an empty string.
- (main): If no input files (by gcc.c's definition)
- but `-o' or `--output' specified, produce diagnostic
- to avoid overwriting output via gcc.
- Recognize C++ `+e' options.
- Treat -L as another non-magical option (like -B).
- Don't append_arg `-x' twice.
-
-Fri Jan 10 23:36:00 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * top.c [BUILT_FOR_270] (ffe_decode_option): Make
- -fargument-noalias-global the default.
-
-Fri Jan 10 07:42:27 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Enable inlining of previously-compiled program units:
- * com.c (ffecom_do_entry_, ffecom_start_progunit_):
- Register new public function in ffeglobal database.
- (ffecom_sym_transform_): Any GLOBAL or potentially GLOBAL
- symbol should be looked up in ffeglobal database and
- that tree node used, if found. That way, gcc knows
- the references are to those earlier definitions, so it
- can emit shorter branches/calls, inline, etc.
- (ffecom_transform_common_): Minor change for clarity.
- * expr.c (ffeexpr_sym-lhs_call_, ffeexpr_sym_lhs_extfunc_,
- ffeexpr_sym_rhs_actualarg_, ffeexpr_paren_rhs_let_,
- ffeexpr_token_funsubstr_): Globalize symbol as needed.
- * global.c (ffeglobal_promoted): New function to look up
- existing local symbol in ffeglobal database.
- * global.h: Declare new function.
- * name.h (ffename_token): New macro, plus alphabetize.
- * stc.c (ffestc_R1207_item): Globalize EXTERNAL symbol.
- * stu.c (ffestu_sym_end_transition, ffestu_sym_exec_transition):
- Globalize symbol as needed.
- * symbol.h, symbol.c (ffesymbol_globalize): New function.
-
-Thu Jan 9 14:20:00 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * ste.c (ffeste_R809): Produce a diagnostic for SELECT CASE
- on CHARACTER type, instead of crashing.
-
-Thu Jan 9 00:52:45 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * stc.c (ffestc_order_entry_, ffestc_order_format_,
- ffestc_R1226): Allow ENTRY and FORMAT before IMPLICIT
- NONE, by having them transition only to state 1 instead
- of state 2 (which is disallowed by IMPLICIT NONE).
-
-Mon Jan 6 22:44:53 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix AXP bug found by Rick Niles (961201-1.f):
- * com.c (ffecom_init_0): Undo my 1996-05-14 change, as
- it is incorrect and prevented easily finding this bug.
- * target.h [__alpha__] (ffetargetReal1, ffetargetReal2):
- Use int instead of long.
- (ffetarget_cvt_r1_to_rv_, ffetarget_cvt_rv_to_r1_,
- ffetarget_cvt_r2_to_rv_, ffetarget_cvt_rv_to_r2_):
- New functions that intercede for callers of
- REAL_VALUE_(TO|UNTO)_TARGET_(SINGLE|DOUBLE).
- All callers changed, and damaging casts to (long *) removed.
-
-Sun Jan 5 03:26:11 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in (g77, g77-cross): Depend on both g77.c and
- zzz.c, in $(srcdir)/f/.
-
- Better design for -fugly-assumed:
- * stc.c (ffestc_R501_item, ffestc_R524_item,
- ffestc_R547_item_object): Pass new is_ugly_assumed flag.
- * stt.c, stt.h (ffestt_dimlist_as_expr,
- ffestt_dimlist_type): New is_ugly_assumed flag now
- controls whether "1" is treated as "*".
- Don't treat "2-1" or other collapsed constants as "*".
-
-Sat Jan 4 15:26:22 1997 Craig Burley <burley@gnu.ai.mit.edu>
-
- * stb.c (ffestb_R10012_): Don't confirm on FORMAT(A,)
- or even FORMAT(A,,B), as R1229 only warns about the
- former currently, and this seems reasonable.
-
- Improvements to diagnostics:
- * sta.c (ffesta_second_): Don't add any ffestb parsers
- unless they're specifically called for.
- Set up ffesta_tokens[0] before calling ffestc_exec_transition,
- else stale info might get used.
- (ffesta_save_): Do a better job picking which parser to run
- after running all parsers with no confirmed possibles.
- (FFESTA_maxPOSSIBLES_): Decrease from 100 now that so few
- possibles are ever on the list at a given time.
- (struct _ffesta_possible): Add named attribute.
- (ffesta_add_possible_exec_, ffesta_add_possible_nonexec_):
- Make these into macros that call a single function that now
- sets the named attribute.
- (ffesta_add_possible_unnamed_exec_,
- ffeseta_add_possible_unnamed_nonexec_): New macros.
- (ffesta_second_): Designate unnamed possibles as
- appropriate.
- * stb.c (ffestb_R1229, ffestb_R12291_): Use more general
- diagnostic, so things like "POINTER (FOO, BAR)" are
- diagnosed as unrecognized statements, not invalid statement
- functions.
- * stb.h, stb.c (ffestb_unimplemented): Remove function.
-
-1996-12-30 Dave Love <d.love@dl.ac.uk>
-
- * com.c: #include libU77/config.h
- (ffecom_f2c_ptr_to_integer_type_node,
- ffecom_f2c_ptr_to_integer_type_node): New variables.
- (ffecom_init_0): Use them.
- (ffecom_expr_intrinsic_): Many news cases for libU77 intrinsics.
-
- * com-rt.def: New definitions for libU77.
- * intrin.def: Likewise. Also correct ftell arg spec.
-
- * Makefile.in (f/runtime/libU77/config.h): New target for com.c
- dependency.
- * Make-lang.in (f771): Depend on f/runtime/Makefile for the above.
-
-Sat Dec 28 12:28:29 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * stt.c (ffestt_dimlist_type): Treat ([...,]1) in dimlist
- as ([...,]*) if -fugly-assumed, so assumed-size array
- detected early enough.
-
-Thu Dec 19 14:01:57 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * target.h (FFETARGET_REAL_VALUE_FROM_INT_): Conditionalize
- definition on BUILT_FOR_280, not BUILT_WITH_280, since
- the name of the macro was (properly) changed since 0.5.19.
-
- Fix warnings/errors resulting from ffetargetOffset becoming
- `long long int' instead of `unsigned long' as of 0.5.19,
- while ffebitCount remains `unsigned long':
- * bld.c (ffebld_constantarray_dump): Avoid warnings by
- using loop var of appropriate type, and using casts.
- * com.c (ffecom_expr_): Use right type for loop var.
- (ffecom_sym_transform_, ffecom_transform_equiv_):
- Cast to right type in assertions.
- * data.c (ffedata_gather_, ffedata_value_): Cast to right
- type in assertions and comparisons.
-
-Wed Dec 18 12:07:11 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- Patch from Alexandre Oliva <oliva@dcc.unicamp.br>:
- * Makefile.in (all.indirect): Don't pass -bbigtoc option
- to GNU ld.
-
- Cope with new versions of gcc:
- * com.h (BUILT_FOR_280): New macro.
- * com.c (ffecom_ptr_to_expr): Conditionalize test of
- OFFSET_REF.
- (ffecom_build_complex_constant_): Conditionalize calling
- sequence for build_complex.
-
-Sat Dec 7 07:15:17 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Version 0.5.19 released.
-
-Fri Dec 6 12:23:55 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * g77.c: Default to assuming "f77" is in $LANGUAGES, since
- the LANGUAGE_F77 macro isn't defined by anyone anymore (but
- might as well leave the no-f77 code in just in case).
- * Make-lang.in (g77, g77-cross): Don't define LANGUAGE_F77
- anymore.
-
-1996-12-06 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (g77, g77-cross): Revert to building `g77' or not
- conditional on `f77' in LANGUAGES.
-
-Wed Dec 4 13:08:44 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in (g77, g77-cross): No libs or lib dependencies
- in case where "f77" is not in $LANGUAGES.
-
- * lex.c (ffelex_image_char_, ffelex_file_fixed,
- ffelex_file_free): Fixes to properly handle lines with
- null character, and too-long lines as well.
-
- * lex.c: Call ffebad_start_msg_lex instead of
- ffebad_start_msg throughout.
-
-Sun Dec 1 21:19:55 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- Fix-up for 1996-11-25 changes:
- * com.c (ffecom_member_phase2_): Subtract out 0 offset for
- elegance and consistency with EQUIVALENCE aggregates.
- (ffecom_sym_transform_): Ditto for LOCAL/COMMON, and
- ensure we get the same parent storage area.
- * data.c (ffedata_gather_, ffedata_value_): Subtract out
- aggregate offset.
-
-Wed Nov 27 13:55:57 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * proj.h: Quote the text of the #error message, to avoid
- strange-looking diagnostics from non-gcc ANSI compilers.
-
- * top.c: Make -fno-debug-kludge the default.
-
-Mon Nov 25 20:13:45 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- Provide more info on EQUIVALENCE mismatches:
- * bad.def (FFEBAD_EQUIV_MISMATCH): More detailed message.
- * equiv.c (ffeequiv_layout_local_, ffeequiv_layout_cblock):
- More details for FFEBAD_EQUIV_MISMATCH.
-
- Fix problem with EQUIVALENCE handling:
- * equiv.c (ffeequiv_layout_local_): Redesign algorithm --
- old one was broken, resulting in rejection of good code.
- (ffeequiv_offset_): Add argument, change callers.
- Clean up the code, fix up the (probably unused) negative-value
- case for SYMTER.
- * com.c (ffecom_sym_transform_): For local EQUIVALENCE
- member, subtract out aggregate offset (which is <= 0).
-
-Thu Nov 21 12:44:56 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- Change type of ffetargetOffset from `unsigned long' to `long long':
- * bld.c (ffebld_constantarray_dump): Change printf formats.
- * storag.c (ffestorag_dump): Ditto.
- * symbol.c (ffesymbol_report): Ditto.
- * target.h (ffetargetOffset_f): Ditto and change type itself.
-
- Handle situation where list of languages does not include f77:
- * Make-lang.in: Define LANGUAGE_F77 to 1 only if `f77' is in
- the $LANGUAGES macro for the build.
- * g77.c: Compile to a (nearly) no-op program if LANGUAGE_F77
- is not defined to 1.
-
- Fixes to delay confirmation of READ, WRITE, and GOTO statements
- so the corresponding assignments to same-named CHAR*(*) arrays
- work:
- * stb.c (ffestb_R90915_, ffestb_91014_): New functions.
- (ffestb_goto3_, ffestb_goto5_): Move confirmation from 3 to 5
- for the OPEN_PAREN case.
- (ffestb_R9091_, ffestb_R9094_, ffestb_R90913_, ffestb_R90914_,
- ffestb_R91012_, ffestb_R91013_): Use new functions, and confirm
- except for the OPEN_PAREN case.
-
- Fixes to not confirm declarations with an open paren where
- an equal sign or other assignment-like token might be, so the
- corresponding assignments to same-named CHAR*(*) arrays work:
- (ffestb_decl_entsp_5_): Move assertion so we crash on that first,
- if it turns out to be wrong, before the less-debuggable crash
- on mistaken confirmation.
- (ffestb_decl_entsp_6_, ffestb_decl_entsp_7_, ffestb_decl_entsp_8_):
- Include OPEN_PAREN in list of assignment-only tokens.
-
- Fix more diagnosed-crash bugs:
- * stu.c (ffestu_sym_end_transition): ANY-ize an adjustable array
- with bad dimension expressions even if still stateUNCERTAIN.
- (ffestu_symter_end_transition_, ffestu_symter_exec_transition_):
- Return TRUE for opANY as well.
- For code elegance, move opSYMTER case into first switch.
-
-1996-11-17 Dave Love <d.love@dl.ac.uk>
-
- * lex.c: Fix last change.
-
-1996-11-14 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in, config-lang.in: Remove the (broken) libU77 stuff,
- pending 0.5.20.
-
-Thu Nov 14 15:40:59 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * bad.def (FFEBAD_UNIMPL_STMT): Explain that invalid
- intrinsic references can trigger this message, too.
-
-1996-11-12 Dave Love <d.love@dl.ac.uk>
-
- * lex.c: Declare dwarfout routines.
-
- * config-lang.in: Sink grep o/p.
-
-Mon Nov 11 14:21:13 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * g77.c (main): Might as well print version number
- for --verbose as well.
-
-Thu Nov 7 18:41:41 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c, lang-options.h, target.h, top.c, top.h: Split out
- remaining -fugly stuff into -fugly-logint and -fugly-comma,
- leaving -fugly as simply a `macro' that expands into other
- options, and eliminate defaults for some of the ugly stuff
- in target.h.
-
- * Make-lang.in (gcc-cross): Compile zzz.c, not version.o (!),
- in to get version info for this target.
-
- * config-lang.in: Test for GBE patch application based
- on whether 2.6.x or 2.7.x GBE is detected.
-
-Wed Nov 6 14:19:45 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in (g77): Compile zzz.c in to get version info.
- * g77.c: Add support for --help and --version.
-
- * g77.c (lookup_option): Short-circuit long-winded tests
- when second char is not hyphen, just to save a spot of time.
-
-Sat Nov 2 13:50:31 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * intrin.def: Add FTELL and FSEEK intrinsics, plus new
- `g' codes for alternate-return (GOTO) arguments.
- * intrin.c (ffeintrin_check_): Support `g' codes.
- * com-rt.def: Add ftell_() and fseek_() to database.
- * com.c (ffecom_expr_intrinsic_): Ditto. Also, let each
- subroutine intrinsic decide for itself what to do with
- tree_type, the default being NULL_TREE once again (so
- ffecom_call_ doesn't think it's supposed to cast the
- function call to the type in the fall-through case).
-
- * ste.c (ffeste_R909_finish): Don't special-case list-directed
- I/O, now that libf2c can return nonzero status codes.
- (ffeste_R910_finish): Ditto.
- (ffeste_io_call_): Simplify logic.
- (ffeste_io_impdo_):
- (ffeste_subr_beru_):
- (ffeste_R904):
- (ffeste_R907):
- (ffeste_R909_start):
- (ffeste_R909_item):
- (ffeste_R909_finish):
- (ffeste_R910_start):
- (ffeste_R910_item):
- (ffeste_R910_finish):
- (ffeste_R911_start):
- (ffeste_R923A): Ditto all the above.
-
-Thu Oct 31 20:56:28 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * config-lang.in, Make-lang.in: Rename flag file
- build-u77 to build-libu77, for consistency with
- install-libf2c and such.
-
- * config-lang.in: Don't complain about failure to patch
- if pre-2.7.0 gcc is involved (since our patch for that
- doesn't add support for tooning).
-
-Sat Oct 26 05:56:51 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * bad.def (FFEBAD_TYPELESS_TOO_LARGE): Remove this
- unused and redundant diagnostic.
-
-Sat Oct 26 00:45:42 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * target.c (ffetarget_integerhex): Fix dumb bug.
-
-1996-10-20 Dave Love <d.love@dl.ac.uk>
-
- * gbe/2.7.2.1.diff: New file.
-
- * Makefile.in (F771_LDFLAGS): Add -bbigtoc for AIX4.1 up, suggested by
- endo@material.tohoku.ac.jp [among others!].
-
-Sat Oct 19 03:11:14 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * bad.def, bld.c, bld.h, expr.c, lang-options.h, target.c,
- target.h, top.c, top.h (ffebld_constant_new_integerbinary,
- ffebld_constant_new_integerhex, ffebld_constant_new_integeroctal,
- ffeexpr_token_name_apos_name_, ffetarget_integerbinary,
- ffetarget_integerhex, ffetarget_integeroctal): Support
- new -fno-typeless-boz option with new functions, mods to
- existing octal-handling functions, new macros, new error
- messages, and so on.
-
- * com.c, lang-options.h, top.c, top.h (ffecom_notify_primary_entry):
- Print program unit name on stderr if -fno-silent (new option).
-
- * lang-options.h, top.c, top.h, stt.c (ffestt_dimlist_as_expr):
- Treat ([...,]1) in dimlist as ([...,]*) if -fugly-assumed
- (new option).
-
- * lang-options.h: Comment out options duplicated in gcc/toplev.c,
- because, somehow, having them commented in and building on my
- DEC Alpha results in a cc1 that always segfaults, and gdb that
- also segfaults whenever it debugs it up to init_lex() calling
- xmalloc() or so.
-
-Thu Oct 17 00:39:27 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * stb.c (ffestb_R10013_): Don't change meaning of .sign until
- after previous meaning/value used to set sign of value
- (960507-1.f).
-
-Sun Oct 13 22:15:23 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * top.c (ffe_decode_option): Don't set back-end flags
- that are nonexistent prior to gcc 2.7.0.
-
-Sun Oct 13 12:48:45 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (convert): Don't convert emulated complex expr to
- real (via REALPART_EXPR) if the target type is (emulated)
- complex.
-
-Wed Oct 2 21:57:12 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_debug_kludge_): Set DECL_IN_SYSTEM_HEADER so
- -Wunused doesn't complain about these manufactured decls.
- (ffecom_expr_): Ditto, for original (non-ASSIGN'ed) variable.
- (ffecom_transform_equiv_): Clear DECL_IGNORED_P for aggregate
- area so it shows up as a debug-accessible symbol.
- (pushdecl): Default for "invented" identifiers (a g77-specific
- concept for now) is that they are artificial, in system header,
- ignored for debugging purposes, used, and (for types) suppressed.
- This ought to be overkill.
-
-Fri Sep 27 23:13:07 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * ste.c (ffeste_begin_iterdo_, ffeste_end_iterdo_): Support
- one-trip DO loops (F66-style).
- * lang-options.h, top.c, top.h (-fonetrip): New option.
-
-Thu Sep 26 00:18:40 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_debug_kludge_): New function.
- (ffecom_sym_transform_): Use new function for COMMON and EQUIVALENCE
- members.
-
- * lang-options.h, top.c, top.h (-fno-debug-kludge):
- New option.
-
-1996-09-24 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (include/f2c.h):
- Remove dependencies on xmake_file and tmake_file.
- They expand inconsistently in 2.8 c.f. 2.7; $(GCC_PARTS) depends on
- them anyhow.
-
-1996-09-22 Dave Love <d.love@dl.ac.uk>
-
- * config-lang.in: Add --enable-libu77 option handling.
-
- * Make-lang.in:
- Conditionally add --enable-libu77 when running runtime configure.
- Define LIBU77STAGESTUFF and use it in relevant rules.
-
-1996-08-21 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (f77-runtime):
- `stmp-hdrs' should have been `stmp-headers'.
-
-1996-08-20 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (f77-runtime):
- Depend on stmp-hdrs, not stmp-int-hdrs, since libF77
- needs float.h.
-
-Sat Jun 22 18:17:11 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_tree_divide_): Fix RECORD_TYPE case to
- look at type of first field, properly, to determine
- whether to call c_div or z_div.
-
-Tue Jun 4 04:27:18 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_build_complex_constant_): Explicitly specify
- TREE_PURPOSE.
- (ffecom_expr_): Fix thinko.
- (ffecom_2): For COMPLEX_EXPR, explicitly specify TREE_PURPOSE.
-
-Mon May 27 16:23:43 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- Changes to optionally avoid gcc's back-end complex support:
- * com.c (ffecom_stabilize_aggregate_): New function.
- (ffecom_convert_to_complex_): New function.
- (ffecom_make_complex_type_): New function.
- (ffecom_build_complex_constant_): New function.
- (ffecom_expr_): For opCONVERT of non-COMPLEX to COMPLEX,
- don't bother explicitly converting to the subtype first,
- because gcc does that anyway, and more code would have
- to be added to find the subtype for the emulated-complex
- case.
- (ffecom_f2c_make_type_): Use ffecom_make_complex_type_
- instead of make_node etc. to make a complex type.
- (ffecom_1, ffecom_2): Translate operations on COMPLEX operands
- to appropriate operations when emulating complex.
- (ffecom_constantunion): Use ffecom_build_complex_constant_
- instead of build_complex to build a complex constant.
- (ffecom_init_0): Change point at which types are laid out
- for improved consistency.
- Use ffecom_make_complex_type_ instead of make_node etc.
- to make a complex type.
- Always calculate storage sizes from TYPE_SIZE, never TYPE_PRECISION.
- (convert): Use e, not expr, since we've copied into that anyway.
- For RECORD_TYPE cases, do emulated-complex conversions.
- (ffecom_f2c_set_lio_code_): Always calculate storage sizes
- from TYPE_SIZE, never TYPE_PRECISION.
- (ffecom_tree_divide_): Allow RECORD_TYPE to also be handled
- by run-time library.
- (ffecom_expr_intrinsic_): Handle possible RECORD_TYPE as argument
- to AIMAG intrinsic.
-
- * top.h, top.c, lang-options.h: Support new -f(no-)emulate-complex option.
-
- * com.c (ffecom_sym_transform_): Clarify and fix typos in comments.
-
-Mon May 20 02:06:27 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * target.h: Use new REAL_VALUE_UNTO_TARGET_* macros instead
- of REAL_VALUE_FROM_TARGET_DOUBLE and _SINGLE.
- Explicitly use long instead of HOST_WIDE_INT for emulation
- of ffetargetReal1 and ffetargetReal2.
-
-1996-05-20 Dave Love <d.love@dl.ac.uk>
-
- * config-lang.in:
- Test for patch being applied with flag_move_all_movables in toplev.c.
-
- * install.texi (Patching GNU Fortran):
- Mention overriding X_CFLAGS rather than
- editing proj.h on SunOS4.
-
- * Make-lang.in (F77_FLAGS_TO_PASS):
- Add X_CFLAGS (convenient for SunOS4 kluge, in
- particular).
- (f77.{,mostly,dist}clean): Reorder things, in particular not to delete
- Makefiles too early.
-
- * g77.c (DEFAULT_SWITCH_TAKES_ARG): Define a la gcc.c in the
- current GCC snapshot.
-
-Tue May 14 00:24:07 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- Changes for DEC Alpha AXP support:
- * com.c (ffecom_init_0): REAL_ARITHMETIC means internal
- REAL/DOUBLE PRECISION might well have a different size
- than the compiled type, so don't crash if this is the
- case.
- * target.h: Use `int' for ffetargetInteger1,
- ffetargetLogical1, and magical tests. Set _f format
- strings accordingly.
-
-Tue Apr 16 14:08:28 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * top.c (ffe_decode_option): -Wall no longer implies
- -Wsurprising.
-
-Sat Apr 13 14:50:06 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_char_args_): If item is error_mark_node,
- set *length that way, too.
-
- * com.c (ffecom_expr_power_integer_): If either operand
- is error_mark_node, return that.
-
- * com.c (ffecom_intrinsic_len_): If item is error_mark_node,
- return that for length.
-
- * expr.c (ffeexpr_declare_unadorned_,
- ffeexpr_declare_parenthesized_): Instead of crashing
- on unexpected contexts, produce a diagnostic.
-
- * intrin.c (ffeintrin_check_), intrin.def (impSIGNAL):
- Allow procedure as second arg to SIGNAL intrinsic.
-
- * stu.c (ffestu_symter_end_transition_): New function.
- (ffestu_symter_exec_transition_): Return bool arg.
- Always transition symbol (don't inhibit when !whereNONE).
- (ffestu_sym_end_transition): If DUMMY/LOCAL arg has any
- opANY exprs in its dimlist, diagnose it so it doesn't
- make it through to later stages that try to deal with
- dimlist stuff.
- (ffestu_sym_exec_transition): If sym has any opANY exprs
- in its dimlist, diagnose it so it becomes opANY itself.
-
- * symbol.c (ffesymbol_error): If token arg is NULL,
- just ANY-ize the symbol -- don't produce diagnostic.
-
-Mon Apr 1 10:14:02 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Version 0.5.18 released.
-
-Mon Mar 25 20:52:24 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_expr_power_integer_): Don't generate code
- that compares COMPLEX (or, as it happens, REAL) via "LT_EXPR",
- since the back end crashes on that. (This code would never
- be executed anyway, but the test that avoids it has now been
- translated to control whether the code gets generated at all.)
- Fixes 960323-3.f.
-
- * com.c (ffecom_type_localvar_): Handle variable-sized
- dimension bounds expressions here, so they get calculated
- and saved on procedure entry. Fixes 960323-4.f.
-
- * com.c (ffecom_notify_init_symbol): Symbol has no init
- info at all if only zeros have been used to initialize it.
- Fixes 960324-0.f.
-
- * expr.c, expr.h (ffeexpr_type_combine): Renamed from
- ffeexpr_type_combine_ and now a public procedure; last arg now
- a token, instead of an internal structure used to extract a token.
- Now allows the outputs to be aliased with the inputs.
- Now allows a NULL token to mean "don't report error".
- (ffeexpr_reduced_bool2_, ffeexpr_reduced_eqop2_,
- ffeexpr_reduced_math2_, ffeexpr_reduced_power_,
- ffeexpr_reduced_relop2_): Handle new calling sequence for
- ffeexpr_type_combine.
- * (ffeexpr_convert): Don't put an opCONVERT node
- in just because the size is unknown; all downstream code
- should be able to deal without it being there anyway, and
- getting rid of it allows new intrinsic code to more easily
- combine types and such without generating bad code.
- * info.c, info.h (ffeinfo_kindtype_max): Rewrite to do
- proper comparison of size of types, not just comparison
- of their internal kind numbers (so I2.eq.I1 doesn't promote
- I1 to I2, rather the other way around).
- * intrin.c (ffeintrin_check_): Combine types of arguments
- in COL a la expression handling, for greater flexibility
- and permissiveness (though, someday, -fpedantic should
- report use of this kind of thing).
- Make sure Hollerith/typeless where CHARACTER expected is
- rejected. This all fixes 960323-2.f.
-
- * ste.c (ffeste_begin_iterdo_): Fix some more type conversions
- so INTEGER*2-laden DO loops don't crash at compile time on
- certain machines. Believed to fix 960323-1.f.
-
- * stu.c (ffestu_sym_end_transition): Certainly reject
- whereDUMMY not in any dummy list, whether stateUNCERTAIN
- or stateUNDERSTOOD. Fixes 960323-0.f.
-
-Tue Mar 19 13:12:40 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * data.c (ffedata_value): Fix crash on opANY, and simplify
- the code at the same time.
-
- * Make-lang.in (f77-runtime): Also depends on lib[FI]77/Makefile...
- (include/f2c.h...): ...which in turn depend on */Makefile.in.
- (f77.rebuilt): Rebuild runtime stuff too.
-
- * intrin.c (ffeintrin_check_): Accommodate TYPELESS/HOLLERITH
- types, convert args as necessary, etc.
-
- * expr.c (ffeexpr_convert): Fix test for TYPELESS/HOLLERITH
- to obey the docs; crash if no source token when error.
- (ffeexpr_collapse_convert): Crash if no token when error.
-
-Mon Mar 18 15:51:30 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_init_zero_): Renamed from
- ffecom_init_local_zero_; now handles top-level
- (COMMON) initializations too.
-
- * bld.c (ffebld_constant_is_zero):
- * com.c (ffecom_symbol_transform_, ffecom_sym_transform_assign_,
- ffecom_transform_common_, ffecom_transform_equiv_):
- * data.c:
- * equiv.c:
- * equiv.h:
- * lang-options.h:
- * stc.c:
- * storag.c:
- * storag.h:
- * symbol.c:
- * symbol.h:
- * target.c:
- * target.h:
- * top.c:
- * top.h: All of this is mostly housekeeping-type changes
- to support -f(no-)zeros, i.e. not always stuff zero
- values into the initializer fields of symbol/storage objects,
- but still track that they have been given initial values.
-
- * bad.def: Fix wording for DATA-related diagnostics.
-
- * com.c (ffecom_sym_transform_assign_): Don't check
- any EQUIVALENCE stuff for local ASSIGN, the check was
- bad (crashing), and it's not necessary, anyway.
-
- * com.c (ffecom_expr_intrinsic_): For MAX and MIN,
- ignore null arguments as far arg[123], and fix handling
- of ANY arguments. (New intrinsic support now allows
- spurious trailing null arguments.)
-
- * com.c (ffecom_init_0): Add HOLLERITH (unsigned)
- equivalents for INTEGER*2, *4, and *8, so shift intrinsics
- and other things that need unsigned versions of signed
- types work.
-
-Sat Mar 16 12:11:40 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * storag.c (ffestorag_exec_layout): Treat adjustable
- local array like dummy -- don't create storage object.
- * com.c (ffecom_sym_transform_): Allow for NULL storage
- object in LOCAL case (adjustable array).
-
-Fri Mar 15 13:09:41 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_sym_transform_): Allow local symbols
- with nonconstant sizes (adjustable local arrays).
- (ffecom_type_localvar_): Allow dimensions with nonconstant
- component (adjustable local arrays).
- * expr.c: Various minor changes to handle adjustable
- local arrays (a new case of stateUNCERTAIN).
- * stu.c (ffestu_sym_end_transition,
- ffestu_sym_exec_transition): Ditto.
- * symbol.def: Update docs to reflect these changes.
-
- * com.c (ffecom_expr_): Reduce space/time needed for
- opACCTER case by handling it here instead of converting
- it to opARRTER earlier on.
- (ffecom_notify_init_storage): Don't convert ACCTER to ARRTER.
- (ffecom_notify_init_symbol): Ditto.
-
- * com.c (ffecom_init_0): Crash and burn if any of the types'
- sizes, according to the GBE, disagrees with the sizes of
- the FFE's internal implementation. This might catch
- Alpha/SGI bugs earlier.
-
-Fri Mar 15 01:09:41 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com-rt.def, com.c, com.h: Changes for rewrite of intrinsic
- handling.
- * com.c (ffecom_arglist_expr_): New function.
- (ffecom_widest_expr_type_): New function.
- (ffecom_expr_intrinsic_): Reorganize, some rewriting.
- (ffecom_f2c_make_type_): Layout complex types.
- (ffecom_gfrt_args_): New function.
- (ffecom_list_expr): Trivial change for consistency.
-
- * expr.c (ffeexpr_token_name_rhs_): Go back to getting
- type from specific, not implementation, info.
- (ffeexpr_token_funsubstr_): Set intrinsic implementation too!
- * intrin.c: Major rewrite of most portions.
- * intrin.def: Major rearchitecting of tables.
- * intrin.h (ffeintrin_basictype, ffeintrin_kindtype):
- Now (once again) take ffeintrinSpec as arg, not ffeintrinImp;
- for now, these return NONE, since they're not really needed
- and adding the necessary info to the tables is not trivial.
- (ffeintrin_codegen_imp): New function.
- * stc.c (ffestc_R1208_item): Change way ffeintrin funcs called,
- back to original per above; but comment out the code anyway.
-
- * intrin.c (ffe_init_0): Do internal checks only if
- -fset-g77-defaults not specified.
-
- * lang-options.h: Add -fset-g77-defaults option.
- * lang-specs.h: Always pass -fset-g77-defaults.
- * top.c, top.h: New option.
-
-Sat Mar 9 17:49:50 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in (stmp-int-hdrs): Use --no-validate when
- generating the f77.rebuilt files (BUGS, INSTALL, NEWS)
- so cross-references can work properly in g77.info
- without a lot of hassle. Users can probably deal with
- the way they end up looking in the f77.rebuilt files.
-
- * bld.c (ffebld_constant_new_integer4_val): INTEGER*8
- support -- new function.
- (ffebld_constant_new_logical4_val): New function.
- * com.c (ffecom_f2c_longint_type_node): New type.
- (FFECOM_rttypeLONGINT_): New return type code.
- (ffecom_expr_): Add code to invoke pow_qq instead
- of pow_ii for INTEGER4 (INTEGER*8) case.
- If ffecom_expr_power_integer_ returns NULL_TREE, just do
- the usual work.
- (ffecom_make_gfrt_): Handle new type.
- (ffecom_expr_power_integer_): Let caller do the work if in
- dummy-transforming case, since
- caller now knows about INTEGER*8 and such, by returning
- NULL_TREE.
- * expr.c (ffeexpr_reduced_power_): Complain about non-INTEGER
- raised to INTEGER4 (INTEGER*8) power.
-
- * target.c (ffetarget_power_integerdefault_integerdefault):
- Fix any**negative.
- * com.c (ffecom_expr_power_integer_): Fix (-1)**(-8) and similar
- to ABS() the integral result if the exponent is negative
- and even.
-
- * ste.c (ffeste_begin_iterdo_): Clean up a type ref.
- Always convert iteration count to _default_ INTEGER.
-
- * sta.c (ffesta_second_): Add BYTE and WORD type/stmts;
- changes by Scott Snyder <snyder@d0sgif.fnal.gov>.
- * stb.c (ffestb_decl_recursive): Ditto.
- (ffestb_decl_recursive): Ditto.
- (ffestb_decl_entsp_2_): Ditto.
- (ffestb_decl_entsp_3_): Ditto.
- (ffestb_decl_funcname_2_): Ditto.
- (ffestb_decl_R539): Ditto.
- (ffestb_decl_R5395_): Ditto.
- * stc.c (ffestc_establish_declstmt_): Ditto.
- * std.c (ffestd_R539item): Ditto.
- (ffestd_R1219): Ditto.
- * stp.h: Ditto.
- * str-1t.fin: Ditto.
- * str-2t.fin: Ditto.
-
- * expr.c (ffeexpr_finished_): For DO loops, allow
- any INTEGER type; convert LOGICAL (assuming -fugly)
- to corresponding INTEGER type instead of always default
- INTEGER; let later phases do conversion of DO start,
- end, incr vars for implied-DO; change checks for non-integral
- DO vars to be -Wsurprising warnings.
- * ste.c (ffeste_io_impdo_): Convert start, end, and incr
- to type of DO variable.
-
- * com.c (ffecom_init_0): Add new types for [IL][234],
- much of which was done by Scott Snyder <snyder@d0sgif.fnal.gov>.
- * target.c: Ditto.
- * target.h: Ditto.
-
-Wed Mar 6 14:08:45 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * top.c (ffe_init_gbe_): Make -frerun-loop-opt the default.
-
-Mon Mar 4 12:27:00 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c (ffeexpr_exprstack_push_unary_): Really warn only
- about two successive _arithmetic_ operators.
-
- * stc.c (ffestc_R522item_object): Allow SAVE of (understood)
- local entity.
-
- * top.c (ffe_decode_option): New -f(no-)second-underscore options.
- * top.h: New options.
- * com.c (ffecom_get_external_identifier_, ffecom_get_identifier_):
- New options.
-
- * Make-lang.in (f77.maintainer-clean): Clean f/BUGS, f/INSTALL,
- f/NEWS.
- ($(srcdir)/f/BUGS, $(srcdir)/f/INSTALL, $(srcdir)/f/NEWS):
- New rules.
- ($(srcdir)/f/g77.info, $(srcdir)/f/g77.dvi): Depend on
- f/bugs.texi and f/news.texi.
- (f77.install-man): Install f77 man pages (if enabled).
- (f77.uninstall): Uninstall info docs, f77 man pages (if enabled).
-
- * top.c (ffe_init_gbe_): New function.
- (ffe_decode_option, ffe_file): Call ffe_init_gbe_ to
- set defaults for gcc options.
-
-Sat Jan 20 13:57:19 1996 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_get_identifier_): Eliminate needless
- comparison of results of strchr.
-
-Tue Dec 26 11:41:56 1995 Craig Burley <burley@gnu.ai.mit.edu>
-
- * Make-lang.in: Add rules for new files g77.texi, g77.info,
- and g77.dvi.
- Reorganize the *clean rules to more closely parallel gcc's.
-
- * config-lang.in: Exclude g77.info from diffs.
-
-Sun Dec 10 02:29:13 1995 Craig Burley <burley@gnu.ai.mit.edu>
-
- * expr.c (ffeexpr_declare_unadorned_,
- ffeexpr_declare_parenthesized_): Break out handling of
- contextDATAIMPDO[INDEX,CTRL] so it's independent of symbol state.
- Don't exec-transition these here (let ffeexpr_sym_impdoitem_
- handle that when appropriate). Don't "declare" them twice.
-
-Tue Dec 5 06:48:26 1995 Craig Burley <burley@gnu.ai.mit.edu>
-
- * stc.c (ffestc_promote_sfdummy_): Allow whereNONE parent
- symbol, since it is not necessarily known whether it will
- become LOCAL or DUMMY.
-
-Mon Dec 4 03:46:55 1995 Craig Burley <burley@gnu.ai.mit.edu>
-
- * lex.c (ffelex_display_token, ffelex_type_string_): Resurrect
- these from their old versions and update them for possible invocation
- from debugger.
- * lex.h (ffelex_display_token): Declare this in case anyone
- else wants to call it.
-
- * lex.c (ffelex_total_tokens_): Have this reflect actual allocated
- tokens, no longer include outstanding "uses" of tokens.
-
- * malloc.c, malloc.h (MALLOC_DEBUG): New macro to control
- checking of whether callers follow rules, now defaults to 0
- for "no checking" to improve compile times.
-
- * malloc.c (malloc_pool_kill): Fix bug that could prevent
- subpool from actually being killed (wasn't setting its use
- count to 1).
-
- * proj.h, *.c (dmpout): Replace all occurrences of `stdout'
- and some of `stderr' with `dmpout', so where to dump debugging
- output can be easily controlled during build; add default
- for `dmpout' of `stderr' to proj.h.
-
-Sun Dec 3 00:56:29 1995 Craig Burley <burley@gnu.ai.mit.edu>
-
- * com.c (ffecom_return_expr): Eliminate attempt at warning
- about unset return values, since the back end does this better,
- with better wording, and is not triggered by clearly working
- (but spaghetti) code as easily as this test.
-
-Sat Dec 2 08:28:56 1995 Craig Burley <burley@gnu.ai.mit.edu>
-
- * target.c (ffetarget_power_*_integerdefault): Raising 0 to
- integer constant power should not be an error condition;
- if so, other code should catch 0 to any power, etc.
-
- * bad.def (FFEBAD_BAD_POWER): 0**integer now a warning instead
- of an error.
-
-Fri Dec 1 00:12:03 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * bad.def: Clarify diagnostic regarding complex constant elements.
- * expr.c (ffeexpr_cb_comma_c_): Capitalize real/imaginary
- for clarified diagnostic.
-
- * com.c (ffecom_close_include_): Close the file!
-
- * lex.c (ffelex_file_fixed): Update line info if the line
- has any content, not just if it finishes a previous line
- or has a label.
- (ffelex_file_free): Clarify switch statement code.
-
-Sat Nov 18 19:37:22 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.17 released.
-
-Fri Nov 17 14:27:24 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Make-lang.in: Fix typo in comment.
-
- * Makefile.in (f/fini.o, f/proj-h.o): Don't use `$<' since
- not all makes support it (e.g. NeXT make), use explicit
- source name instead (with $(srcdir) and munging).
- (ASSERT_H): assert.h lives in source dir, not build dir.
-
-Thu Nov 16 12:47:50 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_init_0): Fix dumb bug in code to produce
- warning message about non-32-bit-systems.
-
- * stc.c (ffestc_R501_item): Parenthesize test to make
- warning go away (and perhaps fix bug).
-
-Thu Nov 16 03:43:33 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * g77.c: Upgrade to 2.7.0's gcc.c.
- Fix -v to pass a temp name instead of "/dev/null" for "-o".
-
-Fri Nov 10 19:16:05 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * ste.c (ffeste_begin_iterdo_): Add Toon's change to
- make loops faster on some machines (implement termination
- condition as "--i >= 0" instead of "i-- > 0").
-
-Thu Nov 2 03:58:17 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Make-lang.in: Remove unnecessary $(exeext) a la cp/Make-lang.in.
-
- * com.c (ffecom_expr_): Restore old strategy for assignp variant
- of opSYMTER case...always return the ASSIGN version of var.
- That way, `-O -Wuninitialized' will catch "I=3;GOTO I;END"
- (though the diagnostic will refer to `__g77_ASSIGN_i').
-
- * com.c (ffecom_expr_power_integer_): For constant rhs case,
- wrap every new eval of lhs in save_expr() so it is clear to
- back end that MULT_EXPR(lhs,lhs) has identical operands,
- otherwise for an rhs like 32767 it generates around 65K pseudo
- registers, with which stupid_life_analysis cannot cope
- (due to reg_renumber in regs.h being `short *' instead of
- `int *').
-
- * com.c (ffecom_expr_): Speed up implementation of LOGICAL
- versions of opNOT, opAND, opOR, opXOR/opNEQV, and opEQV by
- assuming the values actually are kosher LOGICAL bit patterns.
- Also simplify code that implements some of the INTEGER versions
- of these.
-
- * com.c (skip_redundant_dir_prefix, read_name_map,
- ffecom_open_include_, signed_type, unsigned_type): Fold in
- changes to cccp.c made from 2.7.0 through ss-950826.
-
- * equiv.c (ffeequiv_layout_local_): Kill the equiv list
- if no syms in list.
-
- * expr.c (ffeexpr_reduced_eqop2_): Issue specific diagnostic
- regarding usage of .EQV./.NEQV. in preference to .EQ./.NE..
-
- * intrin.c: Add ERF and ERFC as generic intrinsics.
- intrin.def: Same.
-
- * sta.c (ffesta_save_, ffesta_second_): Whoever calls
- ffestd_exec_begin must also set ffesta_seen_first_exec = TRUE,
- and anytime stc sees an exec transition, it must do both.
- stc.c (ffestc_eof): Same.
-
- * stc.c (ffestc_promote_sfdummy_): If failed implicit typing
- or CHARACTER*(*) arg, after calling ffesymbol_error, don't
- reset info to ENTITY/DUMMY, because ffecom_sym_transform_
- doesn't expect such a thing with ANY/ANY type.
-
- * target.h (*logical*): Change some of these so they parallel
- changes in com.c, e.g. for _eqv_, use (l)==(r) instead of
- !!(l)==!!(r), to get a more faithful result.
-
-Fri Oct 27 07:06:59 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_sym_transform_): Simplify code for local
- EQUIVALENCE case.
-
- * expr.c (ffeexpr_exprstack_push_unary_): Warn about two
- successive operators.
- (ffeexpr_exprstack_push_binary_): Warn about "surprising"
- operator precedence, as in "-2**2".
-
- * lang-options.h: Add -W(no-)surprising options.
-
- * parse.c (yyparse): Don't reset -fpedantic if not -pedantic.
-
- * top.c (ffe_decode_option): Support new -Wsurprising option.
- * top.h: Ditto.
-
-Mon Oct 23 09:14:15 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_finish_symbol_transform_): Don't transform
- NONE/NONE (CHARACTER*(*)) vars, as these don't mean anything
- in debugging terms, and can't be turned into anything
- in the back end (so ffecom_sym_transform_ crashes on them).
-
- * com.c (ffecom_expr_): Change strategy for assignp variant
- of opSYMTER case...always return the original var unless
- it is not wide enough.
-
- * ste.c (ffeste_io_cilist_): Clarify diagnostic for ASSIGN
- involving too-narrow variable. This shouldn't happen, though.
- (ffeste_io_icilist_): Ditto.
- (ffeste_R838): Ditto.
- (ffeste_R839): Ditto.
-
-Thu Oct 19 03:21:20 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_sym_transform_assign_): Set TREE_STATIC
- using the same decision-making process as used for their twin
- variables, so ASSIGN can last across RETURN/CALL as appropriate.
-
-Fri Sep 22 20:21:18 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Makefile.in: fini is a host program, so it needs a host-compiled
- version of proj.o, named proj-h.o. f/fini, f/fini.o, and
- f/proj-h.o targets updated accordingly.
-
- * com.c (__eprintf): New function.
-
-Wed Sep 20 02:26:36 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * lang-options.h: Add omitted -funix-intrinsics-* options.
-
- * malloc.c (malloc_find_inpool_): Check for infinite
- loop, crash if detected (user reports encountering
- them in some large programs, this might help track
- down the bugs).
-
-Thu Sep 7 13:00:32 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (lang_print_error_function): Don't dereference null
- pointer when outside any program unit.
- (ffecom_let_char_, ffecom_arg_ptr_to_expr): If catlist
- item or length ever error_mark_node, don't continue processing,
- since back-end functions like build_pointer_type crash on
- error_mark_node's (due to pushing bad obstacks, etc.).
-
-Wed Aug 30 15:58:35 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.16 released.
-
-Mon Aug 28 12:24:20 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * bad.c (ffebad_finish): Fix botched message when no places
- are printed (due to unknown line info, etc.).
-
- * std.c (ffestd_subr_labels_): Do a better job finding
- line info in the case of typeANY and diagnostics.
-
-Fri Aug 25 15:19:29 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (DECL_ARTIFICIAL): Surround all references to this
- macro with #if !BUILT_FOR_270 and #endif.
- (init_lex): Surround print_error_function decl with
- #if !BUILT_FOR_270 and #endif.
- (lang_init): Call new ffelex_hash_kludge function to solve
- problem with preprocessed files that have INCLUDE statements.
-
- * lex.c (ffelex_getc_): New function.
- (ffelex_cfelex_): Use ffelex_getc_ instead of getc in any
- paths of code that can be affected by ffelex_hash_kludge.
- Don't make an EOF token for unrecognized token; set token
- to NULL instead, to avoid problems when not initialized.
- (ffelex_hash_): Use ffelex_getc_ instead of getc in any
- paths of code that can be affected by ffelex_hash_kludge.
- Test token returned by ffelex_cfelex_ for NULL, meaning
- unrecognized token.
- Get rid of useless used_up variable.
- Don't do ffewhere stuff or kill any tokens if in
- ffelex_hash_kludge.
- (ffelex_file_fixed, ffelex_file_free): Use ffelex_getc_
- instead of getc in any paths of code that can be affected
- by ffelex_hash_kludge.
- (ffelex_hash_kludge): New function.
-
- * lex.h (ffelex_hash_kludge): New function.
-
-Wed Aug 23 15:17:40 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c: Implement -f(no-)underscoring options by always
- compiling in code to do it, and having that code inhibit
- itself when -fno-underscoring is in effect. This option
- overrides -f(no-)f2c for this purpose; -f(no-)f2c returns
- to it's <=0.5.15 behavior of affecting only how code
- is generated, not how/whether names are mangled.
-
- * target.h: Redo specification of appending underscores so
- the macros are named "_default" instead of "_is" and the
- two-underscore macro defaults to 1.
-
- * top.c, top.h (underscoring): Add appropriate stuff
- for the -f(no-)underscoring options.
-
-Tue Aug 22 10:25:01 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * bad.c (ffebad_finish): Call report_error_function (in toplev.c)
- to better identify location of problem.
- Say "(continued):" instead of "(continued:)" for consistency.
-
- * com.c (ffecom_gen_sfuncdef_): Set and reset new
- ffecom_nested_entry_ variable to hold ffesymbol being compiled.
- (lang_print_error_function): New function from toplev.c.
- Use ffecom_nested_entry_ to help determine which name
- and kind-string to print.
- (ffecom_expr_intrinsic_): Handle EXIT and FLUSH invocations
- with different calling sequences than library functions.
- Have SIGNAL and SYSTEM push and pop calltemps, and convert
- their return values to the destination type (just in case).
- (FFECOM_rttypeINT_): New return type for `int', in case
- gcc/f/runtime/libF77/system_.c(system_) is really supposed
- to return `int' instead of `ftnint'.
-
- * com.h (report_error_function): Declare this.
-
- * equiv.c (ffeequiv_layout_local_): Don't forget to consider
- root variable itself as possible "first rooted variable",
- else might never set symbol and then crash later.
-
- * intrin.c (ffeintrin_check_exit_): Change to allow no args
- and rename to ffeintrin_check_int_1_o_ for `optional'.
- #define ffeintrin_check_exit_ and _flush_ to this new
- function, so intrin.def can refer to the appropriate names.
-
- * intrin.def (FFEINTRIN_impFLUSH): Validate using
- ffeintrin_check_flush_ so passing an INTEGER arg is allowed.
-
- * lex.c (ffelex_file_push_, ffelex_file_pop_): New functions
- to manage input_file_stack in gbe.
- (ffelex_hash_): Call new functions (instead of doing code).
- (ffelex_include_): Call new functions to update stack for
- INCLUDE (_hash_ handles cpp output of #include).
-
-Mon Aug 21 08:09:04 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Makefile.in: Put `-W' in front of every `-Wall', since
- 2.7.0 requires that to engage `-Wunused' for parameters.
-
- * com.c: Mark all parameters as artificial, so
- `-W -Wunused' doesn't complain about unused ones (since
- there's no way right not to individually specify attributes
- like `unused').
-
- * proj.h: Don't #define UNUSED if already defined, regardless
- of host compiler.
-
-Sun Aug 20 16:03:56 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * gbe/2.7.0.diff: Regenerate.
-
- * lang-options.h, lang-specs.h: If not __STDC__ (ANSI C),
- avoid doing anything, especially the stringizing in -specs.h.
-
-Thu Aug 17 03:36:12 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * lang-specs.h: Remove useless optional settings of -traditional,
- since -traditional is always set anyway.
-
-Wed Aug 16 16:56:46 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Make-lang.in (F2C_INSTALL_FLAG, F2CLIBOK): More
- control over whether to install f2c-related stuff.
- (install-f2c-*): New targets to install f2c-related
- stuff in system, not just gcc, directories.
-
- * com.c: Change calls to ffecom_get_invented_identifier
- to use generally more predictable names.
- Change calls to build_range_type to ensure consistency
- of types of operands.
- (ffecom_get_external_identifier_): Change to accept
- symbol info, not just text, so it can use f2c flag for
- symbol to decide whether to append underscore(s).
- (ffecom_get_identifier_): Don't change names if f2c flag
- off for compilation.
- (ffecom_type_permanent_copy_): Use same type for new max as
- used for min.
- (ffecom_notify_init_storage): Offline fixups for stand-alone.
-
- * data.c (ffedata_gather): Explicitly test for common block,
- since it's no longer always the case that a local EQUIVALENCE
- group has no symbol ptr (it now can, if a user-predictable
- "rooted" symbol has been identified).
-
- * equiv.c: Add some debugging stuff.
- (ffeequiv_layout_local_): Set symbol ptr with user-predictable
- "rooted" symbol, for giving the invented aggregate a
- predictable name.
-
- * g77.c (append_arg): Allow for 20 extra args instead of 10.
- (main): For version-only case, add `-fnull-version' and, unless
- explicitly omitted, `-lf2c -lm'.
-
- * lang-options.h: New "-fnull-version" option.
-
- * lang-specs.h: Support ".fpp" suffix for preprocessed source
- (useful for OS/2, MS-DOS, other case-insensitive systems).
-
- * stc.c (ffestc_R544_equiv_): Swap way lists are merged so this
- is consistent with the order in which lists are built, making
- user predictability of invented aggregate name much higher.
-
- * storag.c, storag.h (FFESTORAG_typeDUMMY): Delete this enum.
-
- * top.c: Accept, but otherwise ignore, `-fnull-version'.
-
-Tue Aug 15 07:01:07 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * DOC, INSTALL, PROJECTS: Extensive improvements to documentation.
-
-Sun Aug 13 01:55:18 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * INSTALL (f77-install-ok): Document the use of this file.
-
- * Make-lang.in (F77_INSTALL_FLAG): New flag to control
- whether to install an `f77' command (based on whether
- a file named `f77-install-ok' exists in the source or
- build directory) to replace the broken attempt to use
- comment lines to avoid installing `f77' (broken in the
- sense that it prevented installation of `g77').
-
-Mon Aug 7 06:14:26 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * DOC: Add new sections for g77 & gcc compiler options,
- source code form, and types, sizes and precisions.
- Remove lots of old "delta-version" info, or at least
- summarize it.
-
- * INSTALL: Add info here that used to be in DOC.
- Other changes.
-
- * g77.c (lookup_option, main): Check for --print-* options,
- so we avoid adding version-determining stuff.
-
-Wed Jul 26 15:51:03 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Make-lang.in, Makefile.in (input.j, INPUT_H): New file.
- Update dependencies accordingly.
-
- * bad.c (ffebad_here): Okay to use unknown line/col.
-
- * compilers.h (@f77-cpp-input): Remove -P option now that
- # directives are handled by f771. Update other options
- to be more consistent with @c in gcc/gcc.c. Don't run f771
- if -E specified, etc., a la @c.
- (@f77): Don't run f771 if -E specified, etc., a la @c.
-
- * config-lang.in: Avoid use of word "guaranteed".
-
- * input.j: New file to wrap around gcc/input.h.
-
- * lex.j: Add support for parsing # directives output by cpp.
- (ffelex_cfebackslash_): New function.
- (ffelex_cfelex_): New function.
- (ffelex_get_directive_line_): New function.
- (ffelex_hash_): New function.
- (ffelex_include_): Change to not use ffewhere_file_(begin|end).
- Also fix bug in pointing to next line (for diagnostics, &c)
- following successful INCLUDE.
- (ffelex_next_line_): New function that does chunk of code
- seen in several places elsewhere in the lexers.
- (ffelex_file_fixed): Delay finishing statement until source
- line is registered with ffewhere, so INCLUDE processing
- picks up the info correctly.
- Okay to kill or use unknown line/col objects now.
- Handle HASH (#) lines.
- Reorder tests for insubstantial lines to put most frequent
- occurrences at top, for possible minor speedup.
- Some general consolidation of code.
- (ffelex_file_free): Handle HASH (#) lines.
- Okay to kill or use unknown line/col objects now.
- Some general consolidation of code.
- (ffelex_init_1): Detect HASH (#) lines.
- (ffelex_set_expecting_hollerith): Okay to kill or use unknown
- line/col objects now.
-
- * lex.h (FFELEX_typeHASH): New enum.
-
- * options-lang.h (-fident, -fno-ident): New options.
-
- * stw.c (ffestw_update): Okay to kill unknown line/col objects
- now.
-
- * target.h (FFETARGET_okREALQUAD, FFETARGET_okCOMPLEXDOUBLE,
- FFETARGET_okCOMPLEXQUAD): #define these appropriately.
-
- * top.c: Include flag.j wrapper, not flags.h directly.
- (ffe_is_ident_): New flag.
- (ffe_decode_option): Handle -fident and -fno-ident.
- (ffe_file): Replace obsolete ffewhere_file_(begin|end) with
- ffewhere_file_set.
-
- * top.h (ffe_is_ident_, ffe_is_ident, ffe_set_is_ident):
- New flag and access functions.
-
- * where.c, where.h: Remove all tracking of parent file.
- (ffewhere_file_begin, ffewhere_file_end): Delete these.
- (ffewhere_line_use): Make it work with unknown line object.
-
-Mon Jul 17 03:04:09 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_sym_transform_): Set DECL_IN_SYSTEM_HEADER
- flag for any local vars used as stmtfunc dummies or DATA
- implied-DO iter vars, so no -Wunused warnings are produced
- for them (a la f2c).
- (ffecom_init_0): Do "extern int xargc;" for IARGC() intrinsic.
- Warn if target machine not 32 bits, since g77 isn't yet
- working on them at all well.
-
- * expr.c (ffeexpr_sym_lhs_call_, ffeexpr_sym_lhs_data_,
- ffeexpr_sym_lhs_extfunc_, ffeexpr_sym_rhs_actualarg_,
- ffeexpr_sym_rhs_let_, ffeexpr_paren_rhs_let_): Don't
- gratuitously set attr bits that don't apply just
- to avoid null set meaning error; instead, use explicit
- error flag, and allow null attr set, to
- fix certain bugs discovered by looking at this code.
-
- * g77.c: Major changes to improve support for gcc long options,
- to make `g77 -v' report more useful info, and so on.
-
-Mon Jul 3 14:49:16 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * DOC, com.c, intrin.h, intrin.c, intrin.def, target.h, top.c,
- top.h: Add new `unix' group of intrinsics, which includes the
- newly added ERF, ERFC, EXIT, plus even newer ABORT, DERF, DERFC,
- FLUSH, GETARG, GETENV, SIGNAL, and SYSTEM.
-
-Tue Jun 27 23:01:05 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * bld.c, bld.h (ffebld_constant_pool,
- ffebld_constant_character_pool): Use a single macro (the
- former) to access the pool for allocating constants, instead
- of latter in public and FFEBLD_CONSTANT_POOL_ internally
- in bld.c (which was the only one that was correct before
- these changes). Add verification of integrity of certain
- heap-allocated areas.
-
- * com.c (ffecom_overlap_, ffecom_args_overlap_,
- ffecom_tree_canonize_ptr_, ffecom_tree_canonize_ref_): New
- functions to optimize calling COMPLEX and, someday, CHARACTER
- functions requiring additional argument to be passed.
- (ffecom_call_, ffecom_call_binop_, ffecom_expr_,
- ffecom_expr_intrinsic_): Change calling
- sequences to include more info on possible destination.
- (ffecom_expr_intrinsic_): Add ERF(), ERFC(), and EXIT()
- intrinsic code.
- (ffecom_sym_transform_): For assumed-size arrays, set high
- bound to highest possible value instead of low bound, to
- improve validity of overlap checking.
- (duplicate_decls): If olddecl and newdecl are the same,
- don't do any munging, just return affirmative.
-
- * expr.c: Change ffecom_constant_character_pool() to
- ffecom_constant_pool().
-
- * info.c (ffeinfo_new): Compile this version if not being
- compiled by GNU C.
-
- * info.h (ffeinfo_new): Don't define macro if not being
- compiled by GNU C.
-
- * intrin.c, intrin.def: Add ERF(), ERFC(), and EXIT() intrinsics.
- (ffeintrin_check_exit_): New for EXIT() subroutine intrinsic.
-
- * malloc.c, malloc.h (malloc_verify_*): New functions to verify
- integrity of heap-storage areas.
-
- * stc.c (ffestc_R834, ffestc_R835): Handle possibility that
- an enclosing DO won't have a construct name even when the
- CYCLE/EXIT does (i.e. without dereferencing NULL).
-
- * target.c, target.h (ffetarget_verify_character1): New function
- to verify integrity of heap storage used to hold character constant.
-
-Thu Jun 22 15:36:39 1995 Howard Gordon (flash@super.org)
-
- * stp.h (ffestpVxtcodeIx): Fix typo in typedef for this.
-
-Mon May 29 15:22:31 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * *: Make all sorts of changes to accommodate upcoming gcc-2.7.0.
- I didn't keep track of them, nor just when I made them, nor
- when I (much later, probably in early August 1995) modified
- them so they could properly handle both 2.7.0 and 2.6.x.
-
- * com.c (ffecom_expr_power_integer_): Don't expand_start_stmt_expr
- if transforming dummy args, because the back end cannot handle
- that (it's rejected by the gcc front end), just generate
- call to run-time library.
- Back out changes in 0.5.15 because more temporaries might be
- needed anyway (for COMPLEX**INTEGER).
- (ffecom_push_tempvar): Remove inhibitor.
- Around start_decl and finish_decl (in particular, arround
- expand_decl, which is called by them), push NULL_TREE into
- sequence_rtl_expr, an external published by gcc/function.c.
- This makes sure the temporary is truly in the function's
- context, not the inner context of a statement-valued expression.
- (I think the back end is inconsistent here, but am not
- interested in convincing the gbe maintainers about this now.)
- (pushdecl): Make sure that when pushing PARM_DECLs, nothing
- other than them are pushed, as happened for 0.5.15 and which,
- if done for other reasons not fixed here, might well indicate
- some other problem -- so crash if it happens.
-
- * equiv.c (ffeequiv_layout_local_): If the local equiv group
- has a non-nil COMMON field, it should mean that an error has
- occurred and been reported, so just trash the local equiv
- group and do nothing.
-
- * stc.c (ffestc_promote_sfdummy_): Set sfdummy arg state to
- UNDERSTOOD so above checking for duplicate args actually
- works, and so we don't crash later in pushdecl.
-
- * ste.c (ffeste_R1001): Set initial value only for VAR_DECLs,
- not for, e.g., LABEL_DECLs, which the FORMAT label can be
- if it was previously treated as an executable label.
-
-Sat May 20 01:53:53 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_sym_transform_): For adjustable arrays,
- pass high bound through variable_size in case its primaries
- are changed (dumb0.f, and this might also improve
- performance so it approaches f2c|gcc).
-
-Fri May 19 11:00:36 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.15 released.
-
- * com.c (ffecom_expr_power_integer_): Push temp vars
- before expanding a statement expression, since that seems
- to cause temp vars to be "forgotten" after the end of the
- expansion in the back end. Disallow more temp-var
- pushing during such an expansion, just in case.
- (ffecom_push_tempvar): Crash if a new variable needs to be
- pushed but cannot be at this point (should never happen).
-
-Wed May 17 12:26:16 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * expr.c (ffeexpr_collapse_convert): Add code to convert
- LOGICAL to CHARACTER. Reject conversion of REAL or COMPLEX
- to CHARACTER entirely, as it cannot be supported with all
- configurations.
-
- * target.h, target.c (ffetarget_convert_character1_logical1):
- New function.
-
-Sun May 14 00:00:09 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_do_entry_, ffecom_gen_sfuncdef_,
- ffecom_start_progunit_, ffecom_sym_transform_,
- ffecom_init_0, start_function): Changes to have REAL
- external functions return same type as DOUBLE PRECISION
- external functions when -ff2c is in force; while at it,
- some code cleanups done.
-
- * stc.c (ffestc_R547_item_object): Disallow array declarator
- if one already exists for symbol.
-
- * ste.c (ffeste_R1227): Convert result variable to type
- of function result as seen by back end (e.g. for when REAL
- external function actually returns result as double).
-
- * target.h (FFETARGET_defaultFIXED_LINE_LENGTH): New
- macro for default for -ffixed-line-length-N option.
-
- * top.c (ffe_fixed_line_length_): Initialize this to new
- target.h macro instead of constant 72.
-
-Tue May 9 01:20:03 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * lex.c (ffelex_send_token_): If sending CHARACTER token with
- null text field, put a single '\0' in it and set length/size
- fields to 0 (to fix 950508-0.f).
- (ffelex_image_char_): When setting ffelex_bad_line_ to TRUE,
- always "close" card image by appending a null char and setting
- ffelex_card_length_. As part of this, append useful text
- to identify the two kinds of problems that involve this.
- (ffelex_file_fixed): Reset ffelex_bad_line_ to FALSE after
- seeing a line with invalid first character (fixes 950508-1.f).
- If final nontab column is zero, assume tab seen in line.
- (ffelex_card_image_): Always make this array 8 characters
- longer than reflected by ffelex_card_size_.
- (ffelex_init_1): Get final nontab column info from top instead
- of assuming 72.
-
- * options-lang.h: Add -ffixed-line-length- prefix.
-
- * top.h: Add ffe_fixed_line_length() and _set_ version, plus
- corresponding extern.
-
- * top.c: Handle -ffixed-line-length- option prefix.
-
-Fri Apr 28 05:40:25 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.14 released.
-
- * Make-lang.in: Add assert.j.
-
- * Makefile.in: Add assert.j.
-
- * assert.j: New file.
-
-Thu Apr 27 16:24:22 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * bad.h (ffebad_severity): New function.
-
- * bad.c (ffebad_severity): New function.
-
- * bad.def (FFEBAD_OPEN_INCLUDE): Change severity from SEVERE
- to FATAL, since processing continues, and that seems fine.
-
- * com.c: Add facility to handle -I.
- (ffecom_file, ffecom_close_include, ffecom_open_include,
- ffecom_decode_include_option): New global functions for -I.
- (ffecom_file_, ffecom_initialize_char_syntax_,
- ffecom_close_include_, ffecom_decode_include_option_,
- ffecom_open_include_, append_include_chain, open_include_file,
- print_containing_files, read_filename_string, file_name_map,
- savestring): New internal functions for -I.
-
- * compilers.h: Pass -I flag(s) to f771 (via "%{I*}").
-
- * lex.c (ffelex_include_): Call ffecom_close_include
- to close include file, for its tracking needs for -I,
- instead of using fclose.
-
- * options-lang.h: Add -I prefix.
-
- * parse.c (yyparse): Call ffecom_file for main input file,
- so -I handling works (diagnostics).
-
- * std.c (ffestd_S3P4): Have ffecom_open_include handle
- opening and diagnosing errors with INCLUDE files.
-
- * ste.c (ffeste_begin_iterdo_): Use correct algorithm for
- calculating # of iterations -- mathematically similar but
- computationally different algorithm was not handling cases
- like "DO I=6,5,2" correctly, because (5-6)/2+1 => 1, not 0.
-
- * top.c (ffe_decode_option): Allow -I, restructure a bit
- for clarity and, maybe, speed.
-
-Mon Apr 17 13:31:11 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * g77.c: Remove -lc, turns out not all systems has it, but
- leave other changes in for clarity of code.
-
-Sun Apr 16 21:50:33 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_expr_): Implement ARRAY_EXPR as INDIRECT_REF
- of appropriate PLUS_EXPRs of ptr_to_expr of array, to see
- if this generates better code. (Conditional on
- FFECOM_FASTER_ARRAY_REFS.)
-
-Sun Apr 16 00:22:48 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Make-lang.in (F77_SRCS): Remove g77.c, since it doesn't
- contribute to building f771.
-
- * Makefile.in (dircheck): Remove/replace with f/Makefile, because
- phony targets that are referenced in other real targets get run
- when those targets are specified, which is a waste of time (e.g.
- when rebuilding and only g77.c has changed, f771 was being linked
- anyway).
-
- * g77.c: Include -lc between -lf2c and -lm throughout.
-
- * implic.c (ffeimplic_establish_symbol): If -Wimplicit, warn if
- implicit type given to symbol.
-
- * lex.c (ffelex_include_): Don't gratuitously increment line
- number here.
-
- * top.h, top.c (ffe_is_warn_implicit_): New global variable and
- related access macros.
- (ffe_decode_option): Handle -W options, including -Wall and
- -Wimplicit.
-
- * where.c (ffewhere_line_new): Don't muck with root line (was
- crashing on null input since lexer changes over the past week
- or so).
-
-Thu Apr 13 16:48:30 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_init_0): Register built-in functions for cos,
- sin, and sqrt.
- (ffecom_tree_fun_type_double): New variable.
- (ffecom_expr_intrinsic_): Update f2c input and output files
- to latest version of f2c (no important g77-related changes
- noted, just bug fixes to f2c and such).
- (builtin_function): New function from c-decl.c.
-
- * com-rt.def: Refer to built-in functions for cos, sin, and sqrt.
-
-Thu Apr 13 10:25:09 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_expr_intrinsic_): Convert 0. to appropriate
- type to keep DCMPLX(I) from crashing the compiler.
- (ffecom_expr_): Don't convert result from ffecom_tree_divide_.
- (ffecom_tree_divide_): Add tree_type argument, have all callers
- pass one, and don't convert right-hand operand to it (this is
- to make this new function work as much like the old in-line
- code used in ffecom_expr_ as possible).
-
- * lex.c: Maintain lineno and input_filename the way the gcc
- lexer does.
-
- * std.c (ffestd_exec_end): Save and restore lineno and
- input_filename around the second pass, which sets them
- appropriately for each saved statement.
-
-Wed Apr 12 09:44:45 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_expr_power_integer_): New function.
- (ffecom_expr_): Call new function for power op with integer second
- argument, for generating better code. Also replace divide
- code with call to new ffecom_tree_divide_ function.
- Canonicalize calls to ffecom_truth_value(_invert).
- (ffecom_tree_divide_): New function.
-
-Wed Apr 5 14:15:44 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * lex.c: Change to allocate text for tokens only when actually
- needed, which should speed compilation up somewhat.
- Change to allow INCLUDE at any point where a statement
- can end, i.e. in ffelex_finish_statement_ or when a SEMICOLON
- token is sent.
- Remove some old, obsolete code.
- Clean up layout of entire file to improve formatting,
- readability, etc.
- (ffelex_set_expecting_hollerith): Remove include argument.
-
-Fri Mar 31 23:19:08 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * bad.h, bad.c (ffebad_start_msg, ffebad_start_msg_lex):
- New functions to generate arbitrary messages.
- (FFEBAD_severityPEDANTIC): New severity, to correspond
- to toplev's pedwarn() function.
-
- * lex.c (ffelex_backslash_): New function to implement
- backslash processing.
- (ffelex_file_fixed, ffelex_file_free): Implement new
- backslash processing.
-
- * std.c (ffestd_R1001dump_): Don't assume CHARACTER and
- HOLLERITH tokens stop at '\0' characters, now that backslash
- processing is supported -- use their advertised lengths instead,
- and double up the '\002' character for libf2c.
-
-Mon Mar 27 17:10:33 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_init_local_zero_): Implement -finit-local-zero.
- (ffecom_sym_transform_): Same.
- (ffecom_transform_equiv_): Same.
-
- * options-lang.h: Add -f(no-)(init-local-zero,backslash,ugly-init).
-
- * stb.c (ffestb_V020): Reject "TYPEblah(...", which might be
- an array assignment.
-
- * target.h, top.h, top.c: Implement -finit-local-zero.
-
-Fri Mar 24 19:56:22 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Make-lang.in, Makefile.in: Remove conf-proj(.in) and
- proj.h(.in) rules, plus related config.log, config.cache,
- and config.status stuff.
-
- * com.c (ffecom_init_0): Change messages when atof(), bsearch(),
- or strtoul() do not work as expected in the start-up test.
-
- * conf-proj, conf-proj.in: Delete.
-
- * lex.c (ffelex_file_fixed): Allow f2c's '&' in column 1
- to mean continuation line.
-
- * options-lang.h: New file, #include'd by ../toplev.c.
-
- * proj.h.in: Rename back to proj.h.
-
- * proj.h (LAME_ASSERT): Remove.
- (LAME_STDIO): Remove.
- (NO_STDDEF): Remove.
- (NO_STDLIB): Remove.
- (NO_BSEARCH): Remove auto detection, rename to !FFEPROJ_BSEARCH.
- (NO_STRTOUL): Remove auto detection, rename to !FFEPROJ_STRTOUL.
- (USE_HOST_LIMITS): Remove (maybe still needed by stand-alone?).
- (STR, STRX): Do only ANSI C definitions.
-
-Mon Mar 13 10:46:13 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * BUGS: Add item about g77 requiring gcc to compile it.
-
- * NEWS: New file listing user-visible changes in the release.
-
- * PROJECTS: Update to include a new item or two, and modify
- or delete items that are addressed in this or previous releases.
-
- * bad.c (ffebad_finish): Don't crash if missing string &c,
- just substitute obviously distressed string "[REPORT BUG!!]"
- for cases where the message/caller are fudgy.
-
- * bad.def: Clean up error messages in a major way, add new ones
- for use by changes in target.c.
-
- * com.c (ffecom_expr_): Handle opANY in opCONVERT.
- (ffecom_let_char_): Disregard destinations with ERROR_MARK.
- (ffecom_1, ffecom_1_fn, ffecom_2, ffecom_2s, ffecom_3,
- ffecom_3s, &c): Check all inputs for error_mark_node.
- (ffecom_start_progunit_): Don't transform all symbols
- in BLOCK DATA, since it never executes, and it is silly
- to, e.g., generate all the structures for NAMELIST.
- (ffecom_char_length_expr_): Rename to ffecom_intrinsic_len_.
- (ffecom_intrinsic_ichar_): New function to handle ICHAR of
- arbitrary expression with possible 0-length operands.
- (ffecom_expr_intrinsic_): Use ffecom_intrinsic_char_.
- For MVBITS, set tree_type to void_type_node.
- (ffecom_start_progunit_): Name master function for entry points
- after primary entry point so users can easily guess it while
- debugging.
- (ffecom_arg_ptr_to_expr): Change treatment of Hollerith,
- Typeless, and %DESCR.
- (ffecom_expr_): Change treatment of Hollerith.
-
- * data.c (ffedata_gather_): Handle opANY in opCONVERT.
-
- * expr.c (ffeexpr_token_apostrophe_): Issue FFEBAD_NULL_CHAR_CONST
- warning as necessary.
- (ffeexpr_token_name_rhs_): Set context for args to intrinsic
- so that assignment-like concatenation is allowed for ICHAR(),
- IACHAR(), and LEN() intrinsics.
- (ffeexpr_reduced_*_): Say "an array" instead of "an entity" in
- diagnostics, since it's more informative.
- (ffeexpr_finished_): For many contexts, check for null expression
- and array before trying to do a conversion, to avoid redundant
- diagnostics.
-
- * g77.1: Fix typo for preprocessed suffix (.F, not .f).
-
- * global.c (ffeglobal_init_common): Warn if initializing
- blank common.
- (ffeglobal_pad_common): Enable code to warn if initial
- padding needed.
- (ffeglobal_size_common): Complain if enlarging already-
- initialized common, since it won't work right anyway.
-
- * intrin.c: Add IMAG() intrinsic.
- (ffeintrin_check_loc_): Allow opSUBSTR in LOC().
-
- * intrin.def: Add IMAG() intrinsic.
-
- * lex.c: Don't report FFEBAD_NULL_CHAR_CONST errors.
-
- * sta.c, sta.h, stb.c: Changes to clean up error messages (see
- bad.def).
-
- * stb.c (ffestb_R100113_): Issue FFEBAD_NULL_CHAR_CONST
- warning as necessary.
-
- * stc.c (ffestc_shriek_do_): Don't try to reference doref_line
- stuff in ANY case, since it won't be valid.
- (ffestc_R1227): Allow RETURN in main program unit, with
- appropriate warnings/errors.
- (ffestc_subr_format_): Array of any type is a CHAREXPR (F77 C5).
-
- * ste.c (ffeste_begin_doiter_): Couple of fixes to accurately
- determine if loop never executes.
-
- * target.c (ffetarget_convert_*_hollerith_): Append spaces,
- not zeros, to follow F77 Appendix C, and to warn when
- truncation of non-blanks done.
- (ffetarget_convert_*_typeless): Rewrite to do typeless
- conversions properly, and warn when truncation done.
- (ffetarget_print_binary, ffetarget_print_octal,
- ffetarget_print_hex): Rewrite to use new implementation of
- typeless.
- (ffetarget_typeless_*): Rewrite to use new implementation
- of typeless, and to warn about overflow.
-
- * target.h (ffetargetTypeless): New implementation of
- this type.
-
- * type.h, type.c (ffetype_size_typeless): Remove (incorrect)
- implementation of this function and its extern.
-
-Sun Mar 5 18:46:42 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * BUGS: Clarify that constant handling would also fix lack of
- adequate IEEE-754/854 support to some degree, and typeless
- and non-decimal constants.
-
- * com.c (ffecom_type_permanent_copy_): Comment out to avoid
- warnings.
- (duplicate_decls): New function a la gcc/c-decl.c.
- (pushdecl): Use duplicate_decls to decide whether to return
- existing decl or new one, instead of always returning existing
- decl.
- (ffecom_expr_): opPERCENT_LOC now supports CHARACTER arguments.
- (ffecom_init_0): Give f2c I/O code 0 for basictypeANY/kindtypeANY.
- (ffecom_sym_transform_): For adjustable arrays, pass low bound
- through variable_size in case its primaries are changed (950302-1.f).
-
- * com.h: More decls that belong in tree.h &c.
-
- * data.c (ffedata_eval_integer1_): Fix opPAREN case to not
- treat value of expression as an error code.
-
- * expr.c (ffeexpr_finished_): Allow opSUBSTR in contextLOC case.
-
- * proj.c: Add "const" as appropriate.
-
-Mon Feb 27 10:04:03 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * bad.def (FFEBAD_BAD_SUBSTR): Fix bad grammar in message.
-
-Fri Feb 24 16:21:31 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.13 released.
-
- * INSTALL: Warn that f/zzz.o will compare differently between
- stages, since it puts the __TIME__ macro into a string.
-
- * com.c (ffecom_sym_transform_): Transform kindFUNCTION/whereDUMMY
- to pointer-to-function, not function.
- (ffecom_expr_): Use ffecom_arg_ptr_to_expr instead of
- ffecom_char_args_ to handle comparison between CHARACTER
- types, so either operand can be a CONCATENATE.
- (ffecom_transform_common_): Set size of initialized common area
- to global (largest-known) size, even though size of init might
- be smaller.
-
- * equiv.c (ffeequiv_offset_): Check symbol info for ANY.
-
- * expr.c (ffeexpr_find_close_paren_, ffeexpr_nil_*): New functions
- to handle following the contour of a rejected expression, so
- statements like "PRINT(I,I,I)=0" don't cause the PRINT statement
- code to get the second passed back to it as if there was a
- missing close-paren before it, the comma causing the PRINT code
- to confirm the statement, resulting in an ambiguity vis-a-vis
- the let statement code.
- Use the new ffecom_find_close_paren_ handler when an expected
- close-paren is missing.
- (ffeexpr_isdigits_): New function, use in all places that
- currently use isdigit in repetitive code.
- (ffeexpr_collapse_symter): Collapse to ANY if init-expr is ANY,
- so as to avoid having symbol get "transformed" if used to
- dimension an array.
- (ffeexpr_token_real_, ffeexpr_token_number_real_): Don't issue
- diagnostic about exponent, since it'll be passed along the
- handler path, resulting in a diagnostic anyway.
- (ffeexpr_token_apos_char_): Use consistent handler path
- regardless of whether diagnostics inhibited.
- (ffeexpr_token_name_apos_name_): Skip past closing quote/apos
- even if not a match or other diagnostic issued.
- (ffeexpr_sym_impdoitem_): Exec-transition local SEEN symbol.
-
- * lex.c (ffelex_image_char_): Set ffelex_saw_tab_ if TAB
- seen, not if anything other than TAB seen!
-
- * stc.c (ffestc_R537_item): If source is ANY but dest isn't,
- set dest symbol's init expr to ANY.
- (ffestc_R501_attrib, ffestc_R522, ffestc_R522start): Complain
- about conflict between "SAVE" by itself and other uses of
- SAVE only in pedantic mode.
-
- * ste.c (ffeste_R1212): Fix loop over labels to always
- increment caseno, to avoid pushcase returning 2 for duplicate
- values when one of the labels is invalid.
-
-Thu Feb 23 12:42:04 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.12 released.
-
- * Make-lang.in (f77.install-common): Add "else true;" before outer
- "fi" per Makefile.in patch.
-
- * Makefile.in (dircheck): Add "else true;" before "fi" per
- patch from chs1pm@surrey.ac.uk.
-
- * com.c (ffecom_push_tempvar): If type desired is ERROR_MARK,
- return error_mark_node, to avoid crash that results from
- making a VAR_DECL with error_mark_node as its type.
-
- * ste.c (ffeste_begin_iterdo_): Convert itercount to INTEGER
- anytime calculation of number of iterations ends up with type
- other than INTEGER (e.g. DOUBLE PRECISION, REAL).
-
-Thu Feb 23 02:48:38 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.11 released.
-
- * DOC: Explain -fugly-args.
-
- * bad.def (FFEBAD_ACTUALARG): Explain -fugly-args and how to
- rewrite code to not require it.
-
- * com.c (ffecom_vardesc_): Handle negative type code, just in
- case.
- (ffecom_arg_ptr_to_expr): Let ffecom_expr handle hollerith
- and typeless constants (move code to ffecom_constantunion).
- (ffecom_constantunion): Handle hollerith and typeless constants.
-
- * expr.c (ffecom_finished_): Check -fugly-args in actual-arg
- context where hollerith/typeless provided.
-
- * intrin.def (FFEINTRIN_genDFLOAT): Add FFEINTRIN_specDFLOAT.
- (FFEINTRIN_specDFLOAT): Add as f2c intrinsic.
-
- * target.h (ffetarget_convert_real[12]_integer,
- ffetarget_convert_complex[12]_integer): Pass -1 for high integer
- value if low part is negative.
- (FFETARGET_defaultIS_UGLY_ARGS): New macro.
-
- * top.c (ffe_is_ugly_args_): New variable.
- (ffe_decode_option): Handle -fugly-args and -fno-ugly-args.
-
- * top.h (ffe_is_ugly_args_, ffe_is_ugly_args(),
- ffe_set_is_ugly_args()): New variable and macros.
-
-Thu Feb 23 02:48:38 1995 Pedro A M Vazquez (vazquez@iqm.unicamp.br)
-
- * g77.c (sys_errlist): Use const for __FreeBSD__ systems
- as well.
-
-Wed Feb 22 13:33:43 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.10 released.
-
- * CREDITS: Add Rick Niles.
-
- * INSTALL: Note how to get around lack of makeinfo.
-
- * Make-lang.in (f/proj.h): Remove # comment.
-
- * Makefile.in (f/proj.h): Remove # comment.
-
- * com.c (ffecom_expr_): Simplify opFUNCREF/opSUBRREF conversion.
- (ffecom_sym_transform_): For whereGLOBAL and whereDUMMY
- kindFUNCTION, use ffecom_tree_fun_type[][] only for non-constant
- (non-statement-function) f2c functions.
- (ffecom_init_0): ffecom_tree_fun_type[][] and _ptr_to_*_* are
- really f2c-interface arrays, so use base type void for COMPLEX
- (like CHARACTER).
-
-Tue Feb 21 19:01:18 1995 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (f77.install-common): Expurgate the test for and
- possible installation of f2c in line with elsewhere. Seems to have
- been missing a semicolon anyhow!
-
-Tue Feb 21 11:45:25 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.9 released.
-
- * Make-lang.in (f/proj.h): touch file to register update,
- because the previous commands won't necessarily modify it.
-
- * Makefile.in (f/proj.h): touch file to register update,
- because the previous commands won't necessarily modify it.
-
- * Makefile.in (f/str-*.h, f/str-*.j): Explicitly specify
- output file names, so these targets go in build, not source,
- directory.
-
- * bits.c, bits.h: Switch to valid ANSI C replacement for
- ARRAY_ZERO.
-
- * com.c (ffecom_expr_): Add assignp arg to support ASSIGN better.
- If assignp is TRUE, use different tree for FFEBLD_opSYMTER case.
- (ffecom_sym_transform_assign_): New function.
- (ffecom_expr_assign): New function.
- (ffecom_expr_assign_w): New function.
-
- * com.c (ffecom_f2c_make_type_): Do make_signed_type instead
- of make_unsigned_type throughout.
-
- * com.c (ffecom_finish_symbol_transform_): Expand scope of
- commented-out code to probably produce faster compiler code.
-
- * com.c (ffecom_gen_sfuncdef_): Push/pop calltemps so
- COMPLEX works right.
- Remove obsolete comment.
-
- * com.c (ffecom_start_progunit_): If non-multi alt-entry
- COMPLEX function, primary (static) entry point returns result
- directory, not via extra arg -- to agree with ffecom_return_expr
- and others.
- Pretransform all symbols so statement functions are defined
- before any code emitted.
-
- * com.c (ffecom_finish_progunit): Don't posttransform all
- symbols here -- pretransform them instead.
-
- * com.c (ffecom_init_0): Don't warn about possible ASSIGN
- crash, as this shouldn't happen now.
-
- * com.c (ffecom_push_tempvar): Fix to handle temp vars
- pushed while context is a statement (nested) function, and
- add appropriate commentary.
-
- * com.c (ffecom_return_expr): Check TREE_USED to determine
- where return value is unset.
-
- * com.h (struct _ffecom_symbol_): Add note about length_tree
- now being used to keep tree for ASSIGN version of symbol.
-
- * com.h (ffecom_expr_assign, ffecom_expr_assign_rw): New decls.
- (error): Add this prototype for back-end function.
-
- * fini.c (main): Grab input, output, and include names
- directly off the command line instead of making the latter
- two out of the first.
-
- * lex.c: Improve tab handling for both fixed and free source
- forms, and ignore carriage-returns on input, while generally
- improving the code. ffelex_handle_tab_ has been renamed and
- reinvented as ffelex_image_char_, among other things.
-
- * malloc.c, malloc.h: Switch to valid ANSI C replacement for
- ARRAY_ZERO, and kill the full number of bytes in pools and
- areas.
-
- * proj.h.in (ARRAY_ZERO, ARRAY_ZERO_SIZE): Remove.
-
- * ste.c (ffeste_io_cilist_, ffeste_io_icilist_, ffeste_R838,
- ffeste_R839): Issue diagnostic if a too-narrow variable used in an
- ASSIGN context despite changes to this code and code in com.c.
-
- * where.c, where.h: Switch to valid ANSI C replacement for
- ARRAY_ZERO.
-
-Fri Feb 17 03:35:19 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.8 released.
-
- * INSTALL: In quick-build case, list g77 target first so g77
- gets installed. Also, explain that gcc gets built and installed
- as well, even though this isn't really what we want (and maybe
- we'll find a way around this someday).
-
-Fri Feb 17 02:35:41 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.7 released.
-
- * Makefile.in (CONFIG_H, HCONFIG_H, TCONFIG_H, TM_H): Remove
- ../ prefix in front of .h files, since they're in the cd.
-
-Fri Feb 17 01:50:48 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.6 released.
-
-Thu Feb 16 20:26:54 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * ../README.g77: Remove description of g77 as "not-yet-published".
-
- * CREDITS: More changes.
-
- * Make-lang.in (G77STAGESTUFF): Remove cktyps stuff.
-
- * Makefile.in (CONFIG_H, HCONFIG_H, TCONFIG_H, TM_H): Don't
- prefix gcc dir with $(srcdir) since these don't live there,
- they are created in the build dir by gcc's configure. Add
- a note explaining what these macros are about.
- Update dependencies via deps-kinda.
-
- * README.NEXTSTEP: Credit Toon, and per his request, add his
- email address.
-
- * com.h (FFECOM_DETERMINE_TYPES): #include "config.j".
-
- * config.j, convert.j, flags.j, hconfig.j, rtl.j, tconfig.j,
- tm.j, tree.j: Don't #include if already done.
-
- * convert.j: #include "tree.j" first, as convert.h clearly depends
- on trees being defined.
-
- * rtl.j: #include "config.j" first, since there's some stuff
- in rtl.h that assumes it has been #included.
-
- * tree.j: #include "config.j" first, or real.h makes inconsistent
- decision about return type of ereal_atof, leading to bugs, and
- because tree.h/real.h assume config.h already included.
-
-Wed Feb 15 14:40:20 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.5 released.
-
- * Copyright notices updated to be FSF-style.
-
- * INSTALL: Some more clarification regarding building just f77.
-
- * Make-lang.in (F77_SRCS): Update wrt changing some .h to .j.
- (install-libf77): Fix typo in new parenthetical note.
-
- * Makefile.in (f/*.o): Update.
- (CONFIG_H, CONVERT_H, FLAGS_H, GLIMITS_H, HCONFIG_H, RTL_H,
- TCONFIG_H, TM_H, TREE_H): Update/new symbols.
- (deps-kinda): More fixes wrt changing some .h to .j.
- Document and explain this rule a bit better.
- Accommodate changes in output of gcc -MM.
-
- * *.h, *.c: Change #include's so proj.h not assumed to #include
- malloc.h or config.h (now config.j), and so new .j files are
- used instead of old .h ones.
-
- * com.c (ffecom_init_0): Use FLOAT_TYPE_SIZE for f2c's
- TYLONG/TYLOGICAL type codes, to get g77 working on Alpha.
-
- * com.h: Make all f2c-related integral types "int", not "long
- int".
-
- * config.j, convert.j, flags.j, glimits.j, hconfig.j, rtl.j,
- tconfig.j, tm.j, tree.j: New files wrapping around gbe
- .h files.
-
- * config.h, convert.h, flags.h, glimits.h, hconfig.h, rtl.h,
- tconfig.h, tm.h, tree.h: Deleted so new .j files
- can #include the gbe files directly, instead of using "../",
- and thus do better with various kinds of builds.
-
- * proj.h: Delete unused NO_STDDEF and related stuff.
-
-Tue Feb 14 08:28:08 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * BUGS: Remove item #12, cross-compiling & autoconf scripts
- reportedly expected to work properly (according to d.love).
-
- * INSTALL: Add explanation of d.love's patch to config-lang.in.
- Add explanation of how to install just g77 when gcc already installed.
- Add note about usability of "-Wall". Add note about bug-
- reporting.
-
- * Make-lang.in ($(srcdir)/f/conf-proj): Add comment about why
- conf-proj.out.
- (install-libf77): Echo parenthetical note to user about how to do
- just the (aborted) libf2c installation.
- (deps-kinda): Update to work with new configuration/build stuff.
-
- * bad.c (ffebad_finish): Put capitalized "warning:" &c message
- as prefix on any diagnostic without pointers into source.
-
- * bad.def (FFEBAD_TOO_BIG_INIT): Add this warning message.
-
- * config-lang.in: Add Dave Love's patch to catch case where
- back-end patches not applied and abort configuration.
-
- * data.c (ffedata_gather_, ffedata_value_): Warn when about
- to initialize a large aggregate area, due to design flaw resulting
- in too much time/space used to handle such cases.
- Use COMMON area name, and first notice of symbol, for multiple-
- initialization diagnostic, instead of member symbol and unknown
- location.
- (FFEDATA_sizeTOO_BIG_INIT_): New macro per above.
-
-Mon Feb 13 13:54:26 1995 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (F77_SRCS): Use $(srcdir)/f/proj.h.in, not
- $(srcdir)/f/proj.h for build outside srcdir.
-
-Sun Feb 12 13:37:11 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * ../README.g77: Clarify procedures for unpacking, add asterisks
- to mark important things the user must do.
-
- * Fix dates in/add dates to ../README.g77, BUGS, CREDITS, DOC,
- INSTALL, PROJECTS, README.
-
-Sun Feb 12 00:26:10 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.4 released.
-
- * Make-lang.in (f/proj.h): Reproduce this rule here from
- Makefile.in.
- ($(srcdir)/f/conf-proj): Put autoconf's stdout in temp file
- conf-proj.out, then mv to conf-proj only if successful, so
- conf-proj not touched if autoconf not installed.
-
- * Makefile.in ($(srcdir)/conf-proj): See Make-lang.in's similar
- rule.
-
-Sat Feb 11 20:56:02 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * BUGS: Clarify some bugs.
-
- * DOC: Many improvements and fixes.
-
- * README: Move bulk of text, edited, to ../README.g77, and
- replace with pointer to that file.
-
- * com.c (ffecom_init_0): Comment out warning about sizeof(ftnlen)
- as per ste.c change. Add text about ASSIGN to help user understand
- what is being warned about.
-
- * conf-proj.in: Fix typos in comments.
-
- * proj.h.in: Add ARRAY_ZERO_SIZE to parallel malloc.h's version,
- in case it proves to be needed.
-
- * ste.c: Comment out assertions requiring sizeof(ftnlen) >=
- sizeof(char *), in the hopes that overflow will never happen.
- (ffeste_R838): Change assertion to fatal() with at least
- partially helpful message.
-
-Sat Feb 11 12:38:00 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * com.c (ffecom_vardesc_): Crash if typecode is -1.
-
- * ste.c (ffeste_io_dolio_): Crash if typecode is -1.
-
-Sat Feb 11 09:51:57 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * ste.c: In I/O code tests for item arrayness, sort of revert
- to much earlier code that tests original exp, but also check
- in newer way just in case. Newer way alone treated FOO(1:40)
- as an array, not sure why older way alone didn't work, but I
- think maybe it was when diagnosed code was involved, and
- since there are now checks for error_mark_node, maybe the old
- way alone would work. But better to be safe; both original
- ffebld exp _and_ the transformed tree must indicate an array
- for the size-determination code to be used, else just 1/2 elements
- assumed. And this text is for EMACS: (foo at bar).
-
-Fri Feb 10 11:05:50 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * ste.c: In many cases, surround statement-expansion code
- with ffecom_push_calltemps () and ffecom_pop_calltemps ()
- so COMPLEX-returning functions can have temporaries pushed
- in "auto-pop" mode and have them auto-popped at the end of
- the statement.
-
-Wed Feb 8 14:35:10 1995 Dave Love <d.love@dl.ac.uk>
-
- * runtime/f2c.h.in (ftnlen, ftnint): Make same size as integer.
-
- * runtime/libI77/err.c (f_init): Thinko in MISSING_FILE_ELEMS
- conditional.
- * runtime/libI77/wrtfmt.c (mv_cur): Likewise.
- * runtime/libI77/wsfe.c (x_putc): Likewise.
-
- * runtime/libF77/signal_.c (signal_): Return 0 (this is a
- subroutine).
-
- * Makefile.in (f/proj.h): Depend on com.h.
- * Make-lang.in (include/f2c.h): Likewise (and proj.h).
- (install-libf77): Also install f2c.h.
-
- * runtime/libI77/Makefile.in (*.o): Add f2c.h dependency.
- * runtime/libF77/Makefile.in: Likewise.
-
-Wed Feb 8 13:56:47 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * stc.c (ffestc_R501_item): Don't reset kind/where to NONE when
- setting basictype/kindtype info for symbol, or especially
- its function/result twin, because kind/where might not be NONE.
-
-Tue Feb 7 14:47:26 1995 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in (include/f2c.h:): Set shell variable src more
- robustly (independent of whether srcdir is relative or absolute).
- * Makefile.in (f/proj.h:): Likewise.
-
- * conf-proj.in: Check need for LAME_ASSERT. Fix indentation in
- check for LAME_STDIO (cosmetic only with ANSI C).
-
- * com.h: Extra ...SIZE stuff taken from com.c.
-
- * com.c (FFECOM_DETERMINE_TYPES): Define before including com.h.
- (BITS_PER_WORD etc.) Remove and use conditional definitions to com.h.
-
- * runtime/configure.in: #define FFECOM_DETERMINE_TYPES for com.h in
- f2c type determination.
-
- * tm.h: Remove (at least pro tem) because of relative path and use
- top-level one.
-
- * Make-lang.in (include/f2c.h:): Set shell variable src more
- robustly (independent of whether srcdir is relative or absolute).
- * Makefile.in (f/proj.h:): Likewise.
-
-Mon Feb 6 19:58:32 1995 Dave Love <d.love@dl.ac.uk>
-
- * g77.c (append_arg): Use K&R declaration for, e.g. SunOS4 build.
-
-Fri Feb 3 20:33:14 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * g77.c (main): Treat -l like filename in terms of -x handling.
- Rewrite arglist mechanism for ease of maintenance.
- Make sure every -lf2c is followed by -lm and vice versa.
-
- * Make-lang.in: Put complete list of sources in F77_SRCS def
- so changing a .h file, for example, causes rebuild.
-
- * Makefile.in: Change test for nextstep to m68k-next-nextstep* so
- all versions of nextstep on m68k get the necessary flag.
-
-Fri Feb 3 19:10:32 1995 Dave Love <d.love@dl.ac.uk>
-
- * INSTALL: Note about possible conflict with existing libf2c.a and
- f2c.h.
-
- * Make-lang.in (f77.distclean): Tidy and move deletion of
- f/config.cache to mostlyclean.
- (install-libf77): Test for $(libdir)/libf2c.* and barf if found
- unless F2CLIBOK defined.
-
- * runtime/Makefile.in (all): Change path to include directory (and
- elsewhere).
- (INCLUDES): Remove (unused/misleading).
- (distclean): Include f2c.h.
- (clean): Include config.cache.
-
- * runtime/libF77/Makefile.in (.SUFFIXES): Correct typo.
- (ALL_CFLAGS) Fix up include search path to find f2c.h in top level
- includes always.
- (all): Depend on f2c.h.
- * runtime/libI77/Makefile.in (.SUFFIXES): Likewise.
-
-Thu Feb 2 17:17:06 1995 Dave Love <d.love@dl.ac.uk>
-
- * INSTALL: Note about --srcdir and GNU make.
-
- * runtime/f2c.h.in (Pad_UDread, ALWAYS_FLUSH): Reomve the #defines
- per below.
-
- * runtime/configure.in (Pad_UDread, ALWAYS_FLUSH): Define these
- here, not in f2c.h as they'r eonly relevant for building.
- * runtime/configure: Regenerated.
-
- * config-lang.in: Warn about using GNU make outside source tree
- since I can't get Irix5 or SunOS4 makes to work in this case.
-
- * Makefile.in (VPATH): Don't set it here.
- (srcdir): Make it the normal `.' (overridden) at top level.
- (all.indirect): New dependency `dircheck'.
- (f771): Likewise
- (dircheck): New target for foolproofing.
- (f/proj.h:): Change finding source.
- (CONFIG_H): Don't use this as the relative path in the include loses
- f builddir != srcdir.
-
- * config.h: Remove per CONFIG_H change above.
-
- * Make-lang.in (F77_FLAGS_TO_PASS): Remove GCC_FOR_TARGET.
- (f771:): Pass VPATH, srcdir to sub-make.
- (f/Makefile:): New target.
- (stmp-int-hdrs): new variable for cheating build.
- (f77-runtime:): Alter GCC_FOR_TARGET treatment.
- (include/f2c.h f/runtime/Makefile:) Likewise.
- (f77-runtime-unsafe:): New (cheating) target.
-
-Thu Feb 2 12:09:51 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * BUGS: Update regarding losing EQUIVALENCE members in -g, and
- regarding RS/6000 problems in the back end.
-
- * CREDITS: Make some changes as requested.
-
- * com.c (ffecom_member_trunk_): Remove unused static variable.
- (ffecom_finish_symbol_transform_): Improve comments.
- (ffecom_let_char_): Fix size of temp address-type var.
- (ffecom_member_phase2_): Try fixing problem fixed by change
- to ffecom_transform_equiv_ (f_m_p2_ function currently not used).
- (ffecom_transform_equiv_): Remove def of unused static variable.
- Comment-out use of ffecom_member_phase2_, until problems with
- back end fixed.
- (ffecom_push_tempvar): Fix assertion to not crash okay code.
-
- * com.h: Remove old, commented-out code.
- Add prototype for warning() in back end.
-
- * ste.c (ffeste_io_dofio_, ffeste_io_dolio_, ffeste_io_douio_,
- ffeste_io_icilist_): Check correct type of variable for arrayness.
-
-Sun Jan 29 14:41:42 1995 Dave Love <d.love@dl.ac.uk>
-
- * BUGS: Remove references to my configure bugs; add another.
-
- * runtime/Makefile.in (AR_FLAGS): Provide default value.
-
- * runtime/f2c.h.in (integer, logical): Take typedefs from
- F2C_INTEGER configuration parameter again.
- (NON_UNIX_STDIO): don't define it.
-
- * runtime/configure.in: Bring type checks for f2c.h in line with
- com.h.
- (MISSING_FILE_ELEMS): New variable to determine whether the relevant
- elements of the FILE struct exist, independent of NON_UNIX_STDIO.
- * runtime/libI77/{err,wrtfmt,wsfe}.c (MISSING_FILE_ELEMS): Use new
- parameter.
-
- * config-lang.in: Comment out more of f2c rules (c.f. Make-lang.in).
- (This stuff is relevant iff you gave configure --enable-f2c.)
- Create f/runtime directory tree iff not building in source
- directory.
-
- * Makefile.in (srcdir): Append slash so we get the right value when
- not building in the source directory. This is a consequence of not
- building the `f' sources in `f'.
- (VPATH): Override configure's value for reasons above.
- (f/proj.h f/conf-proj): New rules to build proj.h by
- autoconfiguration.
-
- * proj.h: Rename to proj.h.in for autoconfiguration.
- * proj.h.in: New as above.
- * conf-proj conf-proj.in: New files for autoconfiguration.
-
- * Make-lang.in (include/f2c.h f/runtime/Makefile:): Change the order
- of setting the sh variables so that the right GCC_FOR_TARGET is
- used.
- (f77.*clean:) Add products of new configuration files and make sure
- all the *clean targets do something (unlike the ones in
- cp/Make-lange.in).
-
- * com.h (FFECOM_f2cINTEGER, FFECOM_f2cLOGICAL): Define as long or
- int appropriately to ensure sizeof(real) == sizeof(integer).
-
- * PROJECTS: Library section.
-
- * runtime/libI77/endfile.c: Don't #include sys/types.h conditional
- on NON_UNIX_STDIO since rawio.h needs size_t.
- * runtime/libI77/uio.c: #include <sys/types.h> for size_t if not
- KR_headers.
-
-Wed Jan 25 03:31:51 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.3 released.
-
- * INSTALL: Revise.
-
- * Make-lang.in: Comment out rules for building f2c itself (f/f2c/).
-
- * README: Revise.
-
- * com.c (ffecom_init_0): Warn if ftnlen or INTEGER not big enough
- to hold a char *.
-
- * gbe/2.6.2.diff: Update.
-
-Mon Jan 23 17:10:49 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * TODO: Remove.
- BUGS: New file.
- PROJECTS: New file.
- CREDITS: New file.
-
- * cktyps*: Remove.
- Make-lang.in: Remove cktyps stuff.
- Makefile.in: Remove cktyps stuff.
-
- * DOC: Add info on changes for 0.5.3.
-
- * bad.c: Put "warning:" &c on diagnostic messages.
- Don't output informational messages if warnings disabled.
-
-Thu Jan 19 12:38:13 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * g77.c: Avoid putting out useless "-xnone -xf77" pairs so
- larger command lines can be accommodated.
- Recognize both `-xlang' and `-x lang'.
- Recognize `-xnone' and `-x none' to mean what it does, instead
- of treating "none" as any other language.
- Some minor, slight improvements in the way args are handled
- (hopefully for clearer, more maintainable code), including
- consistency checks on arg count just in case.
-
-Wed Jan 18 16:41:57 1995 Craig Burley (burley@gnu.ai.mit.edu)
-
- * DOC: Explain -fautomatic better.
-
- * INSTALL: Describe libf2c.a better.
-
- * Make-lang.in, Makefile.in: Build f771 &c with gcc/ as cd instead
- of gcc/f/ so debugging info is better (source file tracking).
- Add new source file type.c.
-
- * Makefile.in: For nextstep3, link f771 with -segaddr __DATA
- 6000000. Fix typo. Change deps-kinda target to handle building
- from gcc/. Update dependencies.
-
- * bld-op.def, bld.h, bld.c: Remove opBACKEND and all related
- stuff.
- Remove consistency tests that cause compiler warnings.
-
- * cktyps.c: Remove all typing checking.
-
- * com-rt.def: Change all rttypeFLOAT_ intrinsics to rttypeDOUBLE_,
- to precisely match how they're declared in libf2c.
-
- * com.h, com.c: Revise to more elegantly track related stuff
- in the version of f2c.h used to build libf2c.
-
- * com.c: Increase FFECOM_sizeMAXSTACKITEM, and if 0 or undefined
- when checked to determine where to put entity, treat as infinite.
- Rewrite temporary mechanism to be based on trees instead of
- ffeinfo stuff, and make it much simpler. Change interface
- accordingly.
- Fixes to better track types of things, make appropriate
- conversions, etc. E.g. when making an arg for a libf2c
- function, make sure it's of the right type (such as ftnlen).
- Delete opBACKEND transformation code.
- (ffecom_init_0): Smoother initialization of types, especially
- paying attention to using consistent rules for making INTEGER,
- REAL, DOUBLE PRECISION, etc., and for deciding their "*N"
- and kind values that will work across all g77 platforms.
- No longer require per-target configuration info in target.h
- or config/*/*; use new type module to store size, alignment.
- (ffecom_member_phase2): Declare COMMON/EQUIVALENCE group members
- so debugger sees them.
- (ffecom_finish_progunit): Transform all symbols in program unit,
- so -g will show they all exist.
-
- * expr.c (ffeexpr_collapse_substr): Handle strange substring
- range values.
-
- * info.h, info.c: Provide connection to new type module.
- Remove tests that yield compiler warnings.
-
- * intrin.c (ffeintrin_is_intrinsic): Properly handle deleted
- intrinsic.
-
- * lex.c (ffelex_file_fixed): Remove redundant/buggy code.
-
- * stc.c (ffestc_kindtype_kind_, ffestc_kindtype_star_): Replace
- boring switch stmt with simple call to new type module. This
- sort of thing is a reason to get up in the morning.
-
- * ste.c: Update to handle new interface for
- ffecom_push/pop_tempvar.
- Fixes to better track types of things.
- Fixes to not crash for certain diagnosed constructs.
- (ffeste_begin_iterdo_): Check only constants for overflow to avoid
- spurious diagnostics.
- Don't convert larger integer (say, INTEGER*8) to canonical integer
- for iteration count.
-
- * stw.h: Track DO iteration count temporary variable.
-
- * symbol.c: Remove consistency tests that cause compiler warnings.
-
- * target.c (ffetarget_aggregate_info): Replace big switch with
- little call to new type module.
- (ffetarget_layout): Remove consistency tests that cause
- compiler warnings.
- (ffetarget_convert_character1_typeless): Pick up length of
- typeless type from new type module.
-
- * target.h: Crash build if target float bit pattern cannot be
- precisely determined.
- Remove all the type cruft now determined by ffecom_init_0
- at invocation time and maintained in new type module.
- Put casts on second arg of all REAL_VALUE_TO_TARGET_DOUBLE
- uses so compiler warnings avoided (requires target float bit
- pattern to be precisely determined, hence code to crash build).
-
- * top.c: Add inits/terminates for new type module.
-
- * type.h, type.c: New module.
-
- * gbe/2.6.2.diff: Remove all patches to files in gcc/config/
- directory and its subdirectories.
-
-Mon Jan 9 19:23:25 1995 Dave Love <d.love@dl.ac.uk>
-
- * com.h (FFECOM_F2C_INTEGER_TYPE_NODE): Define and use instead of
- long_integer_type_node where appropriate.
-
-Tue Jan 3 14:56:18 1995 Dave Love <d.love@dl.ac.uk>
-
- * com.h: Make ffecom_f2c_logical_type_node long, consistent with
- integer.
-
-Fri Dec 2 20:07:37 1994 Dave Love <d.love@dl.ac.uk>
-
- * config-lang.in (stagestuff): Add f2c conditionally.
- * Make-lang.in: Add f2c and related targets.
- * f2c: Add the directory.
-
-Fri Nov 25 22:17:26 1994 Dave Love <d.love@dl.ac.uk>
-
- * Makefile.in (FLAGS_TO_PASS): pass $(CROSS)
- * Make-lang.in: more changes to runtime targets
-
-Thu Nov 24 18:03:21 1994 Dave Love <d.love@dl.ac.uk>
-
- * Makefile.in (FLAGS_TO_PASS): define for sub-makes
-
- * g77.c (main): change f77-cpp-output to f77-cpp-input (.F files)
-
-Wed Nov 23 15:22:53 1994 Dave Love <d.love@dl.ac.uk>
-
- * bad.c (ffebad_finish): kluge to fool emacs19 into finding errors:
- add trailing space to <file>:<line>:
-
-Tue Nov 22 11:30:50 1994 Dave Love <d.love@dl.ac.uk>
-
- * runtime/libF77/signal_.c (RETSIGTYPE): added
-
-Mon Nov 21 13:04:13 1994 Dave Love <d.love@dl.ac.uk>
-
- * Makefile.in (compiler): add runtime
-
- * config-lang.in (stagestuff): add libf2c.a to stagestuff
-
- * Make-lang.in:
- G77STAGESTUFF <- MORESTAGESTUFF
- f77-runtime: new target, plus supporting ones
-
- * runtime: add the directory, containing libI77, libF77 and autoconf
- stuff
-
- * g++.1: remove
-
- * g77.1: minor fixes
-
-Thu Nov 17 15:18:05 1994 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.2 released.
-
- * bad.def: Modify wording of FFEBAD_UNIMPL_STMT to indicate
- that it covers a wide array of possible problems (that, someday,
- should be handled via separate diagnostics).
-
- * lex.c: Allow $ in identifiers if -fdollar-ok.
- * top.c: Support -fdollar-ok.
- * top.h: Support -fdollar-ok.
- * target.h: Support -fdollar-ok.
- * DOC: Describe -fdollar-ok.
-
- * std.c (ffestd_R1229_finish): Fix bug so stand-alone build works.
- * ste.c (ffeste_R819A): Fix bug so stand-alone build works.
-
- * Make: Improvements for stand-alone build.
-
- * Makefile.in: Fix copyright text at top of file.
-
- * LINK, SRCS, UNLINK: Removed. Not particularly useful now that
- g77 sources live in their own subdirectory.
-
- * g77.c (main): Cast arg to bzero to avoid warning. (This is
- identical to Kenner's fix to cp/g++.c.)
-
- * gbe/: New subdirectory, to contain .diff files for various
- versions of the GNU CC back end.
-
- * gbe/README: New file.
- * gbe/2.6.2.diff: New file.
-
-Tue Nov 8 10:23:10 1994 Dave Love <d.love@dl.ac.uk>
-
- * Make-lang.in: don't install as f77 as well as g77 to avoid
- confusion with system's compiler (especially while testing)
-
- * g77.c (main): use -lf2c and -lm; fix sense of test for .f/.F files
-
-Fri Oct 28 09:45:00 1994 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.1 released.
-
- * gcc.c: Invoke f771 instead of f-771.
-
-Fri Oct 28 02:00:44 1994 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Version 0.5.0 released.
-
-Fri Oct 14 15:03:35 1994 Craig Burley (burley@gnu.ai.mit.edu)
-
- * Makefile.in: Handle the Fortran-77 front-end in a subdirectory.
- * f-*: Move Fortran-77 front-end to f/*.
-
-Local Variables:
-add-log-time-format: current-time-string
-End:
+++ /dev/null
-# Top level -*- makefile -*- fragment for GNU Fortran.
-# Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
-
-#This file is part of GNU Fortran.
-
-#GNU Fortran is free software; you can redistribute it and/or modify
-#it under the terms of the GNU General Public License as published by
-#the Free Software Foundation; either version 2, or (at your option)
-#any later version.
-
-#GNU Fortran is distributed in the hope that it will be useful,
-#but WITHOUT ANY WARRANTY; without even the implied warranty of
-#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-#GNU General Public License for more details.
-
-#You should have received a copy of the GNU General Public License
-#along with GNU Fortran; see the file COPYING. If not, write to
-#the Free Software Foundation, 59 Temple Place - Suite 330,
-#Boston, MA 02111-1307, USA.
-
-# This file provides the language dependent support in the main Makefile.
-# Each language makefile fragment must provide the following targets:
-#
-# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap,
-# foo.install-normal, foo.install-common, foo.install-man,
-# foo.uninstall,
-# foo.mostlyclean, foo.clean, foo.distclean,
-# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
-#
-# where `foo' is the name of the language.
-#
-# It should also provide rules for:
-#
-# - making any compiler driver (eg: g++)
-# - the compiler proper (eg: cc1plus)
-# - define the names for selecting the language in LANGUAGES.
-#
-# $(srcdir) must be set to the gcc/ source directory (not gcc/f/).
-#\f
-# Actual name to use when installing a native compiler.
-G77_INSTALL_NAME := $(shell echo g77|sed '$(program_transform_name)')
-
-# Some versions of `touch' (such as the version on Solaris 2.8)
-# do not correctly set the timestamp due to buggy versions of `utime'
-# in the kernel. So, we use `echo' instead.
-STAMP = echo timestamp >
-
-#\f
-# Define the names for selecting f77 in LANGUAGES.
-# Note that it would be nice to move the dependency on g77
-# into the F77 rule, but that needs a little bit of work
-# to do the right thing within all.cross.
-F77 f77: f771$(exeext)
-
-# Tell GNU make to ignore these if they exist.
-.PHONY: F77 f77 f77.all.build f77.all.cross \
- f77.start.encap f77.rest.encap f77.dvi \
- f77.install-normal \
- f77.install-common f77.install-man \
- f77.uninstall f77.mostlyclean f77.clean f77.distclean \
- f77.maintainer-clean \
- f77.stage1 f77.stage2 f77.stage3 f77.stage4 \
- f77.stageprofile f77.stagefeedback
-
-g77spec.o: $(srcdir)/f/g77spec.c $(SYSTEM_H) coretypes.h $(TM_H) $(GCC_H) \
- $(CONFIG_H) intl.h
- (SHLIB_LINK='$(SHLIB_LINK)' \
- SHLIB_MULTILIB='$(SHLIB_MULTILIB)'; \
- $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \
- $(INCLUDES) $(srcdir)/f/g77spec.c)
-
-# Create the compiler driver for g77.
-g77$(exeext): gcc.o g77spec.o version.o prefix.o intl.o \
- $(LIBDEPS) $(EXTRA_GCC_OBJS)
- $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ gcc.o g77spec.o \
- version.o prefix.o intl.o $(EXTRA_GCC_OBJS) $(LIBS)
-
-# Create a version of the g77 driver which calls the cross-compiler.
-g77-cross$(exeext): g77$(exeext)
- rm -f g77-cross$(exeext); \
- cp g77$(exeext) g77-cross$(exeext)
-
-# The compiler itself.
-
-F77_OBJS = f/bad.o f/bit.o f/bld.o f/com.o f/data.o f/equiv.o f/expr.o \
- f/global.o f/implic.o f/info.o f/intrin.o f/lab.o f/lex.o f/malloc.o \
- f/name.o f/parse.o f/src.o f/st.o f/sta.o f/stb.o f/stc.o \
- f/std.o f/ste.o f/storag.o f/stp.o f/str.o f/sts.o f/stt.o f/stu.o \
- f/stv.o f/stw.o f/symbol.o f/target.o f/top.o f/type.o f/where.o
-
-# Use loose warnings for this front end.
-f-warn = $(WERROR)
-
-f771$(exeext): $(F77_OBJS) $(BACKEND) $(LIBDEPS)
- rm -f f771$(exeext)
- $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(F77_OBJS) $(BACKEND) $(LIBS)
-
-# Keyword tables.
-f/stamp-str: f/str-1t.h f/str-1t.j f/str-2t.h f/str-2t.j \
- f/str-fo.h f/str-fo.j f/str-io.h f/str-io.j f/str-nq.h f/str-nq.j \
- f/str-op.h f/str-op.j f/str-ot.h f/str-ot.j
- $(STAMP) f/stamp-str
-
-f/str-1t.h f/str-1t.j: f/fini$(build_exeext) f/str-1t.fin
- ./f/fini$(build_exeext) $(srcdir)/f/str-1t.fin f/str-1t.j f/str-1t.h
-
-f/str-2t.h f/str-2t.j: f/fini$(build_exeext) f/str-2t.fin
- ./f/fini$(build_exeext) $(srcdir)/f/str-2t.fin f/str-2t.j f/str-2t.h
-
-f/str-fo.h f/str-fo.j: f/fini$(build_exeext) f/str-fo.fin
- ./f/fini$(build_exeext) $(srcdir)/f/str-fo.fin f/str-fo.j f/str-fo.h
-
-f/str-io.h f/str-io.j: f/fini$(build_exeext) f/str-io.fin
- ./f/fini$(build_exeext) $(srcdir)/f/str-io.fin f/str-io.j f/str-io.h
-
-f/str-nq.h f/str-nq.j: f/fini$(build_exeext) f/str-nq.fin
- ./f/fini$(build_exeext) $(srcdir)/f/str-nq.fin f/str-nq.j f/str-nq.h
-
-f/str-op.h f/str-op.j: f/fini$(build_exeext) f/str-op.fin
- ./f/fini$(build_exeext) $(srcdir)/f/str-op.fin f/str-op.j f/str-op.h
-
-f/str-ot.h f/str-ot.j: f/fini$(build_exeext) f/str-ot.fin
- ./f/fini$(build_exeext) $(srcdir)/f/str-ot.fin f/str-ot.j f/str-ot.h
-
-f/fini$(build_exeext): f/fini.o $(BUILD_LIBDEPS)
- $(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_LDFLAGS) -o f/fini$(build_exeext) \
- f/fini.o $(BUILD_LIBS)
-
-f/fini.o:
- $(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_CPPFLAGS) $(INCLUDES) \
- -c $(srcdir)/f/fini.c $(OUTPUT_OPTION)
-
-gt-f-lex.h gt-f-where.h gt-f-com.h gt-f-ste.h gtype-f.h : s-gtype; @true
-
-#\f
-# Build hooks:
-
-f77.all.build: g77$(exeext)
-f77.all.cross: g77-cross$(exeext)
-f77.start.encap: g77$(exeext)
-f77.rest.encap:
-
-f77.srcinfo: doc/g77.info
- -cp -p $^ $(srcdir)/doc
-f77.srcman: doc/g77.1
- -cp -p $^ $(srcdir)/doc
-f77.srcextra: f/BUGS f/NEWS
- -cp -p $^ $(srcdir)/f
-
-f77.tags: force
- cd $(srcdir)/f; etags -o TAGS.sub *.c *.h; \
- etags --include TAGS.sub --include ../TAGS.sub
-
-f77.info: doc/g77.info
-dvi:: doc/g77.dvi
-f77.man: doc/g77.1
-
-check-f77 : check-g77
-lang_checks += check-g77
-
-# g77 documentation.
-TEXI_G77_FILES = f/g77.texi f/bugs.texi f/ffe.texi f/invoke.texi \
- f/news.texi f/root.texi $(docdir)/include/fdl.texi \
- $(docdir)/include/gpl.texi $(docdir)/include/funding.texi \
- $(docdir)/include/gcc-common.texi $(srcdir)/f/intdoc.texi
-
-doc/g77.info: $(TEXI_G77_FILES)
- if test "x$(BUILD_INFO)" = xinfo; then \
- rm -f $(@)*; \
- $(MAKEINFO) $(MAKEINFOFLAGS) -I$(docdir)/include -I$(srcdir)/f \
- -o$@ $<; \
- else true; fi
-
-doc/g77.dvi: $(TEXI_G77_FILES)
- $(TEXI2DVI) -I $(srcdir)/f -I $(abs_docdir)/include -I $(objdir)/f -o $@ $<
-
-.INTERMEDIATE: g77.pod
-g77.pod: f/invoke.texi
- -$(TEXI2POD) < $< > $@
-
-# This dance is all about producing accurate documentation for g77's
-# intrinsics with minimum fuss. f/ansify appends "\n\" to C strings
-# so ANSI C compilers can compile f/intdoc.h -- gcc can compile f/intdoc.in
-# directly, if f/intdoc.c #include'd that, but we don't want to force
-# people to install gcc just to build the documentation. We use the
-# C format for f/intdoc.in in the first place to allow a fairly "free",
-# but widely known format for documentation -- basically anyone who knows
-# how to write texinfo source and enclose it in C constants can handle
-# it, and f/ansify allows them to not even end lines with "\n\". So,
-# essentially, the C preprocessor and compiler are used to enter the
-# document snippets into a data base via name lookup, rather than duplicating
-# that kind of code here. And we use f/intdoc.c instead of straight
-# texinfo in the first place so that as much information as possible
-# contained in f/intrin.def can be inserted directly and reliably into
-# the documentation. That's better than replicating it, because it
-# reduces the likelihood of discrepancies between the docs and the compiler
-# itself, which uses f/intrin.def; in fact, many bugs in f/intrin.def have
-# been found only upon reading the documentation that was automatically
-# produced from it.
-
-# If the documentation files depended on executables in the build
-# tree, there'd be no way to ship a source tree with the documentation
-# already generated such that `make' wouldn't attempt to rebuild it.
-# So, we punt and arrange for the documentation files to depend on the
-# dependencies of the executables, not on the executables themselves.
-# But then, we have to build the executables explicitly in their build
-# rules.
-
-INTDOC_DEPS = f/intdoc.c f/intrin.h f/intrin.def
-
-$(srcdir)/f/intdoc.texi: $(INTDOC_DEPS) f/intdoc.in
- $(MAKE) f/intdoc$(build_exeext)
- f/intdoc$(build_exeext) > $(srcdir)/f/intdoc.texi
-
-f/intdoc$(build_exeext): $(INTDOC_DEPS) f/intdoc.h0 bconfig.h \
- $(SYSTEM_H) coretypes.h $(TM_H) $(BUILD_LIBDEPS)
- $(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_LDFLAGS) $(INCLUDES) $< \
- $(BUILD_LIBS) -o $@
-
-f/intdoc.h0: f/intdoc.in f/ansify$(build_exeext)
- f/ansify$(build_exeext) $< < $< > $@
-
-f/ansify$(build_exeext): f/ansify.c bconfig.h $(SYSTEM_H) coretypes.h $(TM_H)
- $(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_LDFLAGS) $(INCLUDES) $< \
- -o $@
-
-f/BUGS: f/bugs0.texi f/bugs.texi f/root.texi
- if [ x$(BUILD_INFO) = xinfo ]; then \
- rm -f $(@)*; \
- $(MAKEINFO) $(MAKEINFOFLAGS) -D BUGSONLY --no-header --no-split \
- --no-validate -I$(docdir)/include -I$(srcdir)/f -o $@ bugs0.texi; \
- else true; fi
-
-f/NEWS: f/news0.texi f/news.texi f/root.texi
- if [ x$(BUILD_INFO) = xinfo ]; then \
- rm -f $(@)*; \
- $(MAKEINFO) $(MAKEINFOFLAGS) -D NEWSONLY --no-header --no-split \
- --no-validate -I$(docdir)/include -I$(srcdir)/f -o $@ news0.texi; \
- else true; fi
-
-#\f
-# Install hooks:
-# f771 is installed elsewhere as part of $(COMPILERS).
-
-f77.install-normal:
-
-# Install the driver program as $(target)-g77
-# and also as either g77 (if native) or $(tooldir)/bin/g77.
-f77.install-common: installdirs
- -if [ -f f771$(exeext) ] ; then \
- rm -f $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
- $(INSTALL_PROGRAM) g77$(exeext) $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
- chmod a+x $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
- else true; fi
- @if [ -f f77-install-ok -o -f $(srcdir)/f77-install-ok ]; then \
- echo ''; \
- echo 'Warning: gcc no longer installs an f77 command.'; \
- echo ' You must do so yourself. For more information,'; \
- echo ' read "Distributing Binaries" in the g77 docs.'; \
- echo ' (To turn off this warning, delete the file'; \
- echo ' f77-install-ok in the source or build directory.)'; \
- echo ''; \
- else true; fi
-
-install-info:: $(DESTDIR)$(infodir)/g77.info
-
-f77.install-man: installdirs $(DESTDIR)$(man1dir)/$(G77_INSTALL_NAME)$(man1ext)
-
-$(DESTDIR)$(man1dir)/$(G77_INSTALL_NAME)$(man1ext): doc/g77.1
- -rm -f $@
- -$(INSTALL_DATA) $< $@
- -chmod a-x $@
-
-f77.uninstall: installdirs
- if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \
- echo " install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/g77.info"; \
- install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/g77.info || : ; \
- else : ; fi
- rm -rf $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
- rm -rf $(DESTDIR)$(man1dir)/$(G77_INSTALL_NAME)$(man1ext); \
- rm -rf $(DESTDIR)$(infodir)/g77.info*
-#\f
-# Clean hooks:
-# A lot of the ancillary files are deleted by the main makefile.
-# We just have to delete files specific to us.
-
-f77.mostlyclean:
- -rm -f f/*$(objext)
- -rm -f f/*$(coverageexts)
- -rm -f f/fini$(build_exeext) f/stamp-str f/str-*.h f/str-*.j
- -rm -f f/BUGS f/NEWS
- -rm -f g77.aux g77.cps g77.ky g77.toc g77.vr g77.fn g77.kys \
- g77.pg g77.tp g77.vrs g77.cp g77.fns g77.log g77.pgs g77.tps
-f77.clean:
- -rm -f g77spec.o
-f77.distclean:
- -rm -f f/Makefile
-f77.maintainer-clean:
- -rm -f $(srcdir)/f/BUGS $(srcdir)/f/TAGS $(srcdir)/f/TAGS.SUB
- -rm -f $(srcdir)/f/NEWS $(srcdir)/f/intdoc.texi
-#\f
-# Stage hooks:
-# The main makefile has already created stage?/f.
-
-G77STAGESTUFF = f/*$(objext) f/fini$(build_exeext) f/stamp-str \
- f/str-*.h f/str-*.j g77spec.o
-
-f77.stage1: stage1-start
- -mv -f $(G77STAGESTUFF) stage1/f
-
-f77.stage2: stage2-start
- -mv -f $(G77STAGESTUFF) stage2/f
-
-f77.stage3: stage3-start
- -mv -f $(G77STAGESTUFF) stage3/f
-
-f77.stage4: stage4-start
- -mv -f $(G77STAGESTUFF) stage4/f
-
-f77.stageprofile: stageprofile-start
- -mv -f $(G77STAGESTUFF) stageprofile/f
-
-f77.stagefeedback: stageprofile-start
- -mv -f $(G77STAGESTUFF) stagefeedback/f
-#\f
-# .o: .h dependencies.
-
-f/bad.o: f/bad.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bad.h f/bad.def f/where.h \
- glimits.h f/top.h f/malloc.h flags.h f/com.h f/com-rt.def $(TREE_H) f/bld.h \
- f/bld-op.def f/bit.h f/info.h f/info-b.def f/info-k.def f/info-w.def \
- f/target.h f/lex.h f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h \
- f/symbol.def f/equiv.h f/storag.h f/global.h f/name.h toplev.h intl.h \
- diagnostic.h coretypes.h $(TM_H)
-f/bit.o: f/bit.c f/proj.h $(CONFIG_H) $(SYSTEM_H) glimits.h f/bit.h \
- f/malloc.h coretypes.h $(TM_H)
-f/bld.o: f/bld.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bld.h f/bld-op.def f/bit.h \
- f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
- f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h f/top.h f/lex.h \
- f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \
- f/name.h f/intrin.h f/intrin.def real.h coretypes.h $(TM_H)
-f/com.o: f/com.c f/proj.h $(CONFIG_H) $(SYSTEM_H) flags.h $(RTL_H) $(TREE_H) \
- output.h convert.h f/com.h f/com-rt.def f/bld.h f/bld-op.def f/bit.h \
- f/malloc.h f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
- f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/intrin.h \
- f/intrin.def f/lab.h f/symbol.h f/symbol.def f/equiv.h f/storag.h f/global.h \
- f/name.h f/expr.h f/implic.h f/src.h f/st.h $(GGC_H) toplev.h diagnostic.h \
- $(LANGHOOKS_DEF) langhooks.h intl.h real.h debug.h gt-f-com.h gtype-f.h \
- coretypes.h $(TM_H)
-f/data.o: f/data.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/data.h f/bld.h f/bld-op.def \
- f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
- f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
- f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h \
- f/global.h f/name.h f/intrin.h f/intrin.def f/expr.h f/st.h coretypes.h $(TM_H)
-f/equiv.o: f/equiv.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/equiv.h f/bld.h \
- f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
- f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h \
- glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \
- f/global.h f/name.h f/intrin.h f/intrin.def f/data.h coretypes.h $(TM_H)
-f/expr.o: f/expr.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/expr.h f/bld.h f/bld-op.def \
- f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
- f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
- f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h \
- f/global.h f/name.h f/intrin.h f/intrin.def f/implic.h f/src.h f/st.h \
- f/stamp-str real.h coretypes.h $(TM_H)
-f/fini.o: f/fini.c f/proj.h bconfig.h $(SYSTEM_H) f/malloc.h coretypes.h $(TM_H)
-f/global.o: f/global.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/global.h f/info.h \
- f/info-b.def f/info-k.def f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/type.h f/name.h f/symbol.h \
- f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def f/lab.h \
- f/storag.h f/intrin.h f/intrin.def f/equiv.h coretypes.h $(TM_H)
-f/implic.o: f/implic.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/implic.h f/info.h \
- f/info-b.def f/info-k.def f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/type.h f/symbol.h \
- f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def f/lab.h \
- f/storag.h f/intrin.h f/intrin.def f/equiv.h f/global.h f/name.h f/src.h \
- coretypes.h $(TM_H)
-f/info.o: f/info.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/info.h f/info-b.def \
- f/info-k.def f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def f/where.h \
- glimits.h f/top.h f/malloc.h f/lex.h f/type.h coretypes.h $(TM_H)
-f/intrin.o: f/intrin.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/intrin.h \
- f/intrin.def f/bld.h f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def \
- $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
- f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h \
- f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/expr.h f/src.h \
- coretypes.h $(TM_H)
-f/lab.o: f/lab.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/lab.h f/com.h f/com-rt.def \
- $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/malloc.h f/info.h f/info-b.def \
- f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
- f/top.h f/lex.h f/type.h f/intrin.h f/intrin.def f/symbol.h f/symbol.def \
- f/equiv.h f/storag.h f/global.h f/name.h coretypes.h $(TM_H)
-f/lex.o: f/lex.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/top.h f/malloc.h f/where.h \
- glimits.h f/bad.h f/bad.def f/com.h f/com-rt.def $(TREE_H) f/bld.h \
- f/bld-op.def f/bit.h f/info.h f/info-b.def f/info-k.def f/info-w.def \
- f/target.h f/lex.h f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h \
- f/symbol.def f/equiv.h f/storag.h f/global.h f/name.h f/src.h flags.h \
- debug.h input.h toplev.h output.h $(GGC_H) gt-f-lex.h coretypes.h $(TM_H)
-f/malloc.o: f/malloc.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/malloc.h \
- coretypes.h $(TM_H)
-f/name.o: f/name.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bad.h f/bad.def f/where.h \
- glimits.h f/top.h f/malloc.h f/name.h f/global.h f/info.h f/info-b.def \
- f/info-k.def f/info-w.def f/target.h $(TREE_H) f/lex.h f/type.h f/symbol.h \
- f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def f/lab.h \
- f/storag.h f/intrin.h f/intrin.def f/equiv.h f/src.h coretypes.h $(TM_H)
-f/parse.o: f/parse.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/top.h f/malloc.h \
- f/where.h glimits.h f/com.h f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def \
- f/bit.h f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
- f/bad.def f/lex.h f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h \
- f/symbol.def f/equiv.h f/storag.h f/global.h f/name.h version.h flags.h \
- coretypes.h $(TM_H)
-f/src.o: f/src.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/src.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h coretypes.h $(TM_H)
-f/st.o: f/st.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/st.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/symbol.h f/symbol.def \
- f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
- f/info-b.def f/info-k.def f/info-w.def f/target.h f/type.h f/lab.h \
- f/storag.h f/intrin.h f/intrin.def f/equiv.h f/global.h f/name.h f/sta.h \
- f/stamp-str f/stb.h f/expr.h f/stp.h f/stt.h f/stc.h f/std.h \
- f/stv.h f/stw.h f/ste.h f/sts.h f/stu.h coretypes.h $(TM_H)
-f/sta.o: f/sta.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/sta.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/stamp-str f/symbol.h \
- f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) \
- f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/type.h f/lab.h \
- f/storag.h f/intrin.h f/intrin.def f/equiv.h f/global.h f/name.h f/implic.h \
- f/stb.h f/expr.h f/stp.h f/stt.h f/stc.h f/std.h f/stv.h f/stw.h coretypes.h \
- $(TM_H)
-f/stb.o: f/stb.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stb.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h f/expr.h f/bld.h f/bld-op.def f/bit.h \
- f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
- f/info-w.def f/target.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
- f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h \
- f/stt.h f/stamp-str f/src.h f/sta.h f/stc.h coretypes.h $(TM_H)
-f/stc.o: f/stc.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stc.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h f/bld.h f/bld-op.def f/bit.h f/com.h \
- f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \
- f/target.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \
- f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/expr.h f/stp.h \
- f/stt.h f/stamp-str f/data.h f/implic.h f/src.h f/sta.h f/std.h f/stv.h \
- f/stw.h coretypes.h $(TM_H)
-f/std.o: f/std.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/std.h f/bld.h f/bld-op.def \
- f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
- f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
- f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h \
- f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h f/stt.h f/stamp-str \
- f/stv.h f/stw.h f/sta.h f/ste.h f/sts.h coretypes.h $(TM_H)
-f/ste.o: f/ste.c f/proj.h $(CONFIG_H) $(SYSTEM_H) $(RTL_H) toplev.h f/ste.h \
- f/bld.h f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) \
- f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
- f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h \
- f/stt.h f/stamp-str f/sts.h f/stv.h f/stw.h f/expr.h f/sta.h $(GGC_H) \
- gt-f-ste.h coretypes.h $(TM_H)
-f/storag.o: f/storag.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/storag.h f/bld.h \
- f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) \
- f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
- f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h \
- f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
- f/intrin.def f/data.h coretypes.h $(TM_H)
-f/stp.o: f/stp.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stp.h f/bld.h f/bld-op.def \
- f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
- f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h \
- f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
- f/intrin.def f/stt.h coretypes.h $(TM_H)
-f/str.o: f/str.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/src.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/malloc.h f/stamp-str f/lex.h coretypes.h $(TM_H)
-f/sts.o: f/sts.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/sts.h f/malloc.h f/com.h \
- f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/info.h \
- f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/lex.h f/type.h f/intrin.h f/intrin.def \
- f/lab.h f/symbol.h f/symbol.def f/equiv.h f/storag.h f/global.h \
- f/name.h coretypes.h $(TM_H)
-f/stt.o: f/stt.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stt.h f/top.h f/malloc.h \
- f/where.h glimits.h f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def \
- $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h \
- f/bad.h f/bad.def f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
- f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def \
- f/stp.h f/expr.h f/sta.h f/stamp-str coretypes.h $(TM_H)
-f/stu.o: f/stu.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bld.h f/bld-op.def f/bit.h \
- f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
- f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h \
- glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
- f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def \
- f/implic.h f/stu.h f/sta.h f/stamp-str coretypes.h $(TM_H)
-f/stv.o: f/stv.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stv.h f/lab.h f/com.h \
- f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/malloc.h \
- f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
- f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/intrin.h \
- f/intrin.def f/symbol.h f/symbol.def f/equiv.h f/storag.h f/global.h \
- f/name.h coretypes.h $(TM_H)
-f/stw.o: f/stw.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stw.h f/bld.h f/bld-op.def \
- f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
- f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
- f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h \
- f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
- f/intrin.def f/stv.h f/sta.h f/stamp-str coretypes.h $(TM_H)
-f/symbol.o: f/symbol.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/symbol.h \
- f/symbol.def f/bld.h f/bld-op.def f/bit.h f/malloc.h f/com.h \
- f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
- f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h f/top.h \
- f/lex.h f/type.h f/lab.h f/storag.h f/intrin.h f/intrin.def f/equiv.h \
- f/global.h f/name.h f/src.h f/st.h coretypes.h $(TM_H)
-f/target.o: f/target.c f/proj.h $(CONFIG_H) $(SYSTEM_H) glimits.h f/target.h \
- $(TREE_H) f/bad.h f/bad.def f/where.h f/top.h f/malloc.h f/info.h real.h \
- f/info-b.def f/info-k.def f/info-w.def f/type.h f/lex.h diagnostic.h \
- coretypes.h $(TM_H) toplev.h
-f/top.o: f/top.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/top.h f/malloc.h f/where.h \
- glimits.h f/bad.h f/bad.def f/bit.h f/bld.h f/bld-op.def f/com.h \
- f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
- f/info-w.def f/target.h f/lex.h f/type.h f/lab.h f/storag.h \
- f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
- f/intrin.def f/data.h f/expr.h f/implic.h f/src.h f/st.h flags.h \
- toplev.h coretypes.h $(TM_H) opts.h options.h
-f/type.o: f/type.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/type.h f/malloc.h \
- coretypes.h $(TM_H)
-f/where.o: f/where.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/where.h glimits.h \
- f/top.h f/malloc.h f/lex.h $(GGC_H) gt-f-where.h coretypes.h $(TM_H)
+++ /dev/null
-1999-03-13 RELEASE-PREP
-
-Things to do to prepare a g77 release.
-
-- Update root.texi: clear DEVELOPMENT flag, set version info.
+++ /dev/null
-/* ansify.c
- Copyright (C) 1997, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
-
-#include "bconfig.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-
-#define die_unless(c) \
- do if (!(c)) \
- { \
- fprintf (stderr, "%s:%lu: %s\n", argv[1], lineno, #c); \
- die (); \
- } \
- while(0)
-
-static void ATTRIBUTE_NORETURN
-die (void)
-{
- exit (1);
-}
-
-int
-main(int argc, char **argv)
-{
- int c;
- static unsigned long lineno = 1;
-
- die_unless (argc == 2);
-
- printf ("\
-/* This file is automatically generated from `%s',\n\
- which you should modify instead. */\n\
-#line 1 \"%s\"\n\
-",
- argv[1], argv[1]);
-
- while ((c = getchar ()) != EOF)
- {
- switch (c)
- {
- default:
- putchar (c);
- break;
-
- case '\n':
- ++lineno;
- putchar (c);
- break;
-
- case '"':
- putchar (c);
- for (;;)
- {
- c = getchar ();
- die_unless (c != EOF);
- switch (c)
- {
- case '"':
- putchar (c);
- goto next_char;
-
- case '\n':
- putchar ('\\');
- putchar ('n');
- putchar ('\\');
- putchar ('\n');
- ++lineno;
- break;
-
- case '\\':
- putchar (c);
- c = getchar ();
- die_unless (c != EOF);
- putchar (c);
- if (c == '\n')
- ++lineno;
- break;
-
- default:
- putchar (c);
- break;
- }
- }
- break;
-
- case '\'':
- putchar (c);
- for (;;)
- {
- c = getchar ();
- die_unless (c != EOF);
- switch (c)
- {
- case '\'':
- putchar (c);
- goto next_char;
-
- case '\n':
- putchar ('\\');
- putchar ('n');
- putchar ('\\');
- putchar ('\n');
- ++lineno;
- break;
-
- case '\\':
- putchar (c);
- c = getchar ();
- die_unless (c != EOF);
- putchar (c);
- if (c == '\n')
- ++lineno;
- break;
-
- default:
- putchar (c);
- break;
- }
- }
- break;
-
- case '/':
- putchar (c);
- c = getchar ();
- putchar (c);
- if (c != '*')
- break;
- for (;;)
- {
- c = getchar ();
- die_unless (c != EOF);
-
- switch (c)
- {
- case '\n':
- ++lineno;
- putchar (c);
- break;
-
- case '*':
- c = getchar ();
- die_unless (c != EOF);
- if (c == '/')
- {
- putchar ('*');
- putchar ('/');
- goto next_char;
- }
- if (c == '\n')
- {
- ++lineno;
- putchar (c);
- }
- break;
-
- default:
- /* Don't bother outputting content of comments. */
- break;
- }
- }
- break;
- }
-
- next_char:
- ;
- }
-
- die_unless (c == EOF);
-
- return 0;
-}
+++ /dev/null
-/* bad.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None
-
- Description:
- Handles the displaying of diagnostic messages regarding the user's source
- files.
-
- Modifications:
-*/
-
-/* If there's a %E or %4 in the messages, set this to at least 5,
- for example. */
-
-#define FFEBAD_MAX_ 6
-
-/* Include files. */
-
-#include "proj.h"
-#include "bad.h"
-#include "flags.h"
-#include "com.h"
-#include "toplev.h"
-#include "where.h"
-#include "intl.h"
-#include "diagnostic.h"
-
-/* Externals defined here. */
-
-bool ffebad_is_inhibited_ = FALSE;
-
-/* Simple definitions and enumerations. */
-
-#define FFEBAD_LONG_MSGS_ 1 /* 0 to use short (or same) messages. */
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-struct _ffebad_message_
- {
- const ffebadSeverity severity;
- const char *const message;
- };
-
-/* Static objects accessed by functions in this module. */
-
-static const struct _ffebad_message_ ffebad_messages_[]
-=
-{
-#define FFEBAD_MSG(kwd,sev,msgid) { sev, msgid },
-#if FFEBAD_LONG_MSGS_ == 0
-#define LONG(m)
-#define SHORT(m) m
-#else
-#define LONG(m) m
-#define SHORT(m)
-#endif
-#include "bad.def"
-#undef FFEBAD_MSG
-#undef LONG
-#undef SHORT
-};
-
-static struct
- {
- ffewhereLine line;
- ffewhereColumn col;
- ffebadIndex tag;
- }
-
-ffebad_here_[FFEBAD_MAX_];
-static const char *ffebad_string_[FFEBAD_MAX_];
-static ffebadIndex ffebad_order_[FFEBAD_MAX_];
-static ffebad ffebad_errnum_;
-static ffebadSeverity ffebad_severity_;
-static const char *ffebad_message_;
-static unsigned char ffebad_index_;
-static ffebadIndex ffebad_places_;
-static bool ffebad_is_temp_inhibited_; /* Effective setting of
- _is_inhibited_ for this
- _start/_finish invocation. */
-
-/* Static functions (internal). */
-
-static int ffebad_bufputs_ (char buf[], int bufi, const char *s);
-
-/* Internal macros. */
-
-#define ffebad_bufflush_(buf, bufi) \
- (((buf)[bufi] = '\0'), fputs ((buf), stderr), 0)
-#define ffebad_bufputc_(buf, bufi, c) \
- (((bufi) == ARRAY_SIZE (buf)) \
- ? (ffebad_bufflush_ ((buf), (bufi)), ((buf)[0] = (c)), 1) \
- : (((buf)[bufi] = (c)), (bufi) + 1))
-\f
-
-static int
-ffebad_bufputs_ (char buf[], int bufi, const char *s)
-{
- for (; *s != '\0'; ++s)
- bufi = ffebad_bufputc_ (buf, bufi, *s);
- return bufi;
-}
-
-/* ffebad_init_0 -- Initialize
-
- ffebad_init_0(); */
-
-void
-ffebad_init_0 (void)
-{
- assert (FFEBAD == ARRAY_SIZE (ffebad_messages_));
-}
-
-ffebadSeverity
-ffebad_severity (ffebad errnum)
-{
- return ffebad_messages_[errnum].severity;
-}
-
-/* ffebad_start_ -- Start displaying an error message
-
- ffebad_start(FFEBAD_SOME_ERROR_CODE);
-
- Call ffebad_start to establish the message, ffebad_here and ffebad_string
- to send run-time data to it as necessary, then ffebad_finish when through
- to actually get it to print (to stderr).
-
- Note: ffebad_start(errnum) turns into ffebad_start_(FALSE,errnum). No
- outside caller should call ffebad_start_ directly (as indicated by the
- trailing underscore).
-
- Call ffebad_start to start a normal message, one that might be inhibited
- by the current state of statement guessing. Call ffebad_start_lex
- instead to start a message that is global to all statement guesses and
- happens only once for all guesses (i.e. the lexer).
-
- sev and message are overrides for the severity and messages when errnum
- is FFEBAD, meaning the caller didn't want to have to put a message in
- bad.def to produce a diagnostic. */
-
-bool
-ffebad_start_ (bool lex_override, ffebad errnum, ffebadSeverity sev,
- const char *msgid)
-{
- unsigned char i;
-
- if (ffebad_is_inhibited_ && !lex_override)
- {
- ffebad_is_temp_inhibited_ = TRUE;
- return FALSE;
- }
-
- if (errnum != FFEBAD)
- {
- ffebad_severity_ = ffebad_messages_[errnum].severity;
- ffebad_message_ = gettext (ffebad_messages_[errnum].message);
- }
- else
- {
- ffebad_severity_ = sev;
- ffebad_message_ = gettext (msgid);
- }
-
- switch (ffebad_severity_)
- { /* Tell toplev.c about this message. */
- case FFEBAD_severityINFORMATIONAL:
- case FFEBAD_severityTRIVIAL:
- if (inhibit_warnings)
- { /* User wants no warnings. */
- ffebad_is_temp_inhibited_ = TRUE;
- return FALSE;
- }
- /* Fall through. */
- case FFEBAD_severityWARNING:
- case FFEBAD_severityPECULIAR:
- case FFEBAD_severityPEDANTIC:
- if ((ffebad_severity_ != FFEBAD_severityPEDANTIC)
- || !flag_pedantic_errors)
- {
- if (!diagnostic_report_warnings_p ())
- { /* User wants no warnings. */
- ffebad_is_temp_inhibited_ = TRUE;
- return FALSE;
- }
- diagnostic_kind_count (global_dc, DK_WARNING)++;
- break;
- }
- /* Fall through (PEDANTIC && flag_pedantic_errors). */
- case FFEBAD_severityFATAL:
- case FFEBAD_severityWEIRD:
- case FFEBAD_severitySEVERE:
- case FFEBAD_severityDISASTER:
- diagnostic_kind_count (global_dc, DK_ERROR)++;
- break;
-
- default:
- break;
- }
-
- ffebad_is_temp_inhibited_ = FALSE;
- ffebad_errnum_ = errnum;
- ffebad_index_ = 0;
- ffebad_places_ = 0;
- for (i = 0; i < FFEBAD_MAX_; ++i)
- {
- ffebad_string_[i] = NULL;
- ffebad_here_[i].line = ffewhere_line_unknown ();
- ffebad_here_[i].col = ffewhere_column_unknown ();
- }
-
- return TRUE;
-}
-
-/* ffebad_here -- Establish source location of some diagnostic concern
-
- ffebad_here(ffebadIndex i,ffewhereLine line,ffewhereColumn col);
-
- Call ffebad_start to establish the message, ffebad_here and ffebad_string
- to send run-time data to it as necessary, then ffebad_finish when through
- to actually get it to print (to stderr). */
-
-void
-ffebad_here (ffebadIndex index, ffewhereLine line, ffewhereColumn col)
-{
- ffewhereLineNumber line_num;
- ffewhereLineNumber ln;
- ffewhereColumnNumber col_num;
- ffewhereColumnNumber cn;
- ffebadIndex i;
- ffebadIndex j;
-
- if (ffebad_is_temp_inhibited_)
- return;
-
- assert (index < FFEBAD_MAX_);
- ffebad_here_[index].line = ffewhere_line_use (line);
- ffebad_here_[index].col = ffewhere_column_use (col);
- if (ffewhere_line_is_unknown (line)
- || ffewhere_column_is_unknown (col))
- {
- ffebad_here_[index].tag = FFEBAD_MAX_;
- return;
- }
- ffebad_here_[index].tag = 0; /* For now, though it shouldn't matter. */
-
- /* Sort the source line/col points into the order they occur in the source
- file. Deal with duplicates appropriately. */
-
- line_num = ffewhere_line_number (line);
- col_num = ffewhere_column_number (col);
-
- /* Determine where in the ffebad_order_ array this new place should go. */
-
- for (i = 0; i < ffebad_places_; ++i)
- {
- ln = ffewhere_line_number (ffebad_here_[ffebad_order_[i]].line);
- cn = ffewhere_column_number (ffebad_here_[ffebad_order_[i]].col);
- if (line_num < ln)
- break;
- if (line_num == ln)
- {
- if (col_num == cn)
- {
- ffebad_here_[index].tag = i;
- return; /* Shouldn't go in, has equivalent. */
- }
- else if (col_num < cn)
- break;
- }
- }
-
- /* Before putting new place in ffebad_order_[i], first increment all tags
- that are i or greater. */
-
- if (i != ffebad_places_)
- {
- for (j = 0; j < FFEBAD_MAX_; ++j)
- {
- if (ffebad_here_[j].tag >= i)
- ++ffebad_here_[j].tag;
- }
- }
-
- /* Then slide all ffebad_order_[] entries at and above i up one entry. */
-
- for (j = ffebad_places_; j > i; --j)
- ffebad_order_[j] = ffebad_order_[j - 1];
-
- /* Finally can put new info in ffebad_order_[i]. */
-
- ffebad_order_[i] = index;
- ffebad_here_[index].tag = i;
- ++ffebad_places_;
-}
-
-/* Establish string for next index (always in order) of message
-
- ffebad_string(const char *string);
-
- Call ffebad_start to establish the message, ffebad_here and ffebad_string
- to send run-time data to it as necessary, then ffebad_finish when through
- to actually get it to print (to stderr). Note: don't trash the string
- until after calling ffebad_finish, since we just maintain a pointer to
- the argument passed in until then. */
-
-void
-ffebad_string (const char *string)
-{
- if (ffebad_is_temp_inhibited_)
- return;
-
- assert (ffebad_index_ != FFEBAD_MAX_);
- ffebad_string_[ffebad_index_++] = string;
-}
-
-/* ffebad_finish -- Display error message with where & run-time info
-
- ffebad_finish();
-
- Call ffebad_start to establish the message, ffebad_here and ffebad_string
- to send run-time data to it as necessary, then ffebad_finish when through
- to actually get it to print (to stderr). */
-
-void
-ffebad_finish (void)
-{
-#define MAX_SPACES 132
- static const char *const spaces
- = "...>\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
-\040\040\040"; /* MAX_SPACES - 1 spaces. */
- ffewhereLineNumber last_line_num;
- ffewhereLineNumber ln;
- ffewhereLineNumber rn;
- ffewhereColumnNumber last_col_num;
- ffewhereColumnNumber cn;
- ffewhereColumnNumber cnt;
- ffewhereLine l;
- ffebadIndex bi;
- unsigned short i;
- char pointer;
- unsigned char c;
- unsigned const char *s;
- const char *fn;
- static char buf[1024];
- int bufi;
- int index;
-
- if (ffebad_is_temp_inhibited_)
- return;
-
- switch (ffebad_severity_)
- {
- case FFEBAD_severityINFORMATIONAL:
- s = _("note:");
- break;
-
- case FFEBAD_severityWARNING:
- s = _("warning:");
- break;
-
- case FFEBAD_severitySEVERE:
- s = _("fatal:");
- break;
-
- default:
- s = "";
- break;
- }
-
- /* Display the annoying source references. */
-
- last_line_num = 0;
- last_col_num = 0;
-
- for (bi = 0; bi < ffebad_places_; ++bi)
- {
- if (ffebad_places_ == 1)
- pointer = '^';
- else
- pointer = '1' + bi;
-
- l = ffebad_here_[ffebad_order_[bi]].line;
- ln = ffewhere_line_number (l);
- rn = ffewhere_line_filelinenum (l);
- cn = ffewhere_column_number (ffebad_here_[ffebad_order_[bi]].col);
- fn = ffewhere_line_filename (l);
- if (ln != last_line_num)
- {
- if (bi != 0)
- fputc ('\n', stderr);
- diagnostic_report_current_function (global_dc);
- fprintf (stderr,
- /* the trailing space on the <file>:<line>: line
- fools emacs19 compilation mode into finding the
- report */
- "%s:%" ffewhereLineNumber_f "u: %s\n %s\n %s%c",
- fn, rn,
- s,
- ffewhere_line_content (l),
- &spaces[cn > MAX_SPACES ? 0 : MAX_SPACES - cn + 4],
- pointer);
- last_line_num = ln;
- last_col_num = cn;
- s = _("(continued):");
- }
- else
- {
- cnt = cn - last_col_num;
- fprintf (stderr,
- "%s%c", &spaces[cnt > MAX_SPACES
- ? 0 : MAX_SPACES - cnt + 4],
- pointer);
- last_col_num = cn;
- }
- }
- if (ffebad_places_ == 0)
- {
- /* Didn't output "warning:" string, capitalize it for message. */
- if (s[0] != '\0')
- {
- char c;
-
- c = TOUPPER (s[0]);
- fprintf (stderr, "%c%s ", c, &s[1]);
- }
- else if (s[0] != '\0')
- fprintf (stderr, "%s ", s);
- }
- else
- fputc ('\n', stderr);
-
- /* Release the ffewhere info. */
-
- for (bi = 0; bi < FFEBAD_MAX_; ++bi)
- {
- ffewhere_line_kill (ffebad_here_[bi].line);
- ffewhere_column_kill (ffebad_here_[bi].col);
- }
-
- /* Now display the message. */
-
- bufi = 0;
- for (i = 0; (c = ffebad_message_[i]) != '\0'; ++i)
- {
- if (c == '%')
- {
- c = ffebad_message_[++i];
- if (ISUPPER (c))
- {
- index = c - 'A';
-
- if ((index < 0) || (index >= FFEBAD_MAX_))
- {
- bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!] %"));
- bufi = ffebad_bufputc_ (buf, bufi, c);
- }
- else
- {
- s = ffebad_string_[index];
- if (s == NULL)
- bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!]"));
- else
- bufi = ffebad_bufputs_ (buf, bufi, s);
- }
- }
- else if (ISDIGIT (c))
- {
- index = c - '0';
-
- if ((index < 0) || (index >= FFEBAD_MAX_))
- {
- bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!] %"));
- bufi = ffebad_bufputc_ (buf, bufi, c);
- }
- else
- {
- pointer = ffebad_here_[index].tag + '1';
- if (pointer == FFEBAD_MAX_ + '1')
- pointer = '?';
- else if (ffebad_places_ == 1)
- pointer = '^';
- bufi = ffebad_bufputc_ (buf, bufi, '(');
- bufi = ffebad_bufputc_ (buf, bufi, pointer);
- bufi = ffebad_bufputc_ (buf, bufi, ')');
- }
- }
- else if (c == '\0')
- break;
- else if (c == '%')
- bufi = ffebad_bufputc_ (buf, bufi, '%');
- else
- {
- bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!]"));
- bufi = ffebad_bufputc_ (buf, bufi, '%');
- bufi = ffebad_bufputc_ (buf, bufi, c);
- }
- }
- else
- bufi = ffebad_bufputc_ (buf, bufi, c);
- }
- bufi = ffebad_bufputc_ (buf, bufi, '\n');
- bufi = ffebad_bufflush_ (buf, bufi);
-}
+++ /dev/null
-/* bad.def -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 1996, 1997, 2002 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- bad.c
-
- Modifications:
-*/
-
-#define INFORM FFEBAD_severityINFORMATIONAL
-#define TRIVIAL FFEBAD_severityTRIVIAL
-#define WARN FFEBAD_severityWARNING
-#define PECULIAR FFEBAD_severityPECULIAR
-#define FATAL FFEBAD_severityFATAL
-#define WEIRD FFEBAD_severityWEIRD
-#define SEVERE FFEBAD_severitySEVERE
-#define DISASTER FFEBAD_severityDISASTER
-
-FFEBAD_MSG (FFEBAD_MISSING_FIRST_BINARY_OPERAND, FATAL,
-/* xgettext:no-c-format */
-"Missing first operand for binary operator at %0")
-FFEBAD_MSG (FFEBAD_NULL_CHAR_CONST, WARN,
-/* xgettext:no-c-format */
-"Zero-length character constant at %0")
-FFEBAD_MSG (FFEBAD_INVALID_TOKEN_IN_EXPRESSION, FATAL,
-/* xgettext:no-c-format */
-"Invalid token at %0 in expression or subexpression at %1")
-FFEBAD_MSG (FFEBAD_MISSING_OPERAND_FOR_OPERATOR, FATAL,
-/* xgettext:no-c-format */
-"Missing operand for operator at %1 at end of expression at %0")
-FFEBAD_MSG (FFEBAD_LABEL_ALREADY_DEFINED, FATAL,
-/* xgettext:no-c-format */
-"Label %A already defined at %1 when redefined at %0")
-FFEBAD_MSG (FFEBAD_UNRECOGNIZED_CHARACTER, FATAL,
-/* xgettext:no-c-format */
-"Unrecognized character at %0 [info -f g77 M LEX]")
-FFEBAD_MSG (FFEBAD_LABEL_WITHOUT_STMT, WARN,
-/* xgettext:no-c-format */
-"Label definition %A at %0 on empty statement (as of %1)")
-FFEBAD_MSG (FFEBAD_EXTRA_LABEL_DEF, FATAL,
-/* xgettext:no-c-format */
-LONG("Extra label definition %A at %0 -- perhaps previous label definition %B at %1 should have CONTINUE statement?")
-/* xgettext:no-c-format */
-SHORT("Extra label definition %A at %0 following label definition %B at %1"))
-FFEBAD_MSG (FFEBAD_FIRST_CHAR_INVALID, FATAL,
-/* xgettext:no-c-format */
-"Invalid first character at %0 [info -f g77 M LEX]")
-FFEBAD_MSG (FFEBAD_LINE_TOO_LONG, FATAL,
-/* xgettext:no-c-format */
-"Line too long as of %0 [info -f g77 M LEX]")
-FFEBAD_MSG (FFEBAD_LABEL_FIELD_NOT_NUMERIC, FATAL,
-/* xgettext:no-c-format */
-"Non-numeric character at %0 in label field [info -f g77 M LEX]")
-FFEBAD_MSG (FFEBAD_LABEL_NUMBER_INVALID, FATAL,
-/* xgettext:no-c-format */
-"Label number at %0 not in range 1-99999")
-FFEBAD_MSG (FFEBAD_NON_ANSI_COMMENT, WARN,
-/* xgettext:no-c-format */
-"At %0, '!' and '/*' are not valid comment delimiters")
-FFEBAD_MSG (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, WARN,
-/* xgettext:no-c-format */
-"Continuation indicator at %0 must appear in column 6 [info -f g77 M LEX]")
-FFEBAD_MSG (FFEBAD_LABEL_ON_CONTINUATION, FATAL,
-/* xgettext:no-c-format */
-"Label at %0 invalid with continuation line indicator at %1 [info -f g77 M LEX]")
-FFEBAD_MSG (FFEBAD_INVALID_CONTINUATION, FATAL,
-/* xgettext:no-c-format */
-LONG("Continuation indicator at %0 invalid on first non-comment line of file or following END or INCLUDE [info -f g77 M LEX]")
-/* xgettext:no-c-format */
-SHORT("Continuation indicator at %0 invalid here [info -f g77 M LEX]"))
-FFEBAD_MSG (FFEBAD_NO_CLOSING_APOSTROPHE, FATAL,
-/* xgettext:no-c-format */
-"Character constant at %0 has no closing apostrophe at %1")
-FFEBAD_MSG (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS, FATAL,
-/* xgettext:no-c-format */
-"Hollerith constant at %0 specified %A more characters than are present as of %1")
-FFEBAD_MSG (FFEBAD_MISSING_CLOSE_PAREN, FATAL,
-/* xgettext:no-c-format */
-"Missing close parenthese at %0 needed to match open parenthese at %1")
-FFEBAD_MSG (FFEBAD_INTEGER_TOO_LARGE, FATAL,
-/* xgettext:no-c-format */
-"Integer at %0 too large")
-FFEBAD_MSG (FFEBAD_BAD_MAGICAL, WARN,
-/* xgettext:no-c-format */
-LONG("Integer at %0 too large except as negative number (preceded by unary minus sign)")
-/* xgettext:no-c-format */
-SHORT("Non-negative integer at %0 too large"))
-FFEBAD_MSG (FFEBAD_BAD_MAGICAL_PRECEDENCE, WARN,
-/* xgettext:no-c-format */
-LONG("Integer at %0 too large; even though preceded by unary minus sign at %1, subsequent operator at %2 has precedence over unary minus -- enclose unary minus sign and integer in parentheses to force precedence")
-/* xgettext:no-c-format */
-SHORT("Integer at %0 too large (%2 has precedence over %1)"))
-FFEBAD_MSG (FFEBAD_BAD_MAGICAL_BINARY, WARN,
-/* xgettext:no-c-format */
-LONG("Integer at %0 too large; even though preceded by minus sign at %1, because minus sign is a binary, not unary, operator -- insert plus sign before minus sign to change it to a unary minus sign")
-/* xgettext:no-c-format */
-SHORT("Integer at %0 too large (needs unary, not binary, minus at %1)"))
-FFEBAD_MSG (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY, WARN,
-/* xgettext:no-c-format */
-LONG("Integer at %0 too large; even though preceded by minus sign at %1, subsequent operator at %2 has precedence over minus, and that minus sign should be a unary minus rather than a binary minus -- insert plus sign before minus sign to change it to a unary minus sign, and enclose unary minus sign and integer in parentheses to force precedence")
-/* xgettext:no-c-format */
-SHORT("Integer at %0 too large (%2 has precedence over %1, which needs to be unary, not binary, minus)"))
-FFEBAD_MSG (FFEBAD_IGNORING_PERIOD, FATAL,
-/* xgettext:no-c-format */
-"Period at %0 not followed by digits for floating-point number or by `NOT.', `TRUE.', or `FALSE.'")
-FFEBAD_MSG (FFEBAD_INSERTING_PERIOD, FATAL,
-/* xgettext:no-c-format */
-"Missing close-period between `.%A' at %0 and %1")
-FFEBAD_MSG (FFEBAD_INVALID_EXPONENT, FATAL,
-/* xgettext:no-c-format */
-"Invalid exponent at %0 for real constant at %1; nondigit `%A' in exponent field")
-FFEBAD_MSG (FFEBAD_MISSING_EXPONENT_VALUE, FATAL,
-/* xgettext:no-c-format */
-"Missing value at %1 for real-number exponent at %0")
-FFEBAD_MSG (FFEBAD_MISSING_BINARY_OPERATOR, FATAL,
-/* xgettext:no-c-format */
-"Expected binary operator between expressions at %0 and at %1")
-FFEBAD_MSG (FFEBAD_INVALID_DOTDOT, FATAL,
-/* xgettext:no-c-format */
-LONG("Period at %0 not followed by valid keyword forming a valid binary operator; `.%A.' is not a valid binary operator")
-/* xgettext:no-c-format */
-SHORT("`.%A.' at %0 not a binary operator"))
-FFEBAD_MSG (FFEBAD_QUOTE_MISSES_DIGITS, FATAL,
-/* xgettext:no-c-format */
-LONG("Double-quote at %0 not followed by a string of valid octal digits at %1")
-/* xgettext:no-c-format */
-SHORT("Invalid octal constant at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_BINARY_DIGIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid binary digit(s) found in string of digits at %0")
-/* xgettext:no-c-format */
-SHORT("Invalid binary constant at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_HEX_DIGIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid hexadecimal digit(s) found in string of digits at %0")
-/* xgettext:no-c-format */
-SHORT("Invalid hexadecimal constant at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_OCTAL_DIGIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid octal digit(s) found in string of digits at %0")
-/* xgettext:no-c-format */
-SHORT("Invalid octal constant at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_RADIX_SPECIFIER, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid radix specifier `%A' at %0 for typeless constant at %1")
-/* xgettext:no-c-format */
-SHORT("Invalid typeless constant at %1"))
-FFEBAD_MSG (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid binary digit(s) found in string of digits at %0")
-/* xgettext:no-c-format */
-SHORT("Invalid binary constant at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid octal digit(s) found in string of digits at %0")
-/* xgettext:no-c-format */
-SHORT("Invalid octal constant at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_TYPELESS_HEX_DIGIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid hexadecimal digit(s) found in string of digits at %0")
-/* xgettext:no-c-format */
-SHORT("Invalid hexadecimal constant at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_COMPLEX_PART, FATAL,
-/* xgettext:no-c-format */
-LONG("%A part of complex constant at %0 must be a real or integer constant -- otherwise use CMPLX() or COMPLEX() in place of ()")
-/* xgettext:no-c-format */
-SHORT("%A part of complex constant at %0 not a real or integer constant"))
-FFEBAD_MSG (FFEBAD_INVALID_PERCENT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid keyword `%%%A' at %0 in this context")
-/* xgettext:no-c-format */
-SHORT("Invalid keyword `%%%A' at %0"))
-FFEBAD_MSG (FFEBAD_NULL_EXPRESSION, FATAL,
-/* xgettext:no-c-format */
-LONG("Null expression between %0 and %1 invalid in this context")
-/* xgettext:no-c-format */
-SHORT("Invalid null expression between %0 and %1"))
-FFEBAD_MSG (FFEBAD_CONCAT_ARGS_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Concatenation operator at %0 must operate on two subexpressions of character type, but neither subexpression at %1 or %2 is of character type")
-/* xgettext:no-c-format */
-SHORT("Invalid operands at %1 and %2 for concatenation operator at %0"))
-FFEBAD_MSG (FFEBAD_CONCAT_ARG_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Concatenation operator at %0 must operate on two subexpressions of character type, but the subexpression at %1 is not of character type")
-/* xgettext:no-c-format */
-SHORT("Invalid operand at %1 for concatenation operator at %0"))
-FFEBAD_MSG (FFEBAD_CONCAT_ARG_KIND, FATAL,
-/* xgettext:no-c-format */
-LONG("Concatenation operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning character scalars, or a combination of both -- but the subexpression at %1 is %A")
-/* xgettext:no-c-format */
-SHORT("Invalid operand (is %A) at %1 for concatenation operator at %0"))
-FFEBAD_MSG (FFEBAD_MATH_ARGS_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Arithmetic operator at %0 must operate on two subexpressions of arithmetic type, but neither subexpression at %1 or %2 is of arithmetic type")
-/* xgettext:no-c-format */
-SHORT("Invalid operands at %1 and %2 for arithmetic operator at %0"))
-FFEBAD_MSG (FFEBAD_MATH_ARG_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Arithmetic operator at %0 must operate on two subexpressions of arithmetic type, but the subexpression at %1 is not of arithmetic type")
-/* xgettext:no-c-format */
-SHORT("Invalid operand at %1 for arithmetic operator at %0"))
-FFEBAD_MSG (FFEBAD_MATH_ARG_KIND, FATAL,
-/* xgettext:no-c-format */
-LONG("Arithmetic operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning arithmetic scalars, or a combination of both -- but the subexpression at %1 is %A")
-/* xgettext:no-c-format */
-SHORT("Invalid operand (is %A) at %1 for arithmetic operator at %0"))
-FFEBAD_MSG (FFEBAD_NO_CLOSING_QUOTE, FATAL,
-/* xgettext:no-c-format */
-LONG("Character constant at %0 has no closing quote at %1 [info -f g77 M LEX]")
-/* xgettext:no-c-format */
-SHORT("Unterminated character constant at %0 [info -f g77 M LEX]"))
-FFEBAD_MSG (FFEBAD_BAD_CHAR_CONTINUE, FATAL,
-/* xgettext:no-c-format */
-LONG("Continuation line at %0 must have initial `&' since it continues a character context [info -f g77 M LEX]")
-/* xgettext:no-c-format */
-SHORT("Missing initial `&' on continuation line at %0 [info -f g77 M LEX]"))
-FFEBAD_MSG (FFEBAD_BAD_LEXTOK_CONTINUE, FATAL,
-/* xgettext:no-c-format */
-LONG("Continuation line at %0 must have initial `&' since it continues a split lexical token [info -f g77 M LEX]")
-/* xgettext:no-c-format */
-SHORT("Missing initial `&' on continuation line at %0 [info -f g77 M LEX]"))
-FFEBAD_MSG (FFEBAD_BAD_FREE_CONTINUE, FATAL,
-/* xgettext:no-c-format */
-LONG("Continuation line at %0 invalid because it consists only of a single `&' as the only nonblank character")
-/* xgettext:no-c-format */
-SHORT("Invalid continuation line at %0"))
-FFEBAD_MSG (FFEBAD_STMT_BEGINS_BAD, FATAL,
-/* xgettext:no-c-format */
-LONG("Statement at %0 begins with invalid token [info -f g77 M LEX]")
-/* xgettext:no-c-format */
-SHORT("Invalid statement at %0 [info -f g77 M LEX]"))
-FFEBAD_MSG (FFEBAD_SEMICOLON, FATAL,
-/* xgettext:no-c-format */
-"Semicolon at %0 is an invalid token")
-FFEBAD_MSG (FFEBAD_UNREC_STMT, FATAL,
-/* xgettext:no-c-format */
-LONG("Unrecognized statement name at %0 and invalid form for assignment or statement-function definition at %1")
-/* xgettext:no-c-format */
-SHORT("Invalid statement at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_STMT_FORM, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid form for %A statement at %0")
-/* xgettext:no-c-format */
-SHORT("Invalid %A statement at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_HOLL_IN_STMT, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid use of hollerith constant in statement at %0 -- enclose the constant in parentheses (for example, change BACKSPACE 2HAB to BACKSPACE (2HAB))")
-/* xgettext:no-c-format */
-SHORT("Enclose hollerith constant in statement at %0 in parentheses"))
-FFEBAD_MSG (FFEBAD_FORMAT_EXTRA_COMMA, FATAL,
-/* xgettext:no-c-format */
-"Extraneous comma in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_MISSING_COMMA, WARN,
-/* xgettext:no-c-format */
-"Missing comma in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_SPURIOUS_SIGN, FATAL,
-/* xgettext:no-c-format */
-"Spurious sign in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_SPURIOUS_NUMBER, FATAL,
-/* xgettext:no-c-format */
-"Spurious number in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_TEXT_IN_NUMBER, FATAL,
-/* xgettext:no-c-format */
-"Spurious text trailing number in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_P_NOCOMMA, FATAL,
-/* xgettext:no-c-format */
-LONG("nP control edit descriptor not followed by comma but followed by edit descriptor at %0 other than D, E, EN, F, or G")
-/* xgettext:no-c-format */
-SHORT("Invalid edit descriptor at %0 following nP control edit descriptor"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_SPEC, FATAL,
-/* xgettext:no-c-format */
-"Unrecognized FORMAT specifier at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_I_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid I specifier in FORMAT statement at %0 -- correct form: [r]Iw.[m]")
-/* xgettext:no-c-format */
-SHORT("Invalid I specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_B_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid B specifier in FORMAT statement at %0 -- correct form: [r]Bw.[m]")
-/* xgettext:no-c-format */
-SHORT("Invalid B specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_O_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid O specifier in FORMAT statement at %0 -- correct form: [r]Ow.[m]")
-/* xgettext:no-c-format */
-SHORT("Invalid O specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_Z_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid Z specifier in FORMAT statement at %0 -- correct form: [r]Zw.[m]")
-/* xgettext:no-c-format */
-SHORT("Invalid Z specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_F_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid F specifier in FORMAT statement at %0 -- correct form: [r]Fw.d")
-/* xgettext:no-c-format */
-SHORT("Invalid F specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_E_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid E specifier in FORMAT statement at %0 -- correct form: [r]Ew.d[Ee]")
-/* xgettext:no-c-format */
-SHORT("Invalid E specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_EN_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid EN specifier in FORMAT statement at %0 -- correct form: [r]ENw.d[Ee]")
-/* xgettext:no-c-format */
-SHORT("Invalid EN specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_G_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid G specifier in FORMAT statement at %0 -- correct form: [r]Gw.d[Ee]")
-/* xgettext:no-c-format */
-SHORT("Invalid G specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_L_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid L specifier in FORMAT statement at %0 -- correct form: [r]Lw")
-/* xgettext:no-c-format */
-SHORT("Invalid L specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_A_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid A specifier in FORMAT statement at %0 -- correct form: [r]A[w]")
-/* xgettext:no-c-format */
-SHORT("Invalid A specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_D_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid D specifier in FORMAT statement at %0 -- correct form: [r]Dw.d")
-/* xgettext:no-c-format */
-SHORT("Invalid D specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_Q_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid Q specifier in FORMAT statement at %0 -- correct form: Q")
-/* xgettext:no-c-format */
-SHORT("Invalid Q specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_DOLLAR_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid $ specifier in FORMAT statement at %0 -- correct form: $")
-/* xgettext:no-c-format */
-SHORT("Invalid $ specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_P_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid P specifier in FORMAT statement at %0 -- correct form: kP")
-/* xgettext:no-c-format */
-SHORT("Invalid P specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_T_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid T specifier in FORMAT statement at %0 -- correct form: Tn")
-/* xgettext:no-c-format */
-SHORT("Invalid T specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_TL_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid TL specifier in FORMAT statement at %0 -- correct form: TLn")
-/* xgettext:no-c-format */
-SHORT("Invalid TL specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_TR_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid TR specifier in FORMAT statement at %0 -- correct form: TRn")
-/* xgettext:no-c-format */
-SHORT("Invalid TR specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_X_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid X specifier in FORMAT statement at %0 -- correct form: nX")
-/* xgettext:no-c-format */
-SHORT("Invalid X specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_S_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid S specifier in FORMAT statement at %0 -- correct form: S")
-/* xgettext:no-c-format */
-SHORT("Invalid S specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_SP_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid SP specifier in FORMAT statement at %0 -- correct form: SP")
-/* xgettext:no-c-format */
-SHORT("Invalid SP specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_SS_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid SS specifier in FORMAT statement at %0 -- correct form: SS")
-/* xgettext:no-c-format */
-SHORT("Invalid SS specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_BN_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid BN specifier in FORMAT statement at %0 -- correct form: BN")
-/* xgettext:no-c-format */
-SHORT("Invalid BN specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_BZ_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid BZ specifier in FORMAT statement at %0 -- correct form: BZ")
-/* xgettext:no-c-format */
-SHORT("Invalid BZ specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_COLON_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid : specifier in FORMAT statement at %0 -- correct form: :")
-/* xgettext:no-c-format */
-SHORT("Invalid : specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_BAD_H_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid H specifier in FORMAT statement at %0 -- correct form: nHcharacters !where n is an unsigned decimal constant, and characters !contains exactly n characters (including spaces)")
-/* xgettext:no-c-format */
-SHORT("Invalid H specifier in FORMAT statement at %0"))
-FFEBAD_MSG (FFEBAD_FORMAT_MISSING_PAREN, FATAL,
-/* xgettext:no-c-format */
-"Missing close-parenthese(s) in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_MISSING_DOT, FATAL,
-/* xgettext:no-c-format */
-"Missing number following period in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_MISSING_EXP, FATAL,
-/* xgettext:no-c-format */
-"Missing number following `E' in FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_EXPR_TOKEN, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid token with FORMAT run-time expression at %0 -- use the traditional operators .LT., .LE., .GT., .GE., .EQ., and .NE. in place of the newer tokens <, <=, >, >=, ==, and !=, because > ends an expression within a FORMAT statement")
-/* xgettext:no-c-format */
-SHORT("Invalid token with FORMAT run-time expression at %0"))
-FFEBAD_MSG (FFEBAD_TRAILING_COMMA, WARN,
-/* xgettext:no-c-format */
-"Spurious trailing comma preceding terminator at %0")
-FFEBAD_MSG (FFEBAD_INTERFACE_ASSIGNMENT, WARN,
-/* xgettext:no-c-format */
-"At %0, specify OPERATOR instead of ASSIGNMENT for INTERFACE statement not specifying the assignment operator (=)")
-FFEBAD_MSG (FFEBAD_INTERFACE_OPERATOR, WARN,
-/* xgettext:no-c-format */
-"At %0, specify ASSIGNMENT instead of OPERATOR for INTERFACE statement specifying the assignment operator (=)")
-FFEBAD_MSG (FFEBAD_INTERFACE_NONLETTER, FATAL,
-/* xgettext:no-c-format */
-LONG("Defined operator at %0 contains a nonletter -- must contain only letters A-Z (or a-z)")
-/* xgettext:no-c-format */
-SHORT("Nonletter in defined operator at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_TYPEDECL_ATTR, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid type-declaration attribute at %0 -- must be one of: DIMENSION(array-spec), EXTERNAL, INTRINSIC, PARAMETER, or SAVE")
-/* xgettext:no-c-format */
-SHORT("Invalid type-declaration attribute at %0"))
-FFEBAD_MSG (FFEBAD_INVALID_TYPEDECL_INIT, FATAL,
-/* xgettext:no-c-format */
-"Cannot specify =initialization-expr at %0 unless `::' appears before list of objects")
-FFEBAD_MSG (FFEBAD_LABEL_USE_DEF, FATAL,
-/* xgettext:no-c-format */
-"Reference to label at %1 inconsistent with its definition at %0")
-FFEBAD_MSG (FFEBAD_LABEL_USE_USE, FATAL,
-/* xgettext:no-c-format */
-"Reference to label at %1 inconsistent with earlier reference at %0")
-FFEBAD_MSG (FFEBAD_LABEL_DEF_DO, FATAL,
-/* xgettext:no-c-format */
-"DO-statement reference to label at %1 follows its definition at %0")
-FFEBAD_MSG (FFEBAD_LABEL_BLOCK, WARN,
-/* xgettext:no-c-format */
-"Reference to label at %1 is outside block containing definition at %0")
-FFEBAD_MSG (FFEBAD_LABEL_DO_BLOCK_DO, FATAL,
-/* xgettext:no-c-format */
-"DO-statement references to label at %0 and %2 separated by unterminated block starting at %1")
-FFEBAD_MSG (FFEBAD_LABEL_DO_BLOCK_END, FATAL,
-/* xgettext:no-c-format */
-"DO-statement reference to label at %0 and label definition at %2 separated by unterminated block starting at %1")
-FFEBAD_MSG (FFEBAD_INVALID_LABEL_DEF, FATAL,
-/* xgettext:no-c-format */
-"Label definition at %0 invalid on this kind of statement")
-FFEBAD_MSG (FFEBAD_ORDER_1, FATAL,
-/* xgettext:no-c-format */
-"Statement at %0 invalid in this context")
-FFEBAD_MSG (FFEBAD_ORDER_2, FATAL,
-/* xgettext:no-c-format */
-"Statement at %0 invalid in context established by statement at %1")
-FFEBAD_MSG (FFEBAD_CONSTRUCT_NAMED, FATAL,
-/* xgettext:no-c-format */
-"Statement at %0 must specify construct name specified at %1")
-FFEBAD_MSG (FFEBAD_CONSTRUCT_NOT_NAMED, FATAL,
-/* xgettext:no-c-format */
-"Construct name at %0 superfluous, no construct name specified at %1")
-FFEBAD_MSG (FFEBAD_CONSTRUCT_WRONG_NAME, FATAL,
-/* xgettext:no-c-format */
-"Construct name at %0 not the same as construct name at %1")
-FFEBAD_MSG (FFEBAD_CONSTRUCT_NO_DO_NAME, FATAL,
-/* xgettext:no-c-format */
-"Construct name at %0 does not match construct name for any containing DO constructs")
-FFEBAD_MSG (FFEBAD_DO_HAD_LABEL, FATAL,
-/* xgettext:no-c-format */
-"Label definition missing at %0 for DO construct specifying label at %1")
-FFEBAD_MSG (FFEBAD_AFTER_ELSE, FATAL,
-/* xgettext:no-c-format */
-"Statement at %0 follows ELSE block for IF construct at %1")
-FFEBAD_MSG (FFEBAD_FORMAT_NO_LABEL_DEF, FATAL,
-/* xgettext:no-c-format */
-"No label definition for FORMAT statement at %0")
-FFEBAD_MSG (FFEBAD_SECOND_ELSE_WHERE, FATAL,
-/* xgettext:no-c-format */
-"Second occurrence of ELSE WHERE at %0 within WHERE at %1")
-FFEBAD_MSG (FFEBAD_END_WO, WARN,
-/* xgettext:no-c-format */
-"END statement at %0 missing `%A' keyword required for internal or module procedure(s) bounded by %1")
-FFEBAD_MSG (FFEBAD_INVALID_MODULE_PROCEDURE, FATAL,
-/* xgettext:no-c-format */
-"MODULE PROCEDURE statement at %0 disallowed because INTERFACE at %1 specifies no generic name, operator, or assignment")
-FFEBAD_MSG (FFEBAD_BLOCKDATA_NOT_NAMED, FATAL,
-/* xgettext:no-c-format */
-"BLOCK DATA name at %0 superfluous, no name specified at %1")
-FFEBAD_MSG (FFEBAD_PROGRAM_NOT_NAMED, FATAL,
-/* xgettext:no-c-format */
-"Program name at %0 superfluous, no PROGRAM statement specified at %1")
-FFEBAD_MSG (FFEBAD_UNIT_WRONG_NAME, FATAL,
-/* xgettext:no-c-format */
-"Program unit name at %0 not the same as name at %1")
-FFEBAD_MSG (FFEBAD_TYPE_WRONG_NAME, FATAL,
-/* xgettext:no-c-format */
-"Type name at %0 not the same as name at %1")
-FFEBAD_MSG (FFEBAD_EOF_BEFORE_BLOCK_END, FATAL,
-/* xgettext:no-c-format */
-"End of source file before end of block started at %0")
-FFEBAD_MSG (FFEBAD_UNDEF_LABEL, FATAL,
-/* xgettext:no-c-format */
-"Undefined label, first referenced at %0")
-FFEBAD_MSG (FFEBAD_CONFLICTING_SAVES, WARN,
-/* xgettext:no-c-format */
-"SAVE statement or attribute at %1 cannot be specified along with SAVE statement or attribute at %0")
-FFEBAD_MSG (FFEBAD_CONFLICTING_ACCESSES, FATAL,
-/* xgettext:no-c-format */
-"PUBLIC or PRIVATE statement at %1 cannot be specified along with PUBLIC or PRIVATE statement at %0")
-FFEBAD_MSG (FFEBAD_RETURN_IN_MAIN, WARN,
-/* xgettext:no-c-format */
-"RETURN statement at %0 invalid within a main program unit")
-FFEBAD_MSG (FFEBAD_ALTRETURN_IN_PROGRAM, FATAL,
-/* xgettext:no-c-format */
-"Alternate return specifier at %0 invalid within a main program unit")
-FFEBAD_MSG (FFEBAD_ALTRETURN_IN_FUNCTION, FATAL,
-/* xgettext:no-c-format */
-"Alternate return specifier at %0 invalid within a function")
-FFEBAD_MSG (FFEBAD_DERIVTYP_ACCESS, FATAL,
-/* xgettext:no-c-format */
-"Access specifier or PRIVATE statement at %0 invalid for derived-type definition within other than the specification part of a module")
-FFEBAD_MSG (FFEBAD_DERIVTYP_ACCESS_FIRST, FATAL,
-/* xgettext:no-c-format */
-"Access specifier at %0 must immediately follow derived-type statement at %1 with no intervening statements")
-FFEBAD_MSG (FFEBAD_DERIVTYP_NO_COMPONENTS, FATAL,
-/* xgettext:no-c-format */
-"No components specified as of %0 for derived-type definition beginning at %1")
-FFEBAD_MSG (FFEBAD_STRUCT_NO_COMPONENTS, FATAL,
-/* xgettext:no-c-format */
-"No components specified as of %0 for structure definition beginning at %1")
-FFEBAD_MSG (FFEBAD_STRUCT_MISSING_NAME, FATAL,
-/* xgettext:no-c-format */
-"Missing structure name for outer structure definition at %0")
-FFEBAD_MSG (FFEBAD_STRUCT_IGNORING_FIELD, FATAL,
-/* xgettext:no-c-format */
-"Field names at %0 for outer structure definition -- specify them in a subsequent RECORD statement instead")
-FFEBAD_MSG (FFEBAD_STRUCT_MISSING_FIELD, FATAL,
-/* xgettext:no-c-format */
-"Missing field name(s) for structure definition at %0 within structure definition at %1")
-FFEBAD_MSG (FFEBAD_MAP_NO_COMPONENTS, FATAL,
-/* xgettext:no-c-format */
-"No components specified as of %0 for map beginning at %1")
-FFEBAD_MSG (FFEBAD_UNION_NO_TWO_MAPS, FATAL,
-/* xgettext:no-c-format */
-"Zero or one maps specified as of %0 for union beginning at %1 -- at least two are required")
-FFEBAD_MSG (FFEBAD_MISSING_SPECIFIER, FATAL,
-/* xgettext:no-c-format */
-"Missing %A specifier in statement at %0")
-FFEBAD_MSG (FFEBAD_NAMELIST_ITEMS, FATAL,
-/* xgettext:no-c-format */
-"Items in I/O list starting at %0 invalid for namelist-directed I/O")
-FFEBAD_MSG (FFEBAD_CONFLICTING_SPECS, FATAL,
-/* xgettext:no-c-format */
-"Conflicting I/O control specifications at %0 and %1")
-FFEBAD_MSG (FFEBAD_NO_UNIT_SPEC, FATAL,
-/* xgettext:no-c-format */
-"No UNIT= specifier in I/O control list at %0")
-FFEBAD_MSG (FFEBAD_MISSING_ADVANCE_SPEC, FATAL,
-/* xgettext:no-c-format */
-"Specification at %0 requires ADVANCE=`NO' specification in same I/O control list")
-FFEBAD_MSG (FFEBAD_MISSING_FORMAT_SPEC, FATAL,
-/* xgettext:no-c-format */
-"Specification at %0 requires explicit FMT= specification in same I/O control list")
-FFEBAD_MSG (FFEBAD_SPEC_VALUE, FATAL,
-/* xgettext:no-c-format */
-LONG("Unrecognized value for character constant at %0 -- expecting %A")
-/* xgettext:no-c-format */
-SHORT("Unrecognized value for character constant at %0"))
-FFEBAD_MSG (FFEBAD_CASE_SECOND_DEFAULT, FATAL,
-/* xgettext:no-c-format */
-"Second occurrence of CASE DEFAULT at %0 within SELECT CASE at %1")
-FFEBAD_MSG (FFEBAD_CASE_DUPLICATE, FATAL,
-/* xgettext:no-c-format */
-"Duplicate or overlapping case values/ranges at %0 and %1")
-FFEBAD_MSG (FFEBAD_CASE_TYPE_DISAGREE, FATAL,
-/* xgettext:no-c-format */
-"Type and/or kind-type parameter disagreement between CASE value or value within range at %0 and SELECT CASE at %1")
-FFEBAD_MSG (FFEBAD_CASE_LOGICAL_RANGE, FATAL,
-/* xgettext:no-c-format */
-"Range specification at %0 invalid for CASE statement within logical-type SELECT CASE statement")
-FFEBAD_MSG (FFEBAD_CASE_BAD_RANGE, FATAL,
-/* xgettext:no-c-format */
-LONG("Range specification at %0 invalid -- at least one expression must be specified, or use CASE DEFAULT")
-/* xgettext:no-c-format */
-SHORT("Range specification at %0 invalid"))
-FFEBAD_MSG (FFEBAD_CASE_RANGE_USELESS, INFORM,
-/* xgettext:no-c-format */
-LONG("Range specification at %0 useless; first expression greater than second expression in range, so range can never be matched by any selection expression")
-/* xgettext:no-c-format */
-SHORT("Useless range at %0"))
-FFEBAD_MSG (FFEBAD_F90, FATAL,
-/* xgettext:no-c-format */
-"Fortran 90 feature at %0 unsupported")
-FFEBAD_MSG (FFEBAD_KINDTYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid kind at %0 for type at %1 -- unsupported or not permitted")
-/* xgettext:no-c-format */
-SHORT("Invalid kind at %0 for type at %1"))
-FFEBAD_MSG (FFEBAD_BAD_IMPLICIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Cannot establish implicit type for initial letter `%A' at %0 -- already explicitly established or used to set implicit type of some name, or backwards order of letters in letter range")
-/* xgettext:no-c-format */
-SHORT("Cannot establish implicit type for initial letter `%A' at %0"))
-FFEBAD_MSG (FFEBAD_SYMERR, FATAL,
-/* xgettext:no-c-format */
-"Invalid declaration of or reference to symbol `%A' at %0 [initially seen at %1]")
-FFEBAD_MSG (FFEBAD_LABEL_WRONG_PLACE, FATAL,
-/* xgettext:no-c-format */
-LONG("Label definition %A (at %0) invalid -- must be in columns 1-5")
-/* xgettext:no-c-format */
-SHORT("Invalid label definition %A (at %0)"))
-FFEBAD_MSG (FFEBAD_NULL_ELEMENT, FATAL,
-/* xgettext:no-c-format */
-"Null element at %0 for array reference at %1")
-FFEBAD_MSG (FFEBAD_TOO_FEW_ELEMENTS, FATAL,
-/* xgettext:no-c-format */
-"Too few elements (%A missing) as of %0 for array reference at %1")
-FFEBAD_MSG (FFEBAD_TOO_MANY_ELEMENTS, FATAL,
-/* xgettext:no-c-format */
-"Too many elements as of %0 for array reference at %1")
-FFEBAD_MSG (FFEBAD_MISSING_COLON_IN_SUBSTR, FATAL,
-/* xgettext:no-c-format */
-"Missing colon as of %0 in substring reference for %1")
-FFEBAD_MSG (FFEBAD_BAD_SUBSTR, FATAL,
-/* xgettext:no-c-format */
-"Invalid use at %0 of substring operator on %1")
-FFEBAD_MSG (FFEBAD_RANGE_SUBSTR, WARN,
-/* xgettext:no-c-format */
-"Substring begin/end point at %0 out of defined range")
-FFEBAD_MSG (FFEBAD_RANGE_ARRAY, WARN,
-/* xgettext:no-c-format */
-"Array element value at %0 out of defined range")
-FFEBAD_MSG (FFEBAD_EXPR_WRONG, FATAL,
-/* xgettext:no-c-format */
-"Expression at %0 has incorrect data type or rank for its context")
-FFEBAD_MSG (FFEBAD_DIV_BY_ZERO, WARN,
-/* xgettext:no-c-format */
-"Division by 0 (zero) at %0 (IEEE not yet supported)")
-FFEBAD_MSG (FFEBAD_DO_STEP_ZERO, FATAL,
-/* xgettext:no-c-format */
-"%A step count known to be 0 (zero) at %0")
-FFEBAD_MSG (FFEBAD_DO_END_OVERFLOW, WARN,
-/* xgettext:no-c-format */
-"%A end value plus step count known to overflow at %0")
-FFEBAD_MSG (FFEBAD_DO_IMP_OVERFLOW, WARN,
-/* xgettext:no-c-format */
-"%A begin, end, and step-count values known to result in implementation-dependent behavior due to overflow(s) in intermediate calculations at %0")
-FFEBAD_MSG (FFEBAD_DO_NULL, WARN,
-/* xgettext:no-c-format */
-"%A begin, end, and step-count values known to result in no iterations at %0")
-FFEBAD_MSG (FFEBAD_BAD_TYPES, FATAL,
-/* xgettext:no-c-format */
-"Type disagreement between expressions at %0 and %1")
-FFEBAD_MSG (FFEBAD_FORMAT_EXPR_SPEC, FATAL,
-/* xgettext:no-c-format */
-LONG("Run-time expression at %0 in FORMAT statement that does not follow the first executable statement in the program unit -- move the statement")
-/* xgettext:no-c-format */
-SHORT("FORMAT at %0 with run-time expression must follow first executable statement"))
-FFEBAD_MSG (FFEBAD_BAD_IMPDO, FATAL,
-/* xgettext:no-c-format */
-LONG("Unexpected token at %0 in implied-DO construct at %1 -- form of implied-DO is `(item-list,do-var=start,end[,incr])'")
-/* xgettext:no-c-format */
-SHORT("Unexpected token at %0 in implied-DO construct at %1"))
-FFEBAD_MSG (FFEBAD_BAD_IMPDCL, FATAL,
-/* xgettext:no-c-format */
-"No specification for implied-DO iterator `%A' at %0")
-FFEBAD_MSG (FFEBAD_IMPDO_PAREN, WARN,
-/* xgettext:no-c-format */
-"Gratuitous parentheses surround implied-DO construct at %0")
-FFEBAD_MSG (FFEBAD_ZERO_SIZE, FATAL,
-/* xgettext:no-c-format */
-"Zero-size specification invalid at %0")
-FFEBAD_MSG (FFEBAD_ZERO_ARRAY, FATAL,
-/* xgettext:no-c-format */
-"Zero-size array at %0")
-FFEBAD_MSG (FFEBAD_BAD_COMPLEX, FATAL,
-/* xgettext:no-c-format */
-"Target machine does not support complex entity of kind specified at %0")
-FFEBAD_MSG (FFEBAD_BAD_DBLCMPLX, FATAL,
-/* xgettext:no-c-format */
-"Target machine does not support DOUBLE COMPLEX, specified at %0")
-FFEBAD_MSG (FFEBAD_BAD_POWER, WARN,
-/* xgettext:no-c-format */
-"Attempt to raise constant zero to a power at %0")
-FFEBAD_MSG (FFEBAD_BOOL_ARGS_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Boolean/logical operator at %0 must operate on two subexpressions of logical type, but neither subexpression at %1 or %2 is of logical type")
-/* xgettext:no-c-format */
-SHORT("Invalid operands at %1 and %2 for boolean operator at %0"))
-FFEBAD_MSG (FFEBAD_BOOL_ARG_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Boolean/logical operator at %0 must operate on two subexpressions of logical type, but the subexpression at %1 is not of logical type")
-/* xgettext:no-c-format */
-SHORT("Invalid operand at %1 for boolean operator at %0"))
-FFEBAD_MSG (FFEBAD_BOOL_ARG_KIND, FATAL,
-/* xgettext:no-c-format */
-LONG("Boolean/logical operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning logical scalars, or a combination of both -- but the subexpression at %1 is %A")
-/* xgettext:no-c-format */
-SHORT("Invalid operand (is %A) at %1 for boolean operator at %0"))
-FFEBAD_MSG (FFEBAD_NOT_ARG_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG(".NOT. operator at %0 must operate on subexpression of logical type, but the subexpression at %1 is not of logical type")
-/* xgettext:no-c-format */
-SHORT("Invalid operand at %1 for .NOT. operator at %0"))
-FFEBAD_MSG (FFEBAD_NOT_ARG_KIND, FATAL,
-/* xgettext:no-c-format */
-LONG(".NOT. operator at %0 must operate on scalar subexpressions -- but the subexpression at %1 is %A")
-/* xgettext:no-c-format */
-SHORT("Invalid operand (is %A) at %1 for .NOT. operator at %0"))
-FFEBAD_MSG (FFEBAD_EQOP_ARGS_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Equality operator at %0 must operate on two subexpressions of arithmetic or character type, but neither subexpression at %1 or %2 is of arithmetic or character type")
-/* xgettext:no-c-format */
-SHORT("Invalid operands at %1 and %2 for equality operator at %0"))
-FFEBAD_MSG (FFEBAD_EQOP_ARG_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Equality operator at %0 must operate on two subexpressions of arithmetic or character type, but the subexpression at %1 is not of arithmetic or character type")
-/* xgettext:no-c-format */
-SHORT("Invalid operand at %1 for equality operator at %0"))
-FFEBAD_MSG (FFEBAD_EQOP_ARG_KIND, FATAL,
-/* xgettext:no-c-format */
-LONG("Equality operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning arithmetic or character scalars, or a combination of both -- but the subexpression at %1 is %A")
-/* xgettext:no-c-format */
-SHORT("Invalid operand (is %A) at %1 for equality operator at %0"))
-FFEBAD_MSG (FFEBAD_RELOP_ARGS_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Relational operator at %0 must operate on two subexpressions of integer, real, or character type, but neither subexpression at %1 or %2 is of integer, real, or character type")
-/* xgettext:no-c-format */
-SHORT("Invalid operands at %1 and %2 for relational operator at %0"))
-FFEBAD_MSG (FFEBAD_RELOP_ARG_TYPE, FATAL,
-/* xgettext:no-c-format */
-LONG("Relational operator at %0 must operate on two subexpressions of integer, real, or character type, but the subexpression at %1 is not of integer, real, or character type")
-/* xgettext:no-c-format */
-SHORT("Invalid operand at %1 for relational operator at %0"))
-FFEBAD_MSG (FFEBAD_RELOP_ARG_KIND, FATAL,
-/* xgettext:no-c-format */
-LONG("Relational operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning integer, real, or character scalars, or a combination of both -- but the subexpression at %1 is %A")
-/* xgettext:no-c-format */
-SHORT("Invalid operand (is %A) at %1 for relational operator at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_REF, FATAL,
-/* xgettext:no-c-format */
-LONG("Reference to intrinsic `%A' at %0 invalid -- one or more arguments have incorrect type")
-/* xgettext:no-c-format */
-SHORT("Invalid reference to intrinsic `%A' at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_TOOFEW, FATAL,
-/* xgettext:no-c-format */
-LONG("Too few arguments passed to intrinsic `%A' at %0")
-/* xgettext:no-c-format */
-SHORT("Too few arguments for intrinsic `%A' at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_TOOMANY, FATAL,
-/* xgettext:no-c-format */
-LONG("Too many arguments passed to intrinsic `%A' at %0")
-/* xgettext:no-c-format */
-SHORT("Too many arguments for intrinsic `%A' at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_DISABLED, FATAL,
-/* xgettext:no-c-format */
-LONG("Reference to disabled intrinsic `%A' at %0")
-/* xgettext:no-c-format */
-SHORT("Disabled intrinsic `%A' at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_IS_SUBR, FATAL,
-/* xgettext:no-c-format */
-LONG("Reference to intrinsic subroutine `%A' as if it were a function at %0")
-/* xgettext:no-c-format */
-SHORT("Function reference to intrinsic subroutine `%A' at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_IS_FUNC, FATAL,
-/* xgettext:no-c-format */
-LONG("Reference to intrinsic function `%A' as if it were a subroutine at %0")
-/* xgettext:no-c-format */
-SHORT("Subroutine reference to intrinsic function `%A' at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_UNIMPL, FATAL,
-/* xgettext:no-c-format */
-LONG("Reference to unimplemented intrinsic `%A' at %0 -- use EXTERNAL to reference user-written procedure with this name")
-/* xgettext:no-c-format */
-SHORT("Unimplemented intrinsic `%A' at %0"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_UNIMPLW, WARN,
-/* xgettext:no-c-format */
-LONG("Reference to unimplemented intrinsic `%A' at %0 (assumed EXTERNAL)")
-/* xgettext:no-c-format */
-SHORT("Unimplemented intrinsic `%A' at %0 (assumed EXTERNAL)"))
-FFEBAD_MSG (FFEBAD_INTRINSIC_AMBIG, FATAL,
-/* xgettext:no-c-format */
-"Reference to generic intrinsic `%A' at %0 could be to form %B or %C")
-FFEBAD_MSG (FFEBAD_INTRINSIC_CMPAMBIG, FATAL,
-/* xgettext:no-c-format */
-"Ambiguous use of intrinsic `%A' at %0 [info -f g77 M CMPAMBIG]")
-FFEBAD_MSG (FFEBAD_INTRINSIC_EXPIMP, WARN,
-/* xgettext:no-c-format */
-"Intrinsic `%A' referenced %Bly at %0, %Cly at %1 [info -f g77 M EXPIMP]")
-FFEBAD_MSG (FFEBAD_INTRINSIC_GLOBAL, WARN,
-/* xgettext:no-c-format */
-"Same name `%A' used for %B at %0 and %C at %1 [info -f g77 M INTGLOB]")
-FFEBAD_MSG (FFEBAD_INTRINSIC_TYPE, WARN,
-/* xgettext:no-c-format */
-"Explicit type declaration for intrinsic `%A' disagrees with invocation at %0")
-FFEBAD_MSG (FFEBAD_OPEN_INCLUDE, FATAL,
-/* xgettext:no-c-format */
-"Unable to open INCLUDE file `%A' at %0")
-FFEBAD_MSG (FFEBAD_DOITER, FATAL,
-/* xgettext:no-c-format */
-LONG("Attempt to modify variable `%A' at %0 while it serves as DO-loop iterator at %1")
-/* xgettext:no-c-format */
-SHORT("Modification of DO-loop iterator `%A' at %0"))
-FFEBAD_MSG (FFEBAD_DOITER_IMPDO, FATAL,
-/* xgettext:no-c-format */
-LONG("Attempt to modify variable `%A' via item #%B in list at %0 while it serves as implied-DO iterator at %1")
-/* xgettext:no-c-format */
-SHORT("Modification of DO-loop iterator `%A' at %0"))
-FFEBAD_MSG (FFEBAD_TOO_MANY_DIMS, FATAL,
-/* xgettext:no-c-format */
-LONG("Array has too many dimensions, as of dimension specifier at %0")
-/* xgettext:no-c-format */
-SHORT("Too many dimensions at %0"))
-FFEBAD_MSG (FFEBAD_NULL_ARGUMENT, FATAL,
-/* xgettext:no-c-format */
-"Null argument at %0 for statement function reference at %1")
-FFEBAD_MSG (FFEBAD_NULL_ARGUMENT_W, WARN,
-/* xgettext:no-c-format */
-"Null argument at %0 for procedure invocation at %1")
-FFEBAD_MSG (FFEBAD_TOO_FEW_ARGUMENTS, FATAL,
-/* xgettext:no-c-format */
-"%A too few arguments (starting with dummy argument `%B') as of %0 for statement function reference at %1")
-FFEBAD_MSG (FFEBAD_TOO_MANY_ARGUMENTS, FATAL,
-/* xgettext:no-c-format */
-"%A too many arguments as of %0 for statement function reference at %1")
-FFEBAD_MSG (FFEBAD_ARRAY_AS_SFARG, FATAL,
-/* xgettext:no-c-format */
-"Array supplied at %1 for dummy argument `%A' in statement function reference at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_UNSUPPORTED, FATAL,
-/* xgettext:no-c-format */
-"Unsupported FORMAT specifier at %0")
-FFEBAD_MSG (FFEBAD_FORMAT_VARIABLE, FATAL,
-/* xgettext:no-c-format */
-"Variable-expression FORMAT specifier at %0 -- unsupported")
-FFEBAD_MSG (FFEBAD_OPEN_UNSUPPORTED, FATAL,
-/* xgettext:no-c-format */
-LONG("Unsupported OPEN control item at %0 -- ACTION=, ASSOCIATEVARIABLE=, BLOCKSIZE=, BUFFERCOUNT=, CARRIAGECONTROL=, DEFAULTFILE=, DELIM=, DISPOSE=, EXTENDSIZE=, INITIALSIZE=, KEY=, MAXREC=, NOSPANBLOCKS, ORGANIZATION=, PAD=, POSITION=, READONLY=, RECORDTYPE=, SHARED=, and USEROPEN= are not supported")
-/* xgettext:no-c-format */
-SHORT("Unsupported OPEN control item at %0"))
-FFEBAD_MSG (FFEBAD_INQUIRE_UNSUPPORTED, FATAL,
-/* xgettext:no-c-format */
-LONG("Unsupported INQUIRE control item at %0 -- ACTION=, CARRIAGECONTROL=, DEFAULTFILE=, DELIM=, KEYED=, ORGANIZATION=, PAD=, POSITION=, READ=, READWRITE=, RECORDTYPE=, and WRITE= are not supported")
-/* xgettext:no-c-format */
-SHORT("Unsupported INQUIRE control item at %0"))
-FFEBAD_MSG (FFEBAD_READ_UNSUPPORTED, FATAL,
-/* xgettext:no-c-format */
-LONG("Unsupported READ control item at %0 -- ADVANCE=, EOR=, KEYEQ=, KEYGE=, KEYGT=, KEYID=, NULLS=, and SIZE= are not supported")
-/* xgettext:no-c-format */
-SHORT("Unsupported READ control item at %0"))
-FFEBAD_MSG (FFEBAD_WRITE_UNSUPPORTED, FATAL,
-/* xgettext:no-c-format */
-LONG("Unsupported WRITE control item at %0 -- ADVANCE= and EOR= are not supported")
-/* xgettext:no-c-format */
-SHORT("Unsupported WRITE control item at %0"))
-FFEBAD_MSG (FFEBAD_VXT_UNSUPPORTED, FATAL,
-/* xgettext:no-c-format */
-"Unsupported VXT statement at %0")
-FFEBAD_MSG (FFEBAD_DATA_REINIT, FATAL,
-/* xgettext:no-c-format */
-"Attempt to specify second initial value for `%A' at %0")
-FFEBAD_MSG (FFEBAD_DATA_TOOFEW, FATAL,
-/* xgettext:no-c-format */
-"Too few initial values in list of initializers for `%A' at %0")
-FFEBAD_MSG (FFEBAD_DATA_TOOMANY, FATAL,
-/* xgettext:no-c-format */
-"Too many initial values in list of initializers starting at %0")
-FFEBAD_MSG (FFEBAD_DATA_RANGE, FATAL,
-/* xgettext:no-c-format */
-"Array or substring specification for `%A' out of range in statement at %0")
-FFEBAD_MSG (FFEBAD_DATA_SUBSCRIPT, FATAL,
-/* xgettext:no-c-format */
-"Array subscript #%B out of range for initialization of `%A' in statement at %0")
-FFEBAD_MSG (FFEBAD_DATA_ZERO, FATAL,
-/* xgettext:no-c-format */
-"Implied do-loop step count of 0 (zero) for iteration variable `%A' in statement at %0")
-FFEBAD_MSG (FFEBAD_DATA_EMPTY, FATAL,
-/* xgettext:no-c-format */
-"Implied do-loop iteration count of 0 (zero) for iteration variable `%A' in statement at %0")
-FFEBAD_MSG (FFEBAD_DATA_EVAL, FATAL,
-/* xgettext:no-c-format */
-"Not an integer constant expression in implied do-loop in statement at %0")
-FFEBAD_MSG (FFEBAD_DATA_MULTIPLE, FATAL,
-/* xgettext:no-c-format */
-"Attempt to specify second initial value for element of `%A' at %0")
-FFEBAD_MSG (FFEBAD_EQUIV_COMMON, FATAL,
-/* xgettext:no-c-format */
-"Attempt to EQUIVALENCE common areas `%A' and `%B' at %0")
-FFEBAD_MSG (FFEBAD_EQUIV_ALIGN, FATAL,
-/* xgettext:no-c-format */
-"Can't place `%A' as directed by EQUIVALENCE due to alignment restrictions")
-FFEBAD_MSG (FFEBAD_EQUIV_MISMATCH, FATAL,
-/* xgettext:no-c-format */
-"Mismatched EQUIVALENCE requirements for placement of `%A' at both %C and %D bytes offset from `%B'")
-FFEBAD_MSG (FFEBAD_EQUIV_RANGE, FATAL,
-/* xgettext:no-c-format */
-"Array or substring specification for `%A' out of range in EQUIVALENCE statement")
-FFEBAD_MSG (FFEBAD_EQUIV_SUBSTR, FATAL,
-/* xgettext:no-c-format */
-"Substring of non-CHARACTER entity `%A' in EQUIVALENCE statement")
-FFEBAD_MSG (FFEBAD_EQUIV_ARRAY, FATAL,
-/* xgettext:no-c-format */
-"Array reference to scalar variable `%A' in EQUIVALENCE statement")
-FFEBAD_MSG (FFEBAD_EQUIV_SUBSCRIPT, WARN,
-/* xgettext:no-c-format */
-"Array subscript #%B out of range for EQUIVALENCE of `%A'")
-FFEBAD_MSG (FFEBAD_COMMON_PAD, WARN,
-/* xgettext:no-c-format */
-LONG("Padding of %A %D required before `%B' in common block `%C' at %0 -- consider reordering members, largest-type-size first")
-/* xgettext:no-c-format */
-SHORT("Padding of %A %D required before `%B' in common block `%C' at %0"))
-FFEBAD_MSG (FFEBAD_COMMON_NEG, FATAL,
-/* xgettext:no-c-format */
-"Attempt to extend COMMON area beyond its starting point via EQUIVALENCE of `%A'")
-FFEBAD_MSG (FFEBAD_EQUIV_FEW, FATAL,
-/* xgettext:no-c-format */
-"Too few elements in reference to array `%A' in EQUIVALENCE statement")
-FFEBAD_MSG (FFEBAD_EQUIV_MANY, FATAL,
-/* xgettext:no-c-format */
-"Too many elements in reference to array `%A' in EQUIVALENCE statement")
-FFEBAD_MSG (FFEBAD_MIXED_TYPES, WARN,
-/* xgettext:no-c-format */
-"Mixed CHARACTER and non-CHARACTER types via COMMON/EQUIVALENCE -- for example, `%A' and `%B'")
-FFEBAD_MSG (FFEBAD_IMPLICIT_ADJLEN, FATAL,
-/* xgettext:no-c-format */
-LONG("Invalid length specification at %0 for IMPLICIT statement -- must be integer constant expression")
-/* xgettext:no-c-format */
-SHORT("Invalid length specification at %0"))
-FFEBAD_MSG (FFEBAD_ENTRY_CONFLICTS, FATAL,
-/* xgettext:no-c-format */
-LONG("Type of ENTRY point at %0 to function conflicts with type(s) of previous entrypoint(s) -- must all be identical-length CHARACTER or none be CHARACTER type")
-/* xgettext:no-c-format */
-SHORT("Type of ENTRY point at %0 to function conflicts with type(s) of previous entrypoint(s)"))
-FFEBAD_MSG (FFEBAD_RETURN_VALUE_UNSET, WARN,
-/* xgettext:no-c-format */
-"Return value `%A' for FUNCTION at %0 not referenced in subprogram")
-FFEBAD_MSG (FFEBAD_COMMON_ALREADY_INIT, FATAL,
-/* xgettext:no-c-format */
-LONG("Common block `%A' initialized at %0 already initialized at %1 -- only one program unit may specify initial values for a particular common block")
-/* xgettext:no-c-format */
-SHORT("Common block `%A' initialized at %0 already initialized at %1"))
-FFEBAD_MSG (FFEBAD_COMMON_INIT_PAD, WARN,
-/* xgettext:no-c-format */
-LONG("Initial padding for common block `%A' is %B %C at %0 -- consider reordering members, largest-type-size first")
-/* xgettext:no-c-format */
-SHORT("Initial padding for common block `%A' is %B %C at %0"))
-FFEBAD_MSG (FFEBAD_COMMON_DIFF_PAD, FATAL,
-/* xgettext:no-c-format */
-LONG("Initial padding for common block `%A' is %B %D at %0 but %C %E at %1 -- consider reordering members, largest-type-size first")
-/* xgettext:no-c-format */
-SHORT("Initial padding for common block `%A' is %B %D at %0 but %C %E at %1"))
-FFEBAD_MSG (FFEBAD_COMMON_DIFF_SAVE, WARN,
-/* xgettext:no-c-format */
-"Common block `%A' is SAVEd, explicitly or implicitly, at %0 but not SAVEd at %1")
-FFEBAD_MSG (FFEBAD_COMMON_DIFF_SIZE, WARN,
-/* xgettext:no-c-format */
-"Common block `%A' is %B %D in length at %0 but %C %E at %1")
-FFEBAD_MSG (FFEBAD_COMMON_ENLARGED, FATAL,
-/* xgettext:no-c-format */
-LONG("Common block `%A' is initialized to %B %D long at %0 but enlarged to %C %E at %1 -- use consistent definitions or reorder program units in source file")
-/* xgettext:no-c-format */
-SHORT("Common block `%A' is initialized to %B %D long at %0 but enlarged to %C %E at %1"))
-FFEBAD_MSG (FFEBAD_COMMON_BLANK_INIT, WARN,
-/* xgettext:no-c-format */
-"Blank common initialized at %0")
-FFEBAD_MSG (FFEBAD_NEED_INTRINSIC, WARN,
-/* xgettext:no-c-format */
-"Intrinsic `%A' is passed as actual argument at %0 but not explicitly declared INTRINSIC")
-FFEBAD_MSG (FFEBAD_NEED_EXTERNAL, WARN,
-/* xgettext:no-c-format */
-"External procedure `%A' is passed as actual argument at %0 but not explicitly declared EXTERNAL")
-FFEBAD_MSG (FFEBAD_SYMBOL_UPPER_CASE, WARN,
-/* xgettext:no-c-format */
-"Character `%A' (for example) is upper-case in symbol name at %0")
-FFEBAD_MSG (FFEBAD_SYMBOL_LOWER_CASE, WARN,
-/* xgettext:no-c-format */
-"Character `%A' (for example) is lower-case in symbol name at %0")
-FFEBAD_MSG (FFEBAD_SYMBOL_NOLOWER_INITCAP, WARN,
-/* xgettext:no-c-format */
-"Character `%A' not followed at some point by lower-case character in symbol name at %0")
-FFEBAD_MSG (FFEBAD_SYMBOL_LOWER_INITCAP, WARN,
-/* xgettext:no-c-format */
-"Initial character `%A' is lower-case in symbol name at %0")
-FFEBAD_MSG (FFEBAD_DO_REAL, WARN,
-/* xgettext:no-c-format */
-LONG("DO-variable `%A' is type REAL or DOUBLE PRECISION at %0 -- unexpected behavior likely")
-/* xgettext:no-c-format */
-SHORT("DO-variable `%A' is type REAL or DOUBLE PRECISION at %0"))
-FFEBAD_MSG (FFEBAD_NAMELIST_CASE, WARN,
-/* xgettext:no-c-format */
-"NAMELIST not adequately supported by run-time library for source files with case preserved")
-FFEBAD_MSG (FFEBAD_NESTED_PERCENT, WARN,
-/* xgettext:no-c-format */
-"Nested %% construct (%%VAL, %%REF, or %%DESCR) at %0")
-FFEBAD_MSG (FFEBAD_ACTUALARG, WARN,
-/* xgettext:no-c-format */
-LONG("Invalid actual argument at %0 -- replace hollerith constants with %%REF('string') and typeless constants with INTEGER constant equivalents, or use -fugly-args or -fugly")
-/* xgettext:no-c-format */
-SHORT("Invalid actual argument at %0"))
-FFEBAD_MSG (FFEBAD_QUAD_UNSUPPORTED, FATAL,
-/* xgettext:no-c-format */
-LONG("Quadruple-precision floating-point unsupported -- treating constant at %0 as double-precision")
-/* xgettext:no-c-format */
-SHORT("Quadruple-precision floating-point unsupported"))
-FFEBAD_MSG (FFEBAD_TOO_BIG_INIT, WARN,
-/* xgettext:no-c-format */
-LONG("Initialization of large (%B-unit) aggregate area `%A' at %0 slow and takes lots of memory during g77 compile")
-/* xgettext:no-c-format */
-SHORT("This could take a while (initializing `%A' at %0)..."))
-FFEBAD_MSG (FFEBAD_BLOCKDATA_STMT, FATAL,
-/* xgettext:no-c-format */
-"Statement at %0 invalid in BLOCK DATA program unit at %1")
-FFEBAD_MSG (FFEBAD_TRUNCATING_CHARACTER, FATAL,
-/* xgettext:no-c-format */
-"Truncating characters on right side of character constant at %0")
-FFEBAD_MSG (FFEBAD_TRUNCATING_HOLLERITH, FATAL,
-/* xgettext:no-c-format */
-"Truncating characters on right side of hollerith constant at %0")
-FFEBAD_MSG (FFEBAD_TRUNCATING_NUMERIC, FATAL,
-/* xgettext:no-c-format */
-"Truncating non-zero data on left side of numeric constant at %0")
-FFEBAD_MSG (FFEBAD_TRUNCATING_TYPELESS, FATAL,
-/* xgettext:no-c-format */
-"Truncating non-zero data on left side of typeless constant at %0")
-FFEBAD_MSG (FFEBAD_TYPELESS_OVERFLOW, FATAL,
-/* xgettext:no-c-format */
-"Typeless constant at %0 too large")
-FFEBAD_MSG (FFEBAD_AMPERSAND, WARN,
-/* xgettext:no-c-format */
-"First-column ampersand continuation at %0")
-FFEBAD_MSG (FFEBAD_FILEWIDE_ALREADY_SEEN, FATAL,
-/* xgettext:no-c-format */
-"Global name `%A' defined at %0 already defined at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_ALREADY_SEEN_W, WARN,
-/* xgettext:no-c-format */
-"Global name `%A' defined at %0 already defined at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_DISAGREEMENT, FATAL,
-/* xgettext:no-c-format */
-"Global name `%A' is %B at %0 but is %C at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_DISAGREEMENT_W, WARN,
-/* xgettext:no-c-format */
-"Global name `%A' is %B at %0 but is %C at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_TYPE_MISMATCH, FATAL,
-/* xgettext:no-c-format */
-"Global name `%A' at %0 has different type at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_TYPE_MISMATCH_W, WARN,
-/* xgettext:no-c-format */
-"Global name `%A' at %0 has different type at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_NARGS, FATAL,
-/* xgettext:no-c-format */
-"Too %B arguments passed to `%A' at %0 versus definition at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_NARGS_W, WARN,
-/* xgettext:no-c-format */
-"Too %B arguments for `%A' at %0 versus invocation at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_ARG, FATAL,
-/* xgettext:no-c-format */
-"Argument #%B of `%A' is %C at %0 but is %D at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_FILEWIDE_ARG_W, WARN,
-/* xgettext:no-c-format */
-"Argument #%B of `%A' is %C at %0 but is %D at %1 [info -f g77 M GLOBALS]")
-FFEBAD_MSG (FFEBAD_ARRAY_LARGE, FATAL,
-/* xgettext:no-c-format */
-"Array `%A' at %0 is too large to handle")
-FFEBAD_MSG (FFEBAD_SFUNC_UNUSED, WARN,
-/* xgettext:no-c-format */
-"Statement function `%A' defined at %0 is not used")
-FFEBAD_MSG (FFEBAD_INTRINSIC_Y2KBAD, WARN,
-/* xgettext:no-c-format */
-"Intrinsic `%A', invoked at %0, known to be non-Y2K-compliant [info -f g77 M Y2KBAD]")
-FFEBAD_MSG (FFEBAD_NOCANDO, DISASTER,
-/* xgettext:no-c-format */
-"Internal compiler error -- cannot perform operation")
-
-#undef INFORM
-#undef TRIVIAL
-#undef WARN
-#undef PECULIAR
-#undef FATAL
-#undef WEIRD
-#undef SEVERE
-#undef DISASTER
+++ /dev/null
-/* bad.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 2002 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- bad.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_BAD_H
-#define GCC_F_BAD_H
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
-#define FFEBAD_MSG(KWD,SEV,MSG) KWD,
-#include "bad.def"
-#undef FFEBAD_MSG
- FFEBAD
- } ffebad;
-
-typedef enum
- {
-
- /* Order important; must be increasing severity. */
-
- FFEBAD_severityINFORMATIONAL, /* User notice. */
- FFEBAD_severityTRIVIAL, /* Internal notice. */
- FFEBAD_severityWARNING, /* User warning. */
- FFEBAD_severityPECULIAR, /* Internal warning. */
- FFEBAD_severityPEDANTIC, /* Pedantic, could be warning or error. */
- FFEBAD_severityFATAL, /* User error. */
- FFEBAD_severityWEIRD, /* Internal error. */
- FFEBAD_severitySEVERE, /* User error, cannot continue. */
- FFEBAD_severityDISASTER, /* Internal error, cannot continue. */
- FFEBAD_severity
- } ffebadSeverity;
-
-/* Typedefs. */
-
-typedef unsigned char ffebadIndex;
-
-/* Include files needed by this one. */
-
-#include "where.h"
-
-/* Structure definitions. */
-
-
-/* Global objects accessed by users of this module. */
-
-extern bool ffebad_is_inhibited_;
-
-/* Declare functions with prototypes. */
-
-void ffebad_finish (void);
-void ffebad_here (ffebadIndex i, ffewhereLine wl, ffewhereColumn wc);
-void ffebad_init_0 (void);
-bool ffebad_is_fatal (ffebad errnum);
-ffebadSeverity ffebad_severity (ffebad errnum);
-bool ffebad_start_ (bool lex_override, ffebad errnum, ffebadSeverity sev,
- const char *msgid);
-void ffebad_string (const char *string);
-
-/* Define macros. */
-
-#define ffebad_inhibit() (ffebad_is_inhibited_)
-#define ffebad_init_1()
-#define ffebad_init_2()
-#define ffebad_init_3()
-#define ffebad_init_4()
-#define ffebad_set_inhibit(f) (ffebad_is_inhibited_ = (f))
-#define ffebad_start(e) ffebad_start_ (FALSE, (e), FFEBAD_severity, NULL)
-#define ffebad_start_lex(e) ffebad_start_ (TRUE, (e), FFEBAD_severity, NULL)
-#define ffebad_start_msg(msgid,s) ffebad_start_ (FALSE, FFEBAD, (s), (msgid))
-#define ffebad_start_msg_lex(msgid,s) ffebad_start_ (TRUE, FFEBAD, (s), (msgid))
-#define ffebad_terminate_0()
-#define ffebad_terminate_1()
-#define ffebad_terminate_2()
-#define ffebad_terminate_3()
-#define ffebad_terminate_4()
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_BAD_H */
+++ /dev/null
-/* bit.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None
-
- Description:
- Tracks arrays of booleans in useful ways.
-
- Modifications:
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "bit.h"
-#include "malloc.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-
-/* Static objects accessed by functions in this module. */
-
-
-/* Static functions (internal). */
-
-
-/* Internal macros. */
-\f
-
-/* ffebit_count -- Count # of bits set a particular way
-
- ffebit b; // the ffebit object
- ffebitCount offset; // 0..size-1
- bool value; // FALSE (0), TRUE (1)
- ffebitCount range; // # bits to test
- ffebitCount number; // # bits equal to value
- ffebit_count(b,offset,value,range,&number);
-
- Sets <number> to # bits at <offset> through <offset + range - 1> set to
- <value>. If <range> is 0, <number> is set to 0. */
-
-void
-ffebit_count (ffebit b, ffebitCount offset, bool value, ffebitCount range,
- ffebitCount *number)
-{
- ffebitCount element;
- ffebitCount bitno;
-
- assert (offset + range <= b->size);
-
- for (*number = 0; range != 0; --range, ++offset)
- {
- element = offset / CHAR_BIT;
- bitno = offset % CHAR_BIT;
- if (value
- == ((b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE))
- ++ * number;
- }
-}
-
-/* ffebit_new -- Create a new ffebit object
-
- ffebit b;
- ffebit_kill(b);
-
- Destroys an ffebit object obtained via ffebit_new. */
-
-void
-ffebit_kill (ffebit b)
-{
- malloc_kill_ks (b->pool, b,
- offsetof (struct _ffebit_, bits)
- + (b->size + CHAR_BIT - 1) / CHAR_BIT);
-}
-
-/* ffebit_new -- Create a new ffebit object
-
- ffebit b;
- mallocPool pool;
- ffebitCount size;
- b = ffebit_new(pool,size);
-
- Allocates an ffebit object that holds the values of <size> bits in pool
- <pool>. */
-
-ffebit
-ffebit_new (mallocPool pool, ffebitCount size)
-{
- ffebit b;
-
- b = malloc_new_zks (pool, "ffebit",
- offsetof (struct _ffebit_, bits)
- + (size + CHAR_BIT - 1) / CHAR_BIT,
- 0);
- b->pool = pool;
- b->size = size;
-
- return b;
-}
-
-/* ffebit_set -- Set value of # of bits
-
- ffebit b; // the ffebit object
- ffebitCount offset; // 0..size-1
- bool value; // FALSE (0), TRUE (1)
- ffebitCount length; // # bits to set starting at offset (usually 1)
- ffebit_set(b,offset,value,length);
-
- Sets bit #s <offset> through <offset + length - 1> to <value>. */
-
-void
-ffebit_set (ffebit b, ffebitCount offset, bool value, ffebitCount length)
-{
- ffebitCount i;
- ffebitCount element;
- ffebitCount bitno;
-
- assert (offset + length <= b->size);
-
- for (i = 0; i < length; ++i, ++offset)
- {
- element = offset / CHAR_BIT;
- bitno = offset % CHAR_BIT;
- b->bits[element] = (((unsigned char) (value ? 1 : 0)) << bitno)
- | (b->bits[element] & ~((unsigned char) 1 << bitno));
- }
-}
-
-/* ffebit_test -- Test value of # of bits
-
- ffebit b; // the ffebit object
- ffebitCount offset; // 0..size-1
- bool value; // FALSE (0), TRUE (1)
- ffebitCount length; // # bits with same value
- ffebit_test(b,offset,&value,&length);
-
- Returns value of bits at <offset> through <offset + length - 1> in
- <value>. If <offset> is already at the end of the bit array (if
- offset == ffebit_size(b)), <length> is set to 0 and <value> is
- undefined. */
-
-void
-ffebit_test (ffebit b, ffebitCount offset, bool *value, ffebitCount *length)
-{
- ffebitCount i;
- ffebitCount element;
- ffebitCount bitno;
-
- if (offset >= b->size)
- {
- assert (offset == b->size);
- *length = 0;
- return;
- }
-
- element = offset / CHAR_BIT;
- bitno = offset % CHAR_BIT;
- *value = (b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE;
- *length = 1;
-
- for (i = b->size - offset - 1, ++offset; i != 0; --i, ++offset, ++*length)
- {
- element = offset / CHAR_BIT;
- bitno = offset % CHAR_BIT;
- if (*value
- != ((b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE))
- break;
- }
-}
+++ /dev/null
-/* bit.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- bit.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_BIT_H
-#define GCC_F_BIT_H
-
-/* Simple definitions and enumerations. */
-
-
-/* Typedefs. */
-
-typedef struct _ffebit_ *ffebit;
-typedef unsigned long ffebitCount;
-#define ffebitCount_f "l"
-
-/* Include files needed by this one. */
-
-#include "malloc.h"
-
-/* Structure definitions. */
-
-struct _ffebit_
- {
- mallocPool pool;
- ffebitCount size;
- unsigned char bits[1];
- };
-
-/* Global objects accessed by users of this module. */
-
-
-/* Declare functions with prototypes. */
-
-void ffebit_count (ffebit b, ffebitCount offset, bool value, ffebitCount range,
- ffebitCount *number);
-void ffebit_kill (ffebit b);
-ffebit ffebit_new (mallocPool pool, ffebitCount size);
-void ffebit_set (ffebit b, ffebitCount offset, bool value, ffebitCount length);
-void ffebit_test (ffebit b, ffebitCount offset, bool *value, ffebitCount *length);
-
-/* Define macros. */
-
-#define ffebit_init_0()
-#define ffebit_init_1()
-#define ffebit_init_2()
-#define ffebit_init_3()
-#define ffebit_init_4()
-#define ffebit_pool(b) ((b)->pool)
-#define ffebit_size(b) ((b)->size)
-#define ffebit_terminate_0()
-#define ffebit_terminate_1()
-#define ffebit_terminate_2()
-#define ffebit_terminate_3()
-#define ffebit_terminate_4()
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_BIT_H */
+++ /dev/null
-/* bld-op.def -- Public #include File (module.h template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- bad.c
-
- Modifications:
-*/
-
-FFEBLD_OP (FFEBLD_opANY, "ANY", 0)
-FFEBLD_OP (FFEBLD_opSTAR, "STAR", 0) /* For adjustable arrays, alternate return dummies, etc. */
-FFEBLD_OP (FFEBLD_opCONTER, "CONTER", 0)
-FFEBLD_OP (FFEBLD_opARRTER, "ARRTER", 0) /* Array of constants (DATA...). */
-FFEBLD_OP (FFEBLD_opACCTER, "ACCTER", 0) /* Accreting ARRTER. */
-FFEBLD_OP (FFEBLD_opSYMTER, "SYMTER", 0)
-FFEBLD_OP (FFEBLD_opITEM, "ITEM", 0)
-FFEBLD_OP (FFEBLD_opUPLUS, "UPLUS", 1)
-FFEBLD_OP (FFEBLD_opUMINUS, "UMINUS", 1)
-FFEBLD_OP (FFEBLD_opADD, "ADD", 2)
-FFEBLD_OP (FFEBLD_opSUBTRACT, "SUBTRACT", 2)
-FFEBLD_OP (FFEBLD_opMULTIPLY, "MULTIPLY", 2)
-FFEBLD_OP (FFEBLD_opDIVIDE, "DIVIDE", 2)
-FFEBLD_OP (FFEBLD_opPOWER, "POWER", 2)
-FFEBLD_OP (FFEBLD_opCONCATENATE, "CONCATENATE", 2)
-FFEBLD_OP (FFEBLD_opNOT, "NOT", 1)
-FFEBLD_OP (FFEBLD_opLT, "LT", 2)
-FFEBLD_OP (FFEBLD_opLE, "LE", 2)
-FFEBLD_OP (FFEBLD_opEQ, "EQ", 2)
-FFEBLD_OP (FFEBLD_opNE, "NE", 2)
-FFEBLD_OP (FFEBLD_opGT, "GT", 2)
-FFEBLD_OP (FFEBLD_opGE, "GE", 2)
-FFEBLD_OP (FFEBLD_opAND, "AND", 2)
-FFEBLD_OP (FFEBLD_opOR, "OR", 2)
-FFEBLD_OP (FFEBLD_opXOR, "XOR", 2)
-FFEBLD_OP (FFEBLD_opEQV, "EQV", 2)
-FFEBLD_OP (FFEBLD_opNEQV, "NEQV", 2)
-FFEBLD_OP (FFEBLD_opPAREN, "PAREN", 1)
-FFEBLD_OP (FFEBLD_opPERCENT_LOC, "%LOC", 1)
-FFEBLD_OP (FFEBLD_opPERCENT_VAL, "%VAL", 1)
-FFEBLD_OP (FFEBLD_opPERCENT_REF, "%REF", 1)
-FFEBLD_OP (FFEBLD_opPERCENT_DESCR, "%DESCR", 1)
-FFEBLD_OP (FFEBLD_opCONVERT, "CONVERT", 1)
-FFEBLD_OP (FFEBLD_opREPEAT, "REPEAT", 2)
-FFEBLD_OP (FFEBLD_opBOUNDS, "BOUNDS", 2) /* For low:high in dimension lists. */
-FFEBLD_OP (FFEBLD_opFUNCREF, "FUNCREF", 2)
-FFEBLD_OP (FFEBLD_opSUBRREF, "SUBRREF", 2)
-FFEBLD_OP (FFEBLD_opARRAYREF, "ARRAYREF", 2)
-FFEBLD_OP (FFEBLD_opSUBSTR, "SUBSTR", 2)
-FFEBLD_OP (FFEBLD_opLABTER, "LABTER", 0)
-FFEBLD_OP (FFEBLD_opLABTOK, "LABTOK", 0) /* Like LABTER but contains ffelexToken instead. */
-FFEBLD_OP (FFEBLD_opIMPDO, "IMPDO", 2)
+++ /dev/null
-/* bld.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 2003, 2004 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None
-
- Description:
- The primary "output" of the FFE includes ffebld objects, which
- connect expressions, operators, and operands together, along with
- connecting lists of expressions together for argument or dimension
- lists.
-
- Modifications:
- 30-Aug-92 JCB 1.1
- Change names of some things for consistency.
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "bld.h"
-#include "bit.h"
-#include "info.h"
-#include "lex.h"
-#include "malloc.h"
-#include "target.h"
-#include "where.h"
-#include "real.h"
-
-/* Externals defined here. */
-
-const ffebldArity ffebld_arity_op_[(int) FFEBLD_op]
-=
-{
-#define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
-#include "bld-op.def"
-#undef FFEBLD_OP
-};
-struct _ffebld_pool_stack_ ffebld_pool_stack_;
-
-/* Simple definitions and enumerations. */
-
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-
-/* Static objects accessed by functions in this module. */
-
-#if FFETARGET_okCHARACTER1
-static ffebldConstant ffebld_constant_character1_;
-#endif
-#if FFETARGET_okCOMPLEX1
-static ffebldConstant ffebld_constant_complex1_;
-#endif
-#if FFETARGET_okCOMPLEX2
-static ffebldConstant ffebld_constant_complex2_;
-#endif
-#if FFETARGET_okCOMPLEX3
-static ffebldConstant ffebld_constant_complex3_;
-#endif
-#if FFETARGET_okINTEGER1
-static ffebldConstant ffebld_constant_integer1_;
-#endif
-#if FFETARGET_okINTEGER2
-static ffebldConstant ffebld_constant_integer2_;
-#endif
-#if FFETARGET_okINTEGER3
-static ffebldConstant ffebld_constant_integer3_;
-#endif
-#if FFETARGET_okINTEGER4
-static ffebldConstant ffebld_constant_integer4_;
-#endif
-#if FFETARGET_okLOGICAL1
-static ffebldConstant ffebld_constant_logical1_;
-#endif
-#if FFETARGET_okLOGICAL2
-static ffebldConstant ffebld_constant_logical2_;
-#endif
-#if FFETARGET_okLOGICAL3
-static ffebldConstant ffebld_constant_logical3_;
-#endif
-#if FFETARGET_okLOGICAL4
-static ffebldConstant ffebld_constant_logical4_;
-#endif
-#if FFETARGET_okREAL1
-static ffebldConstant ffebld_constant_real1_;
-#endif
-#if FFETARGET_okREAL2
-static ffebldConstant ffebld_constant_real2_;
-#endif
-#if FFETARGET_okREAL3
-static ffebldConstant ffebld_constant_real3_;
-#endif
-static ffebldConstant ffebld_constant_hollerith_;
-static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
- - FFEBLD_constTYPELESS_FIRST + 1];
-
-static const char *const ffebld_op_string_[]
-=
-{
-#define FFEBLD_OP(KWD,NAME,ARITY) NAME,
-#include "bld-op.def"
-#undef FFEBLD_OP
-};
-
-/* Static functions (internal). */
-
-
-/* Internal macros. */
-
-#define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
-#define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
-#define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
-#define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
-#define realquad_ CATX(real,FFETARGET_ktREALQUAD)
-\f
-/* ffebld_constant_cmp -- Compare two constants a la strcmp
-
- ffebldConstant c1, c2;
- if (ffebld_constant_cmp(c1,c2) == 0)
- // they're equal, else they're not.
-
- Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2. */
-
-int
-ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
-{
- if (c1 == c2)
- return 0;
-
- assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));
-
- switch (ffebld_constant_type (c1))
- {
-#if FFETARGET_okINTEGER1
- case FFEBLD_constINTEGER1:
- return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
- ffebld_constant_integer1 (c2));
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEBLD_constINTEGER2:
- return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
- ffebld_constant_integer2 (c2));
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEBLD_constINTEGER3:
- return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
- ffebld_constant_integer3 (c2));
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEBLD_constINTEGER4:
- return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
- ffebld_constant_integer4 (c2));
-#endif
-
-#if FFETARGET_okLOGICAL1
- case FFEBLD_constLOGICAL1:
- return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
- ffebld_constant_logical1 (c2));
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEBLD_constLOGICAL2:
- return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
- ffebld_constant_logical2 (c2));
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEBLD_constLOGICAL3:
- return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
- ffebld_constant_logical3 (c2));
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEBLD_constLOGICAL4:
- return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
- ffebld_constant_logical4 (c2));
-#endif
-
-#if FFETARGET_okREAL1
- case FFEBLD_constREAL1:
- return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
- ffebld_constant_real1 (c2));
-#endif
-
-#if FFETARGET_okREAL2
- case FFEBLD_constREAL2:
- return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
- ffebld_constant_real2 (c2));
-#endif
-
-#if FFETARGET_okREAL3
- case FFEBLD_constREAL3:
- return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
- ffebld_constant_real3 (c2));
-#endif
-
-#if FFETARGET_okCHARACTER1
- case FFEBLD_constCHARACTER1:
- return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
- ffebld_constant_character1 (c2));
-#endif
-
- default:
- assert ("bad constant type" == NULL);
- return 0;
- }
-}
-
-/* ffebld_constant_is_magical -- Determine if integer is "magical"
-
- ffebldConstant c;
- if (ffebld_constant_is_magical(c))
- // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
- // (this test is important for 2's-complement machines only). */
-
-bool
-ffebld_constant_is_magical (ffebldConstant c)
-{
- switch (ffebld_constant_type (c))
- {
- case FFEBLD_constINTEGERDEFAULT:
- return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
-
- default:
- return FALSE;
- }
-}
-
-/* Determine if constant is zero. Used to ensure step count
- for DO loops isn't zero, also to determine if values will
- be binary zeros, so not entirely portable at this point. */
-
-bool
-ffebld_constant_is_zero (ffebldConstant c)
-{
- switch (ffebld_constant_type (c))
- {
-#if FFETARGET_okINTEGER1
- case FFEBLD_constINTEGER1:
- return ffebld_constant_integer1 (c) == 0;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEBLD_constINTEGER2:
- return ffebld_constant_integer2 (c) == 0;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEBLD_constINTEGER3:
- return ffebld_constant_integer3 (c) == 0;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEBLD_constINTEGER4:
- return ffebld_constant_integer4 (c) == 0;
-#endif
-
-#if FFETARGET_okLOGICAL1
- case FFEBLD_constLOGICAL1:
- return ffebld_constant_logical1 (c) == 0;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEBLD_constLOGICAL2:
- return ffebld_constant_logical2 (c) == 0;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEBLD_constLOGICAL3:
- return ffebld_constant_logical3 (c) == 0;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEBLD_constLOGICAL4:
- return ffebld_constant_logical4 (c) == 0;
-#endif
-
-#if FFETARGET_okREAL1
- case FFEBLD_constREAL1:
- return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
-#endif
-
-#if FFETARGET_okREAL2
- case FFEBLD_constREAL2:
- return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
-#endif
-
-#if FFETARGET_okREAL3
- case FFEBLD_constREAL3:
- return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
-#endif
-
-#if FFETARGET_okCOMPLEX1
- case FFEBLD_constCOMPLEX1:
- return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real)
- && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary);
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEBLD_constCOMPLEX2:
- return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real)
- && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary);
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEBLD_constCOMPLEX3:
- return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real)
- && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary);
-#endif
-
-#if FFETARGET_okCHARACTER1
- case FFEBLD_constCHARACTER1:
- return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
-#endif
-
- case FFEBLD_constHOLLERITH:
- return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
-
- case FFEBLD_constBINARY_MIL:
- case FFEBLD_constBINARY_VXT:
- case FFEBLD_constOCTAL_MIL:
- case FFEBLD_constOCTAL_VXT:
- case FFEBLD_constHEX_X_MIL:
- case FFEBLD_constHEX_X_VXT:
- case FFEBLD_constHEX_Z_MIL:
- case FFEBLD_constHEX_Z_VXT:
- return ffetarget_iszero_typeless (ffebld_constant_typeless (c));
-
- default:
- return FALSE;
- }
-}
-
-/* ffebld_constant_new_character1 -- Return character1 constant object from token
-
- See prototype. */
-
-#if FFETARGET_okCHARACTER1
-ffebldConstant
-ffebld_constant_new_character1 (ffelexToken t)
-{
- ffetargetCharacter1 val;
-
- ffetarget_character1 (&val, t, ffebld_constant_pool());
- return ffebld_constant_new_character1_val (val);
-}
-
-#endif
-/* ffebld_constant_new_character1_val -- Return an character1 constant object
-
- See prototype. */
-
-#if FFETARGET_okCHARACTER1
-ffebldConstant
-ffebld_constant_new_character1_val (ffetargetCharacter1 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_character1_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constCHARACTER1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constCHARACTER1;
- nc->u.character1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_character1_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_character1 (val, ffebld_constant_character1 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constCHARACTER1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constCHARACTER1;
- nc->u.character1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_complex1 -- Return complex1 constant object from token
-
- See prototype. */
-
-#if FFETARGET_okCOMPLEX1
-ffebldConstant
-ffebld_constant_new_complex1 (ffebldConstant real,
- ffebldConstant imaginary)
-{
- ffetargetComplex1 val;
-
- val.real = ffebld_constant_real1 (real);
- val.imaginary = ffebld_constant_real1 (imaginary);
- return ffebld_constant_new_complex1_val (val);
-}
-
-#endif
-/* ffebld_constant_new_complex1_val -- Return a complex1 constant object
-
- See prototype. */
-
-#if FFETARGET_okCOMPLEX1
-ffebldConstant
-ffebld_constant_new_complex1_val (ffetargetComplex1 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_complex1_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constCOMPLEX1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constCOMPLEX1;
- nc->u.complex1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_complex1_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_real1 (val.real,
- ffebld_constant_complex1 (P).real);
- if (cmp == 0)
- cmp = ffetarget_cmp_real1 (val.imaginary,
- ffebld_constant_complex1 (P).imaginary);
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constCOMPLEX1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constCOMPLEX1;
- nc->u.complex1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_complex2 -- Return complex2 constant object from token
-
- See prototype. */
-
-#if FFETARGET_okCOMPLEX2
-ffebldConstant
-ffebld_constant_new_complex2 (ffebldConstant real,
- ffebldConstant imaginary)
-{
- ffetargetComplex2 val;
-
- val.real = ffebld_constant_real2 (real);
- val.imaginary = ffebld_constant_real2 (imaginary);
- return ffebld_constant_new_complex2_val (val);
-}
-
-#endif
-/* ffebld_constant_new_complex2_val -- Return a complex2 constant object
-
- See prototype. */
-
-#if FFETARGET_okCOMPLEX2
-ffebldConstant
-ffebld_constant_new_complex2_val (ffetargetComplex2 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_complex2_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constCOMPLEX2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constCOMPLEX2;
- nc->u.complex2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_complex2_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_real2 (val.real,
- ffebld_constant_complex2 (P).real);
- if (cmp == 0)
- cmp = ffetarget_cmp_real2 (val.imaginary,
- ffebld_constant_complex2 (P).imaginary);
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constCOMPLEX2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constCOMPLEX2;
- nc->u.complex2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_hollerith -- Return hollerith constant object from token
-
- See prototype. */
-
-ffebldConstant
-ffebld_constant_new_hollerith (ffelexToken t)
-{
- ffetargetHollerith val;
-
- ffetarget_hollerith (&val, t, ffebld_constant_pool());
- return ffebld_constant_new_hollerith_val (val);
-}
-
-/* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
-
- See prototype. */
-
-ffebldConstant
-ffebld_constant_new_hollerith_val (ffetargetHollerith val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_hollerith_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constHOLLERITH",
- sizeof (*nc));
- nc->consttype = FFEBLD_constHOLLERITH;
- nc->u.hollerith = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_hollerith_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constHOLLERITH",
- sizeof (*nc));
- nc->consttype = FFEBLD_constHOLLERITH;
- nc->u.hollerith = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-/* ffebld_constant_new_integer1 -- Return integer1 constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-#if FFETARGET_okINTEGER1
-ffebldConstant
-ffebld_constant_new_integer1 (ffelexToken t)
-{
- ffetargetInteger1 val;
-
- assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
-
- ffetarget_integer1 (&val, t);
- return ffebld_constant_new_integer1_val (val);
-}
-
-#endif
-/* ffebld_constant_new_integer1_val -- Return an integer1 constant object
-
- See prototype. */
-
-#if FFETARGET_okINTEGER1
-ffebldConstant
-ffebld_constant_new_integer1_val (ffetargetInteger1 val)
-{
-
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_integer1_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER1;
- nc->u.integer1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_integer1_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER1;
- nc->u.integer1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_integer2_val -- Return an integer2 constant object
-
- See prototype. */
-
-#if FFETARGET_okINTEGER2
-ffebldConstant
-ffebld_constant_new_integer2_val (ffetargetInteger2 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_integer2_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER2;
- nc->u.integer2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_integer2_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER2;
- nc->u.integer2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_integer3_val -- Return an integer3 constant object
-
- See prototype. */
-
-#if FFETARGET_okINTEGER3
-ffebldConstant
-ffebld_constant_new_integer3_val (ffetargetInteger3 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_integer3_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER3",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER3;
- nc->u.integer3 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_integer3_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER3",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER3;
- nc->u.integer3 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_integer4_val -- Return an integer4 constant object
-
- See prototype. */
-
-#if FFETARGET_okINTEGER4
-ffebldConstant
-ffebld_constant_new_integer4_val (ffetargetInteger4 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_integer4_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER4",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER4;
- nc->u.integer4 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_integer4_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constINTEGER4",
- sizeof (*nc));
- nc->consttype = FFEBLD_constINTEGER4;
- nc->u.integer4 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_integerbinary -- Return binary constant object from token
-
- See prototype.
-
- Parses the token as a binary integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_integerbinary (ffelexToken t)
-{
- ffetargetIntegerDefault val;
-
- assert ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNUMBER));
-
- ffetarget_integerbinary (&val, t);
- return ffebld_constant_new_integerdefault_val (val);
-}
-
-/* ffebld_constant_new_integerhex -- Return hex constant object from token
-
- See prototype.
-
- Parses the token as a hex integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_integerhex (ffelexToken t)
-{
- ffetargetIntegerDefault val;
-
- assert ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNUMBER));
-
- ffetarget_integerhex (&val, t);
- return ffebld_constant_new_integerdefault_val (val);
-}
-
-/* ffebld_constant_new_integeroctal -- Return octal constant object from token
-
- See prototype.
-
- Parses the token as a octal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_integeroctal (ffelexToken t)
-{
- ffetargetIntegerDefault val;
-
- assert ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNUMBER));
-
- ffetarget_integeroctal (&val, t);
- return ffebld_constant_new_integerdefault_val (val);
-}
-
-/* ffebld_constant_new_logical1 -- Return logical1 constant object from token
-
- See prototype.
-
- Parses the token as a decimal logical constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-#if FFETARGET_okLOGICAL1
-ffebldConstant
-ffebld_constant_new_logical1 (bool truth)
-{
- ffetargetLogical1 val;
-
- ffetarget_logical1 (&val, truth);
- return ffebld_constant_new_logical1_val (val);
-}
-
-#endif
-/* ffebld_constant_new_logical1_val -- Return a logical1 constant object
-
- See prototype. */
-
-#if FFETARGET_okLOGICAL1
-ffebldConstant
-ffebld_constant_new_logical1_val (ffetargetLogical1 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_logical1_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL1;
- nc->u.logical1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_logical1_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL1;
- nc->u.logical1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_logical2_val -- Return a logical2 constant object
-
- See prototype. */
-
-#if FFETARGET_okLOGICAL2
-ffebldConstant
-ffebld_constant_new_logical2_val (ffetargetLogical2 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_logical2_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL2;
- nc->u.logical2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_logical2_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL2;
- nc->u.logical2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_logical3_val -- Return a logical3 constant object
-
- See prototype. */
-
-#if FFETARGET_okLOGICAL3
-ffebldConstant
-ffebld_constant_new_logical3_val (ffetargetLogical3 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_logical3_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL3",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL3;
- nc->u.logical3 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_logical3_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL3",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL3;
- nc->u.logical3 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_logical4_val -- Return a logical4 constant object
-
- See prototype. */
-
-#if FFETARGET_okLOGICAL4
-ffebldConstant
-ffebld_constant_new_logical4_val (ffetargetLogical4 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_logical4_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL4",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL4;
- nc->u.logical4 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_logical4_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constLOGICAL4",
- sizeof (*nc));
- nc->consttype = FFEBLD_constLOGICAL4;
- nc->u.logical4 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_real1 -- Return real1 constant object from token
-
- See prototype. */
-
-#if FFETARGET_okREAL1
-ffebldConstant
-ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
- ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
- ffelexToken exponent_digits)
-{
- ffetargetReal1 val;
-
- ffetarget_real1 (&val,
- integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
- return ffebld_constant_new_real1_val (val);
-}
-
-#endif
-/* ffebld_constant_new_real1_val -- Return an real1 constant object
-
- See prototype. */
-
-#if FFETARGET_okREAL1
-ffebldConstant
-ffebld_constant_new_real1_val (ffetargetReal1 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_real1_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constREAL1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constREAL1;
- nc->u.real1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_real1_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constREAL1",
- sizeof (*nc));
- nc->consttype = FFEBLD_constREAL1;
- nc->u.real1 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_real2 -- Return real2 constant object from token
-
- See prototype. */
-
-#if FFETARGET_okREAL2
-ffebldConstant
-ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
- ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
- ffelexToken exponent_digits)
-{
- ffetargetReal2 val;
-
- ffetarget_real2 (&val,
- integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
- return ffebld_constant_new_real2_val (val);
-}
-
-#endif
-/* ffebld_constant_new_real2_val -- Return an real2 constant object
-
- See prototype. */
-
-#if FFETARGET_okREAL2
-ffebldConstant
-ffebld_constant_new_real2_val (ffetargetReal2 val)
-{
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_real2_;
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constREAL2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constREAL1;
- nc->u.real2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_real2_ = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constREAL2",
- sizeof (*nc));
- nc->consttype = FFEBLD_constREAL2;
- nc->u.real2 = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-#endif
-/* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_bm (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_binarymil (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
-}
-
-/* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_bv (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_binaryvxt (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
-}
-
-/* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_hxm (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_hexxmil (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
-}
-
-/* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_hxv (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_hexxvxt (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
-}
-
-/* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_hzm (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_hexzmil (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
-}
-
-/* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_hzv (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_hexzvxt (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
-}
-
-/* ffebld_constant_new_typeless_om -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_om (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_octalmil (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
-}
-
-/* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
-
- See prototype.
-
- Parses the token as a decimal integer constant, thus it must be an
- FFELEX_typeNUMBER. */
-
-ffebldConstant
-ffebld_constant_new_typeless_ov (ffelexToken t)
-{
- ffetargetTypeless val;
-
- ffetarget_octalvxt (&val, t);
- return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
-}
-
-/* ffebld_constant_new_typeless_val -- Return a typeless constant object
-
- See prototype. */
-
-ffebldConstant
-ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
-{
-
- ffebldConstant nc;
- ffebldConstant P;
- ffebldConstant Q;
- int cmp = 0;
- P = ffebld_constant_typeless_[type
- - FFEBLD_constTYPELESS_FIRST];
- Q = P;
- if (!P)
- {
- /* make this node the root */
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constTYPELESS",
- sizeof (*nc));
- nc->consttype = type;
- nc->u.typeless = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
- ffebld_constant_typeless_[type- FFEBLD_constTYPELESS_FIRST] = nc;
- return nc;
- }
- else
- while (P)
- {
- Q = P;
- cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (P));
- if (cmp > 0)
- P = P->llink;
- else if (cmp < 0)
- P = P->rlink;
- else
- return P;
- }
-
- nc = malloc_new_kp (ffebld_constant_pool(),
- "FFEBLD_constTYPELESS",
- sizeof (*nc));
- nc->consttype = type;
- nc->u.typeless = val;
- nc->hook = FFECOM_constantNULL;
- nc->llink = NULL;
- nc->rlink = NULL;
-
- if (cmp < 0)
- Q->llink = nc;
- else
- Q->rlink = nc;
- return nc;
-}
-
-/* ffebld_constantarray_get -- Get a value from an array of constants
-
- See prototype. */
-
-ffebldConstantUnion
-ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset offset)
-{
- ffebldConstantUnion u;
-
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- u.integer1 = *(array.integer1 + offset);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- u.integer2 = *(array.integer2 + offset);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- u.integer3 = *(array.integer3 + offset);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- u.integer4 = *(array.integer4 + offset);
- break;
-#endif
-
- default:
- assert ("bad INTEGER kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- u.logical1 = *(array.logical1 + offset);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- u.logical2 = *(array.logical2 + offset);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- u.logical3 = *(array.logical3 + offset);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- u.logical4 = *(array.logical4 + offset);
- break;
-#endif
-
- default:
- assert ("bad LOGICAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- u.real1 = *(array.real1 + offset);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- u.real2 = *(array.real2 + offset);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- u.real3 = *(array.real3 + offset);
- break;
-#endif
-
- default:
- assert ("bad REAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- u.complex1 = *(array.complex1 + offset);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- u.complex2 = *(array.complex2 + offset);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- u.complex3 = *(array.complex3 + offset);
- break;
-#endif
-
- default:
- assert ("bad COMPLEX kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- u.character1.length = 1;
- u.character1.text = array.character1 + offset;
- break;
-#endif
-
- default:
- assert ("bad CHARACTER kindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad basictype" == NULL);
- break;
- }
-
- return u;
-}
-
-/* ffebld_constantarray_new -- Make an array of constants
-
- See prototype. */
-
-ffebldConstantArray
-ffebld_constantarray_new (ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset size)
-{
- ffebldConstantArray ptr;
-
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetInteger1),
- 0);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetInteger2),
- 0);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetInteger3),
- 0);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetInteger4),
- 0);
- break;
-#endif
-
- default:
- assert ("bad INTEGER kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetLogical1),
- 0);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetLogical2),
- 0);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetLogical3),
- 0);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetLogical4),
- 0);
- break;
-#endif
-
- default:
- assert ("bad LOGICAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetReal1),
- 0);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetReal2),
- 0);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetReal3),
- 0);
- break;
-#endif
-
- default:
- assert ("bad REAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetComplex1),
- 0);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetComplex2),
- 0);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size *= sizeof (ffetargetComplex3),
- 0);
- break;
-#endif
-
- default:
- assert ("bad COMPLEX kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
- "ffebldConstantArray",
- size
- *= sizeof (ffetargetCharacterUnit1),
- 0);
- break;
-#endif
-
- default:
- assert ("bad CHARACTER kindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad basictype" == NULL);
- break;
- }
-
- return ptr;
-}
-
-/* ffebld_constantarray_preparray -- Prepare for copy between arrays
-
- See prototype.
-
- Like _prepare, but the source is an array instead of a single-value
- constant. */
-
-void
-ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
- ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
- ffetargetOffset offset, ffebldConstantArray source_array,
- ffeinfoBasictype cbt, ffeinfoKindtype ckt)
-{
- switch (abt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (akt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- *aptr = array.integer1 + offset;
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- *aptr = array.integer2 + offset;
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- *aptr = array.integer3 + offset;
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- *aptr = array.integer4 + offset;
- break;
-#endif
-
- default:
- assert ("bad INTEGER akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (akt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- *aptr = array.logical1 + offset;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- *aptr = array.logical2 + offset;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- *aptr = array.logical3 + offset;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- *aptr = array.logical4 + offset;
- break;
-#endif
-
- default:
- assert ("bad LOGICAL akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (akt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- *aptr = array.real1 + offset;
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- *aptr = array.real2 + offset;
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- *aptr = array.real3 + offset;
- break;
-#endif
-
- default:
- assert ("bad REAL akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (akt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- *aptr = array.complex1 + offset;
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- *aptr = array.complex2 + offset;
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- *aptr = array.complex3 + offset;
- break;
-#endif
-
- default:
- assert ("bad COMPLEX akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (akt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- *aptr = array.character1 + offset;
- break;
-#endif
-
- default:
- assert ("bad CHARACTER akindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad abasictype" == NULL);
- break;
- }
-
- switch (cbt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (ckt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- *cptr = source_array.integer1;
- *size = sizeof (*source_array.integer1);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- *cptr = source_array.integer2;
- *size = sizeof (*source_array.integer2);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- *cptr = source_array.integer3;
- *size = sizeof (*source_array.integer3);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- *cptr = source_array.integer4;
- *size = sizeof (*source_array.integer4);
- break;
-#endif
-
- default:
- assert ("bad INTEGER ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ckt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- *cptr = source_array.logical1;
- *size = sizeof (*source_array.logical1);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- *cptr = source_array.logical2;
- *size = sizeof (*source_array.logical2);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- *cptr = source_array.logical3;
- *size = sizeof (*source_array.logical3);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- *cptr = source_array.logical4;
- *size = sizeof (*source_array.logical4);
- break;
-#endif
-
- default:
- assert ("bad LOGICAL ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ckt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- *cptr = source_array.real1;
- *size = sizeof (*source_array.real1);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- *cptr = source_array.real2;
- *size = sizeof (*source_array.real2);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- *cptr = source_array.real3;
- *size = sizeof (*source_array.real3);
- break;
-#endif
-
- default:
- assert ("bad REAL ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ckt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- *cptr = source_array.complex1;
- *size = sizeof (*source_array.complex1);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- *cptr = source_array.complex2;
- *size = sizeof (*source_array.complex2);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- *cptr = source_array.complex3;
- *size = sizeof (*source_array.complex3);
- break;
-#endif
-
- default:
- assert ("bad COMPLEX ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ckt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- *cptr = source_array.character1;
- *size = sizeof (*source_array.character1);
- break;
-#endif
-
- default:
- assert ("bad CHARACTER ckindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad cbasictype" == NULL);
- break;
- }
-}
-
-/* ffebld_constantarray_prepare -- Prepare for copy between value and array
-
- See prototype.
-
- Like _put, but just returns the pointers to the beginnings of the
- array and the constant and returns the size (the amount of info to
- copy). The idea is that the caller can use memcpy to accomplish the
- same thing as _put (though slower), or the caller can use a different
- function that swaps bytes, words, etc for a different target machine.
- Also, the type of the array may be different from the type of the
- constant; the array type is used to determine the meaning (scale) of
- the offset field (to calculate the array pointer), the constant type is
- used to determine the constant pointer and the size (amount of info to
- copy). */
-
-void
-ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
- ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
- ffetargetOffset offset, ffebldConstantUnion *constant,
- ffeinfoBasictype cbt, ffeinfoKindtype ckt)
-{
- switch (abt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (akt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- *aptr = array.integer1 + offset;
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- *aptr = array.integer2 + offset;
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- *aptr = array.integer3 + offset;
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- *aptr = array.integer4 + offset;
- break;
-#endif
-
- default:
- assert ("bad INTEGER akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (akt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- *aptr = array.logical1 + offset;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- *aptr = array.logical2 + offset;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- *aptr = array.logical3 + offset;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- *aptr = array.logical4 + offset;
- break;
-#endif
-
- default:
- assert ("bad LOGICAL akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (akt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- *aptr = array.real1 + offset;
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- *aptr = array.real2 + offset;
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- *aptr = array.real3 + offset;
- break;
-#endif
-
- default:
- assert ("bad REAL akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (akt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- *aptr = array.complex1 + offset;
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- *aptr = array.complex2 + offset;
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- *aptr = array.complex3 + offset;
- break;
-#endif
-
- default:
- assert ("bad COMPLEX akindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (akt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- *aptr = array.character1 + offset;
- break;
-#endif
-
- default:
- assert ("bad CHARACTER akindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad abasictype" == NULL);
- break;
- }
-
- switch (cbt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (ckt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- *cptr = &constant->integer1;
- *size = sizeof (constant->integer1);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- *cptr = &constant->integer2;
- *size = sizeof (constant->integer2);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- *cptr = &constant->integer3;
- *size = sizeof (constant->integer3);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- *cptr = &constant->integer4;
- *size = sizeof (constant->integer4);
- break;
-#endif
-
- default:
- assert ("bad INTEGER ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ckt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- *cptr = &constant->logical1;
- *size = sizeof (constant->logical1);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- *cptr = &constant->logical2;
- *size = sizeof (constant->logical2);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- *cptr = &constant->logical3;
- *size = sizeof (constant->logical3);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- *cptr = &constant->logical4;
- *size = sizeof (constant->logical4);
- break;
-#endif
-
- default:
- assert ("bad LOGICAL ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ckt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- *cptr = &constant->real1;
- *size = sizeof (constant->real1);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- *cptr = &constant->real2;
- *size = sizeof (constant->real2);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- *cptr = &constant->real3;
- *size = sizeof (constant->real3);
- break;
-#endif
-
- default:
- assert ("bad REAL ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ckt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- *cptr = &constant->complex1;
- *size = sizeof (constant->complex1);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- *cptr = &constant->complex2;
- *size = sizeof (constant->complex2);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- *cptr = &constant->complex3;
- *size = sizeof (constant->complex3);
- break;
-#endif
-
- default:
- assert ("bad COMPLEX ckindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ckt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- *cptr = ffetarget_text_character1 (constant->character1);
- *size = ffetarget_length_character1 (constant->character1);
- break;
-#endif
-
- default:
- assert ("bad CHARACTER ckindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad cbasictype" == NULL);
- break;
- }
-}
-
-/* ffebld_constantarray_put -- Put a value into an array of constants
-
- See prototype. */
-
-void
-ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
-{
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- *(array.integer1 + offset) = constant.integer1;
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- *(array.integer2 + offset) = constant.integer2;
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- *(array.integer3 + offset) = constant.integer3;
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- *(array.integer4 + offset) = constant.integer4;
- break;
-#endif
-
- default:
- assert ("bad INTEGER kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- *(array.logical1 + offset) = constant.logical1;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- *(array.logical2 + offset) = constant.logical2;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- *(array.logical3 + offset) = constant.logical3;
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- *(array.logical4 + offset) = constant.logical4;
- break;
-#endif
-
- default:
- assert ("bad LOGICAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- *(array.real1 + offset) = constant.real1;
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- *(array.real2 + offset) = constant.real2;
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- *(array.real3 + offset) = constant.real3;
- break;
-#endif
-
- default:
- assert ("bad REAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- *(array.complex1 + offset) = constant.complex1;
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- *(array.complex2 + offset) = constant.complex2;
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- *(array.complex3 + offset) = constant.complex3;
- break;
-#endif
-
- default:
- assert ("bad COMPLEX kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- memcpy (array.character1 + offset,
- ffetarget_text_character1 (constant.character1),
- ffetarget_length_character1 (constant.character1));
- break;
-#endif
-
- default:
- assert ("bad CHARACTER kindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad basictype" == NULL);
- break;
- }
-}
-
-/* ffebld_init_0 -- Initialize the module
-
- ffebld_init_0(); */
-
-void
-ffebld_init_0 (void)
-{
- assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
- assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
-}
-
-/* ffebld_init_1 -- Initialize the module for a file
-
- ffebld_init_1(); */
-
-void
-ffebld_init_1 (void)
-{
-#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
- int i;
-
-#if FFETARGET_okCHARACTER1
- ffebld_constant_character1_ = NULL;
-#endif
-#if FFETARGET_okCOMPLEX1
- ffebld_constant_complex1_ = NULL;
-#endif
-#if FFETARGET_okCOMPLEX2
- ffebld_constant_complex2_ = NULL;
-#endif
-#if FFETARGET_okCOMPLEX3
- ffebld_constant_complex3_ = NULL;
-#endif
-#if FFETARGET_okINTEGER1
- ffebld_constant_integer1_ = NULL;
-#endif
-#if FFETARGET_okINTEGER2
- ffebld_constant_integer2_ = NULL;
-#endif
-#if FFETARGET_okINTEGER3
- ffebld_constant_integer3_ = NULL;
-#endif
-#if FFETARGET_okINTEGER4
- ffebld_constant_integer4_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL1
- ffebld_constant_logical1_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL2
- ffebld_constant_logical2_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL3
- ffebld_constant_logical3_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL4
- ffebld_constant_logical4_ = NULL;
-#endif
-#if FFETARGET_okREAL1
- ffebld_constant_real1_ = NULL;
-#endif
-#if FFETARGET_okREAL2
- ffebld_constant_real2_ = NULL;
-#endif
-#if FFETARGET_okREAL3
- ffebld_constant_real3_ = NULL;
-#endif
- ffebld_constant_hollerith_ = NULL;
- for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
- ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
-#endif
-}
-
-/* ffebld_init_2 -- Initialize the module
-
- ffebld_init_2(); */
-
-void
-ffebld_init_2 (void)
-{
-#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
- int i;
-#endif
-
- ffebld_pool_stack_.next = NULL;
- ffebld_pool_stack_.pool = ffe_pool_program_unit ();
-#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
-#if FFETARGET_okCHARACTER1
- ffebld_constant_character1_ = NULL;
-#endif
-#if FFETARGET_okCOMPLEX1
- ffebld_constant_complex1_ = NULL;
-#endif
-#if FFETARGET_okCOMPLEX2
- ffebld_constant_complex2_ = NULL;
-#endif
-#if FFETARGET_okCOMPLEX3
- ffebld_constant_complex3_ = NULL;
-#endif
-#if FFETARGET_okINTEGER1
- ffebld_constant_integer1_ = NULL;
-#endif
-#if FFETARGET_okINTEGER2
- ffebld_constant_integer2_ = NULL;
-#endif
-#if FFETARGET_okINTEGER3
- ffebld_constant_integer3_ = NULL;
-#endif
-#if FFETARGET_okINTEGER4
- ffebld_constant_integer4_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL1
- ffebld_constant_logical1_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL2
- ffebld_constant_logical2_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL3
- ffebld_constant_logical3_ = NULL;
-#endif
-#if FFETARGET_okLOGICAL4
- ffebld_constant_logical4_ = NULL;
-#endif
-#if FFETARGET_okREAL1
- ffebld_constant_real1_ = NULL;
-#endif
-#if FFETARGET_okREAL2
- ffebld_constant_real2_ = NULL;
-#endif
-#if FFETARGET_okREAL3
- ffebld_constant_real3_ = NULL;
-#endif
- ffebld_constant_hollerith_ = NULL;
- for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
- ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
-#endif
-}
-
-/* ffebld_list_length -- Return # of opITEMs in list
-
- ffebld list; // Must be NULL or opITEM
- ffebldListLength length;
- length = ffebld_list_length(list);
-
- Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */
-
-ffebldListLength
-ffebld_list_length (ffebld list)
-{
- ffebldListLength length;
-
- for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
- ;
-
- return length;
-}
-
-/* ffebld_new_accter -- Create an ffebld object that is an array
-
- ffebld x;
- ffebldConstantArray a;
- ffebit b;
- x = ffebld_new_accter(a,b); */
-
-ffebld
-ffebld_new_accter (ffebldConstantArray a, ffebit b)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = FFEBLD_opACCTER;
- x->u.accter.array = a;
- x->u.accter.bits = b;
- x->u.accter.pad = 0;
- return x;
-}
-
-/* ffebld_new_arrter -- Create an ffebld object that is an array
-
- ffebld x;
- ffebldConstantArray a;
- ffetargetOffset size;
- x = ffebld_new_arrter(a,size); */
-
-ffebld
-ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = FFEBLD_opARRTER;
- x->u.arrter.array = a;
- x->u.arrter.size = size;
- x->u.arrter.pad = 0;
- return x;
-}
-
-/* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
-
- ffebld x;
- ffebldConstant c;
- x = ffebld_new_conter_with_orig(c,NULL); */
-
-ffebld
-ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = FFEBLD_opCONTER;
- x->u.conter.expr = c;
- x->u.conter.orig = o;
- x->u.conter.pad = 0;
- return x;
-}
-
-/* ffebld_new_item -- Create an ffebld item object
-
- ffebld x,y,z;
- x = ffebld_new_item(y,z); */
-
-ffebld
-ffebld_new_item (ffebld head, ffebld trail)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = FFEBLD_opITEM;
- x->u.item.head = head;
- x->u.item.trail = trail;
- return x;
-}
-
-/* ffebld_new_labter -- Create an ffebld object that is a label
-
- ffebld x;
- ffelab l;
- x = ffebld_new_labter(c); */
-
-ffebld
-ffebld_new_labter (ffelab l)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = FFEBLD_opLABTER;
- x->u.labter = l;
- return x;
-}
-
-/* ffebld_new_labtok -- Create object that is a label's NUMBER token
-
- ffebld x;
- ffelexToken t;
- x = ffebld_new_labter(c);
-
- Like the other ffebld_new_ functions, the
- supplied argument is stored exactly as is: ffelex_token_use is NOT
- called, so the token is "consumed", if one is indeed supplied (it may
- be NULL). */
-
-ffebld
-ffebld_new_labtok (ffelexToken t)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = FFEBLD_opLABTOK;
- x->u.labtok = t;
- return x;
-}
-
-/* ffebld_new_none -- Create an ffebld object with no arguments
-
- ffebld x;
- x = ffebld_new_none(FFEBLD_opWHATEVER); */
-
-ffebld
-ffebld_new_none (ffebldOp o)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = o;
- return x;
-}
-
-/* ffebld_new_one -- Create an ffebld object with one argument
-
- ffebld x,y;
- x = ffebld_new_one(FFEBLD_opWHATEVER,y); */
-
-ffebld
-ffebld_new_one (ffebldOp o, ffebld left)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = o;
- x->u.nonter.left = left;
- x->u.nonter.hook = FFECOM_nonterNULL;
- return x;
-}
-
-/* ffebld_new_symter -- Create an ffebld object that is a symbol
-
- ffebld x;
- ffesymbol s;
- ffeintrinGen gen; // Generic intrinsic id, if any
- ffeintrinSpec spec; // Specific intrinsic id, if any
- ffeintrinImp imp; // Implementation intrinsic id, if any
- x = ffebld_new_symter (s, gen, spec, imp); */
-
-ffebld
-ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
- ffeintrinImp imp)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = FFEBLD_opSYMTER;
- x->u.symter.symbol = s;
- x->u.symter.generic = gen;
- x->u.symter.specific = spec;
- x->u.symter.implementation = imp;
- x->u.symter.do_iter = FALSE;
- return x;
-}
-
-/* ffebld_new_two -- Create an ffebld object with two arguments
-
- ffebld x,y,z;
- x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */
-
-ffebld
-ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
-{
- ffebld x;
-
- x = ffebld_new ();
- x->op = o;
- x->u.nonter.left = left;
- x->u.nonter.right = right;
- x->u.nonter.hook = FFECOM_nonterNULL;
- return x;
-}
-
-/* ffebld_pool_pop -- Pop ffebld's pool stack
-
- ffebld_pool_pop(); */
-
-void
-ffebld_pool_pop (void)
-{
- ffebldPoolstack_ ps;
-
- assert (ffebld_pool_stack_.next != NULL);
- ps = ffebld_pool_stack_.next;
- ffebld_pool_stack_.next = ps->next;
- ffebld_pool_stack_.pool = ps->pool;
- malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
-}
-
-/* ffebld_pool_push -- Push ffebld's pool stack
-
- ffebld_pool_push(); */
-
-void
-ffebld_pool_push (mallocPool pool)
-{
- ffebldPoolstack_ ps;
-
- ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
- ps->next = ffebld_pool_stack_.next;
- ps->pool = ffebld_pool_stack_.pool;
- ffebld_pool_stack_.next = ps;
- ffebld_pool_stack_.pool = pool;
-}
-
-/* ffebld_op_string -- Return short string describing op
-
- ffebldOp o;
- ffebld_op_string(o);
-
- Returns a short string (uppercase) containing the name of the op. */
-
-const char *
-ffebld_op_string (ffebldOp o)
-{
- if (o >= ARRAY_SIZE (ffebld_op_string_))
- return "?\?\?";
- return ffebld_op_string_[o];
-}
-
-/* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
-
- ffetargetCharacterSize sz;
- ffebld b;
- sz = ffebld_size_max (b);
-
- Like ffebld_size_known, but if that would return NONE and the expression
- is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
- of the subexpression(s). */
-
-ffetargetCharacterSize
-ffebld_size_max (ffebld b)
-{
- ffetargetCharacterSize sz;
-
-recurse: /* :::::::::::::::::::: */
-
- sz = ffebld_size_known (b);
-
- if (sz != FFETARGET_charactersizeNONE)
- return sz;
-
- switch (ffebld_op (b))
- {
- case FFEBLD_opSUBSTR:
- case FFEBLD_opCONVERT:
- case FFEBLD_opPAREN:
- b = ffebld_left (b);
- goto recurse; /* :::::::::::::::::::: */
-
- case FFEBLD_opCONCATENATE:
- sz = ffebld_size_max (ffebld_left (b))
- + ffebld_size_max (ffebld_right (b));
- return sz;
-
- default:
- return sz;
- }
-}
+++ /dev/null
-/* bld.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 1996, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- bld.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_BLD_H
-#define GCC_F_BLD_H
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFEBLD_constNONE,
- FFEBLD_constINTEGER1,
- FFEBLD_constINTEGER2,
- FFEBLD_constINTEGER3,
- FFEBLD_constINTEGER4,
- FFEBLD_constINTEGER5,
- FFEBLD_constINTEGER6,
- FFEBLD_constINTEGER7,
- FFEBLD_constINTEGER8,
- FFEBLD_constLOGICAL1,
- FFEBLD_constLOGICAL2,
- FFEBLD_constLOGICAL3,
- FFEBLD_constLOGICAL4,
- FFEBLD_constLOGICAL5,
- FFEBLD_constLOGICAL6,
- FFEBLD_constLOGICAL7,
- FFEBLD_constLOGICAL8,
- FFEBLD_constREAL1,
- FFEBLD_constREAL2,
- FFEBLD_constREAL3,
- FFEBLD_constREAL4,
- FFEBLD_constREAL5,
- FFEBLD_constREAL6,
- FFEBLD_constREAL7,
- FFEBLD_constREAL8,
- FFEBLD_constCOMPLEX1,
- FFEBLD_constCOMPLEX2,
- FFEBLD_constCOMPLEX3,
- FFEBLD_constCOMPLEX4,
- FFEBLD_constCOMPLEX5,
- FFEBLD_constCOMPLEX6,
- FFEBLD_constCOMPLEX7,
- FFEBLD_constCOMPLEX8,
- FFEBLD_constCHARACTER1,
- FFEBLD_constCHARACTER2,
- FFEBLD_constCHARACTER3,
- FFEBLD_constCHARACTER4,
- FFEBLD_constCHARACTER5,
- FFEBLD_constCHARACTER6,
- FFEBLD_constCHARACTER7,
- FFEBLD_constCHARACTER8,
- FFEBLD_constHOLLERITH,
- FFEBLD_constTYPELESS_FIRST,
- FFEBLD_constBINARY_MIL = FFEBLD_constTYPELESS_FIRST,
- FFEBLD_constBINARY_VXT,
- FFEBLD_constOCTAL_MIL,
- FFEBLD_constOCTAL_VXT,
- FFEBLD_constHEX_X_MIL,
- FFEBLD_constHEX_X_VXT,
- FFEBLD_constHEX_Z_MIL,
- FFEBLD_constHEX_Z_VXT,
- FFEBLD_constTYPELESS_LAST = FFEBLD_constHEX_Z_VXT,
- FFEBLD_const
- } ffebldConst;
-
-typedef enum
- {
-#define FFEBLD_OP(KWD,NAME,ARITY) KWD,
-#include "bld-op.def"
-#undef FFEBLD_OP
- FFEBLD_op
- } ffebldOp;
-
-/* Typedefs. */
-
-typedef struct _ffebld_ *ffebld;
-typedef unsigned char ffebldArity;
-typedef union _ffebld_constant_array_ ffebldConstantArray;
-typedef struct _ffebld_constant_ *ffebldConstant;
-typedef union _ffebld_constant_union_ ffebldConstantUnion;
-typedef ffebld *ffebldListBottom;
-typedef unsigned int ffebldListLength;
-#define ffebldListLength_f ""
-typedef struct _ffebld_pool_stack_ *ffebldPoolstack_;
-
-/* Include files needed by this one. */
-
-#include "bit.h"
-#include "com.h"
-#include "info.h"
-#include "intrin.h"
-#include "lab.h"
-#include "lex.h"
-#include "malloc.h"
-#include "symbol.h"
-#include "target.h"
-
-#define FFEBLD_whereconstPROGUNIT_ 1
-#define FFEBLD_whereconstFILE_ 2
-
-#define FFEBLD_whereconstCURRENT_ FFEBLD_whereconstFILE_
-
-/* Structure definitions. */
-
-#define FFEBLD_constINTEGERDEFAULT FFEBLD_constINTEGER1
-#define FFEBLD_constLOGICALDEFAULT FFEBLD_constLOGICAL1
-#define FFEBLD_constREALDEFAULT FFEBLD_constREAL1
-#define FFEBLD_constREALDOUBLE FFEBLD_constREAL2
-#define FFEBLD_constREALQUAD FFEBLD_constREAL3
-#define FFEBLD_constCOMPLEX FFEBLD_constCOMPLEX1
-#define FFEBLD_constCOMPLEXDOUBLE FFEBLD_constCOMPLEX2
-#define FFEBLD_constCOMPLEXQUAD FFEBLD_constCOMPLEX3
-#define FFEBLD_constCHARACTERDEFAULT FFEBLD_constCHARACTER1
-
-union _ffebld_constant_union_
- {
- ffetargetTypeless typeless;
- ffetargetHollerith hollerith;
-#if FFETARGET_okINTEGER1
- ffetargetInteger1 integer1;
-#endif
-#if FFETARGET_okINTEGER2
- ffetargetInteger2 integer2;
-#endif
-#if FFETARGET_okINTEGER3
- ffetargetInteger3 integer3;
-#endif
-#if FFETARGET_okINTEGER4
- ffetargetInteger4 integer4;
-#endif
-#if FFETARGET_okLOGICAL1
- ffetargetLogical1 logical1;
-#endif
-#if FFETARGET_okLOGICAL2
- ffetargetLogical2 logical2;
-#endif
-#if FFETARGET_okLOGICAL3
- ffetargetLogical3 logical3;
-#endif
-#if FFETARGET_okLOGICAL4
- ffetargetLogical4 logical4;
-#endif
-#if FFETARGET_okREAL1
- ffetargetReal1 real1;
-#endif
-#if FFETARGET_okREAL2
- ffetargetReal2 real2;
-#endif
-#if FFETARGET_okREAL3
- ffetargetReal3 real3;
-#endif
-#if FFETARGET_okCOMPLEX1
- ffetargetComplex1 complex1;
-#endif
-#if FFETARGET_okCOMPLEX2
- ffetargetComplex2 complex2;
-#endif
-#if FFETARGET_okCOMPLEX3
- ffetargetComplex3 complex3;
-#endif
-#if FFETARGET_okCHARACTER1
- ffetargetCharacter1 character1;
-#endif
- };
-
-union _ffebld_constant_array_
- {
-#if FFETARGET_okINTEGER1
- ffetargetInteger1 *integer1;
-#endif
-#if FFETARGET_okINTEGER2
- ffetargetInteger2 *integer2;
-#endif
-#if FFETARGET_okINTEGER3
- ffetargetInteger3 *integer3;
-#endif
-#if FFETARGET_okINTEGER4
- ffetargetInteger4 *integer4;
-#endif
-#if FFETARGET_okLOGICAL1
- ffetargetLogical1 *logical1;
-#endif
-#if FFETARGET_okLOGICAL2
- ffetargetLogical2 *logical2;
-#endif
-#if FFETARGET_okLOGICAL3
- ffetargetLogical3 *logical3;
-#endif
-#if FFETARGET_okLOGICAL4
- ffetargetLogical4 *logical4;
-#endif
-#if FFETARGET_okREAL1
- ffetargetReal1 *real1;
-#endif
-#if FFETARGET_okREAL2
- ffetargetReal2 *real2;
-#endif
-#if FFETARGET_okREAL3
- ffetargetReal3 *real3;
-#endif
-#if FFETARGET_okCOMPLEX1
- ffetargetComplex1 *complex1;
-#endif
-#if FFETARGET_okCOMPLEX2
- ffetargetComplex2 *complex2;
-#endif
-#if FFETARGET_okCOMPLEX3
- ffetargetComplex3 *complex3;
-#endif
-#if FFETARGET_okCHARACTER1
- ffetargetCharacterUnit1 *character1;
-#endif
- };
-
-struct _ffebld_
- {
- ffebldOp op;
- ffeinfo info; /* Not used or valid for
- op=={STAR,ITEM,BOUNDS,REPEAT,LABTER,
- LABTOK,IMPDO}. */
- union
- {
- struct
- {
- ffebld left;
- ffebld right;
- ffecomNonter hook; /* Whatever the compiler/backend wants! */
- }
- nonter;
- struct
- {
- ffebld head;
- ffebld trail;
- }
- item;
- struct
- {
- ffebldConstant expr;
- ffebld orig; /* Original expression, or NULL if none. */
- ffetargetAlign pad; /* Initial padding (for DATA, etc.). */
- }
- conter;
- struct
- {
- ffebldConstantArray array;
- ffetargetOffset size;
- ffetargetAlign pad; /* Initial padding (for DATA, etc.). */
- }
- arrter;
- struct
- {
- ffebldConstantArray array;
- ffebit bits;
- ffetargetAlign pad; /* Initial padding (for DATA, etc.). */
- }
- accter;
- struct
- {
- ffesymbol symbol;
- ffeintrinGen generic; /* Id for generic intrinsic. */
- ffeintrinSpec specific; /* Id for specific intrinsic. */
- ffeintrinImp implementation; /* Id for implementation. */
- bool do_iter; /* TRUE if this ref is a read-only ref by
- definition (ref within DO loop using this
- var as iterator). */
- }
- symter;
- ffelab labter;
- ffelexToken labtok;
- }
- u;
- };
-
-struct _ffebld_constant_
- {
- ffebldConstant rlink;
- ffebldConstant llink;
- ffebldConstant first_complex; /* First complex const with me as
- real. */
- ffebldConst consttype;
- ffecomConstant hook; /* Whatever the compiler/backend wants! */
- bool numeric; /* A numeric kind of constant. */
- ffebldConstantUnion u;
- };
-
-struct _ffebld_pool_stack_
- {
- ffebldPoolstack_ next;
- mallocPool pool;
- };
-
-/* Global objects accessed by users of this module. */
-
-extern const ffebldArity ffebld_arity_op_[(int) FFEBLD_op];
-extern struct _ffebld_pool_stack_ ffebld_pool_stack_;
-
-/* Declare functions with prototypes. */
-
-int ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2);
-bool ffebld_constant_is_magical (ffebldConstant c);
-bool ffebld_constant_is_zero (ffebldConstant c);
-#if FFETARGET_okCHARACTER1
-ffebldConstant ffebld_constant_new_character1 (ffelexToken t);
-ffebldConstant ffebld_constant_new_character1_val (ffetargetCharacter1 val);
-#endif
-#if FFETARGET_okCOMPLEX1
-ffebldConstant ffebld_constant_new_complex1 (ffebldConstant real,
- ffebldConstant imaginary);
-ffebldConstant ffebld_constant_new_complex1_val (ffetargetComplex1 val);
-#endif
-#if FFETARGET_okCOMPLEX2
-ffebldConstant ffebld_constant_new_complex2 (ffebldConstant real,
- ffebldConstant imaginary);
-ffebldConstant ffebld_constant_new_complex2_val (ffetargetComplex2 val);
-#endif
-#if FFETARGET_okCOMPLEX3
-ffebldConstant ffebld_constant_new_complex3 (ffebldConstant real,
- ffebldConstant imaginary);
-ffebldConstant ffebld_constant_new_complex3_val (ffetargetComplex3 val);
-#endif
-ffebldConstant ffebld_constant_new_hollerith (ffelexToken t);
-ffebldConstant ffebld_constant_new_hollerith_val (ffetargetHollerith val);
-#if FFETARGET_okINTEGER1
-ffebldConstant ffebld_constant_new_integer1 (ffelexToken t);
-ffebldConstant ffebld_constant_new_integer1_val (ffetargetInteger1 val);
-#endif
-#if FFETARGET_okINTEGER2
-ffebldConstant ffebld_constant_new_integer2 (ffelexToken t);
-ffebldConstant ffebld_constant_new_integer2_val (ffetargetInteger2 val);
-#endif
-#if FFETARGET_okINTEGER3
-ffebldConstant ffebld_constant_new_integer3 (ffelexToken t);
-ffebldConstant ffebld_constant_new_integer3_val (ffetargetInteger3 val);
-#endif
-#if FFETARGET_okINTEGER4
-ffebldConstant ffebld_constant_new_integer4 (ffelexToken t);
-ffebldConstant ffebld_constant_new_integer4_val (ffetargetInteger4 val);
-#endif
-ffebldConstant ffebld_constant_new_integerbinary (ffelexToken t);
-ffebldConstant ffebld_constant_new_integerhex (ffelexToken t);
-ffebldConstant ffebld_constant_new_integeroctal (ffelexToken t);
-#if FFETARGET_okLOGICAL1
-ffebldConstant ffebld_constant_new_logical1 (bool truth);
-ffebldConstant ffebld_constant_new_logical1_val (ffetargetLogical1 val);
-#endif
-#if FFETARGET_okLOGICAL2
-ffebldConstant ffebld_constant_new_logical2 (bool truth);
-ffebldConstant ffebld_constant_new_logical2_val (ffetargetLogical2 val);
-#endif
-#if FFETARGET_okLOGICAL3
-ffebldConstant ffebld_constant_new_logical3 (bool truth);
-ffebldConstant ffebld_constant_new_logical3_val (ffetargetLogical3 val);
-#endif
-#if FFETARGET_okLOGICAL4
-ffebldConstant ffebld_constant_new_logical4 (bool truth);
-ffebldConstant ffebld_constant_new_logical4_val (ffetargetLogical4 val);
-#endif
-#if FFETARGET_okREAL1
-ffebldConstant ffebld_constant_new_real1 (ffelexToken integer,
- ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
- ffelexToken exponent_sign, ffelexToken exponent_digits);
-ffebldConstant ffebld_constant_new_real1_val (ffetargetReal1 val);
-#endif
-#if FFETARGET_okREAL2
-ffebldConstant ffebld_constant_new_real2 (ffelexToken integer,
- ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
- ffelexToken exponent_sign, ffelexToken exponent_digits);
-ffebldConstant ffebld_constant_new_real2_val (ffetargetReal2 val);
-#endif
-#if FFETARGET_okREAL3
-ffebldConstant ffebld_constant_new_real3 (ffelexToken integer,
- ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
- ffelexToken exponent_sign, ffelexToken exponent_digits);
-ffebldConstant ffebld_constant_new_real3_val (ffetargetReal3 val);
-#endif
-ffebldConstant ffebld_constant_new_typeless_bm (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_bv (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_hxm (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_hxv (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_hzm (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_hzv (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_om (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_ov (ffelexToken t);
-ffebldConstant ffebld_constant_new_typeless_val (ffebldConst type,
- ffetargetTypeless val);
-ffebldConstant ffebld_constant_negated (ffebldConstant c);
-ffebldConstantUnion ffebld_constantarray_get (ffebldConstantArray array,
- ffeinfoBasictype bt, ffeinfoKindtype kt, ffetargetOffset offset);
-void ffebld_constantarray_kill (ffebldConstantArray array, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset size);
-ffebldConstantArray ffebld_constantarray_new (ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset size);
-void ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
- ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
- ffetargetOffset offset, ffebldConstantUnion *constant,
- ffeinfoBasictype cbt, ffeinfoKindtype ckt);
-void ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
- ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
- ffetargetOffset offset, ffebldConstantArray source_array,
- ffeinfoBasictype cbt, ffeinfoKindtype ckt);
-void ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant);
-void ffebld_init_0 (void);
-void ffebld_init_1 (void);
-void ffebld_init_2 (void);
-ffebldListLength ffebld_list_length (ffebld l);
-ffebld ffebld_new_accter (ffebldConstantArray array, ffebit b);
-ffebld ffebld_new_arrter (ffebldConstantArray array, ffetargetOffset size);
-ffebld ffebld_new_conter_with_orig (ffebldConstant c, ffebld orig);
-ffebld ffebld_new_item (ffebld head, ffebld trail);
-ffebld ffebld_new_labter (ffelab l);
-ffebld ffebld_new_labtok (ffelexToken t);
-ffebld ffebld_new_none (ffebldOp o);
-ffebld ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
- ffeintrinImp imp);
-ffebld ffebld_new_one (ffebldOp o, ffebld left);
-ffebld ffebld_new_two (ffebldOp o, ffebld left, ffebld right);
-const char *ffebld_op_string (ffebldOp o);
-void ffebld_pool_pop (void);
-void ffebld_pool_push (mallocPool pool);
-ffetargetCharacterSize ffebld_size_max (ffebld b);
-
-/* Define macros. */
-
-#define ffebld_accter(b) ((b)->u.accter.array)
-#define ffebld_accter_bits(b) ((b)->u.accter.bits)
-#define ffebld_accter_pad(b) ((b)->u.accter.pad)
-#define ffebld_accter_set_bits(b,bt) ((b)->u.accter.bits = (bt))
-#define ffebld_accter_set_pad(b,p) ((b)->u.accter.pad = (p))
-#define ffebld_accter_size(b) ffebit_size((b)->u.accter.bits)
-#define ffebld_append_item(b,i) (**(b) = ffebld_new_item((i),NULL), \
- *(b) = &((**(b))->u.item.trail))
-#define ffebld_arity(b) ffebld_arity_op(ffebld_op(b))
-#define ffebld_arity_op(o) (ffebld_arity_op_[o])
-#define ffebld_arrter(b) ((b)->u.arrter.array)
-#define ffebld_arrter_pad(b) ((b)->u.arrter.pad)
-#define ffebld_arrter_set_pad(b,p) ((b)->u.arrter.pad = (p))
-#define ffebld_arrter_set_size(b,s) ((b)->u.arrter.size = (s))
-#define ffebld_arrter_size(b) ((b)->u.arrter.size)
-#define ffebld_basictype(b) (ffeinfo_basictype (ffebld_info ((b))))
-#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
-#define ffebld_constant_pool() ffe_pool_program_unit()
-#elif FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
-#define ffebld_constant_pool() ffe_pool_file()
-#else
-#error
-#endif
-#define ffebld_constant_character1(c) ((c)->u.character1)
-#define ffebld_constant_character2(c) ((c)->u.character2)
-#define ffebld_constant_character3(c) ((c)->u.character3)
-#define ffebld_constant_character4(c) ((c)->u.character4)
-#define ffebld_constant_character5(c) ((c)->u.character5)
-#define ffebld_constant_character6(c) ((c)->u.character6)
-#define ffebld_constant_character7(c) ((c)->u.character7)
-#define ffebld_constant_character8(c) ((c)->u.character8)
-#define ffebld_constant_characterdefault ffebld_constant_character1
-#define ffebld_constant_complex1(c) ((c)->u.complex1)
-#define ffebld_constant_complex2(c) ((c)->u.complex2)
-#define ffebld_constant_complex3(c) ((c)->u.complex3)
-#define ffebld_constant_complex4(c) ((c)->u.complex4)
-#define ffebld_constant_complex5(c) ((c)->u.complex5)
-#define ffebld_constant_complex6(c) ((c)->u.complex6)
-#define ffebld_constant_complex7(c) ((c)->u.complex7)
-#define ffebld_constant_complex8(c) ((c)->u.complex8)
-#define ffebld_constant_complexdefault ffebld_constant_complex1
-#define ffebld_constant_complexdouble ffebld_constant_complex2
-#define ffebld_constant_complexquad ffebld_constant_complex3
-#define ffebld_constant_copy(c) (c)
-#define ffebld_constant_hollerith(c) ((c)->u.hollerith)
-#define ffebld_constant_hook(c) ((c)->hook)
-#define ffebld_constant_integer1(c) ((c)->u.integer1)
-#define ffebld_constant_integer2(c) ((c)->u.integer2)
-#define ffebld_constant_integer3(c) ((c)->u.integer3)
-#define ffebld_constant_integer4(c) ((c)->u.integer4)
-#define ffebld_constant_integer5(c) ((c)->u.integer5)
-#define ffebld_constant_integer6(c) ((c)->u.integer6)
-#define ffebld_constant_integer7(c) ((c)->u.integer7)
-#define ffebld_constant_integer8(c) ((c)->u.integer8)
-#define ffebld_constant_integerdefault ffebld_constant_integer1
-#define ffebld_constant_is_numeric(c) ((c)->numeric)
-#define ffebld_constant_logical1(c) ((c)->u.logical1)
-#define ffebld_constant_logical2(c) ((c)->u.logical2)
-#define ffebld_constant_logical3(c) ((c)->u.logical3)
-#define ffebld_constant_logical4(c) ((c)->u.logical4)
-#define ffebld_constant_logical5(c) ((c)->u.logical5)
-#define ffebld_constant_logical6(c) ((c)->u.logical6)
-#define ffebld_constant_logical7(c) ((c)->u.logical7)
-#define ffebld_constant_logical8(c) ((c)->u.logical8)
-#define ffebld_constant_logicaldefault ffebld_constant_logical1
-#define ffebld_constant_new_characterdefault ffebld_constant_new_character1
-#define ffebld_constant_new_characterdefault_val ffebld_constant_new_character1_val
-#define ffebld_constant_new_complexdefault ffebld_constant_new_complex1
-#define ffebld_constant_new_complexdefault_val ffebld_constant_new_complex1_val
-#define ffebld_constant_new_complexdouble ffebld_constant_new_complex2
-#define ffebld_constant_new_complexdouble_val ffebld_constant_new_complex2_val
-#define ffebld_constant_new_complexquad ffebld_constant_new_complex3
-#define ffebld_constant_new_complexquad_valffebld_constant_new_complex3_val
-#define ffebld_constant_new_integerdefault ffebld_constant_new_integer1
-#define ffebld_constant_new_integerdefault_val ffebld_constant_new_integer1_val
-#define ffebld_constant_new_logicaldefault ffebld_constant_new_logical1
-#define ffebld_constant_new_logicaldefault_val ffebld_constant_new_logical1_val
-#define ffebld_constant_new_realdefault ffebld_constant_new_real1
-#define ffebld_constant_new_realdefault_val ffebld_constant_new_real1_val
-#define ffebld_constant_new_realdouble ffebld_constant_new_real2
-#define ffebld_constant_new_realdouble_val ffebld_constant_new_real2_val
-#define ffebld_constant_new_realquad ffebld_constant_new_real3
-#define ffebld_constant_new_realquad_val ffebld_constant_new_real3_val
-#define ffebld_constant_ptr_to_union(c) (&(c)->u)
-#define ffebld_constant_real1(c) ((c)->u.real1)
-#define ffebld_constant_real2(c) ((c)->u.real2)
-#define ffebld_constant_real3(c) ((c)->u.real3)
-#define ffebld_constant_real4(c) ((c)->u.real4)
-#define ffebld_constant_real5(c) ((c)->u.real5)
-#define ffebld_constant_real6(c) ((c)->u.real6)
-#define ffebld_constant_real7(c) ((c)->u.real7)
-#define ffebld_constant_real8(c) ((c)->u.real8)
-#define ffebld_constant_realdefault ffebld_constant_real1
-#define ffebld_constant_realdouble ffebld_constant_real2
-#define ffebld_constant_realquad ffebld_constant_real3
-#define ffebld_constant_set_hook(c,h) ((c)->hook = (h))
-#define ffebld_constant_set_union(c,un) ((c)->u = (un))
-#define ffebld_constant_type(c) ((c)->consttype)
-#define ffebld_constant_typeless(c) ((c)->u.typeless)
-#define ffebld_constant_union(c) ((c)->u)
-#define ffebld_conter(b) ((b)->u.conter.expr)
-#define ffebld_conter_orig(b) ((b)->u.conter.orig)
-#define ffebld_conter_pad(b) ((b)->u.conter.pad)
-#define ffebld_conter_set_orig(b,o) ((b)->u.conter.orig = (o))
-#define ffebld_conter_set_pad(b,p) ((b)->u.conter.pad = (p))
-#define ffebld_copy(b) (b) /* ~~~Someday really make a copy. */
-#define ffebld_cu_ptr_typeless(u) &(u).typeless
-#define ffebld_cu_ptr_hollerith(u) &(u).hollerith
-#define ffebld_cu_ptr_integer1(u) &(u).integer1
-#define ffebld_cu_ptr_integer2(u) &(u).integer2
-#define ffebld_cu_ptr_integer3(u) &(u).integer3
-#define ffebld_cu_ptr_integer4(u) &(u).integer4
-#define ffebld_cu_ptr_integer5(u) &(u).integer5
-#define ffebld_cu_ptr_integer6(u) &(u).integer6
-#define ffebld_cu_ptr_integer7(u) &(u).integer7
-#define ffebld_cu_ptr_integer8(u) &(u).integer8
-#define ffebld_cu_ptr_integerdefault ffebld_cu_ptr_integer1
-#define ffebld_cu_ptr_logical1(u) &(u).logical1
-#define ffebld_cu_ptr_logical2(u) &(u).logical2
-#define ffebld_cu_ptr_logical3(u) &(u).logical3
-#define ffebld_cu_ptr_logical4(u) &(u).logical4
-#define ffebld_cu_ptr_logical5(u) &(u).logical5
-#define ffebld_cu_ptr_logical6(u) &(u).logical6
-#define ffebld_cu_ptr_logical7(u) &(u).logical7
-#define ffebld_cu_ptr_logical8(u) &(u).logical8
-#define ffebld_cu_ptr_logicaldefault ffebld_cu_ptr_logical1
-#define ffebld_cu_ptr_real1(u) &(u).real1
-#define ffebld_cu_ptr_real2(u) &(u).real2
-#define ffebld_cu_ptr_real3(u) &(u).real3
-#define ffebld_cu_ptr_real4(u) &(u).real4
-#define ffebld_cu_ptr_real5(u) &(u).real5
-#define ffebld_cu_ptr_real6(u) &(u).real6
-#define ffebld_cu_ptr_real7(u) &(u).real7
-#define ffebld_cu_ptr_real8(u) &(u).real8
-#define ffebld_cu_ptr_realdefault ffebld_cu_ptr_real1
-#define ffebld_cu_ptr_realdouble ffebld_cu_ptr_real2
-#define ffebld_cu_ptr_realquad ffebld_cu_ptr_real3
-#define ffebld_cu_ptr_complex1(u) &(u).complex1
-#define ffebld_cu_ptr_complex2(u) &(u).complex2
-#define ffebld_cu_ptr_complex3(u) &(u).complex3
-#define ffebld_cu_ptr_complex4(u) &(u).complex4
-#define ffebld_cu_ptr_complex5(u) &(u).complex5
-#define ffebld_cu_ptr_complex6(u) &(u).complex6
-#define ffebld_cu_ptr_complex7(u) &(u).complex7
-#define ffebld_cu_ptr_complex8(u) &(u).complex8
-#define ffebld_cu_ptr_complexdefault ffebld_cu_ptr_complex1
-#define ffebld_cu_ptr_complexdouble ffebld_cu_ptr_complex2
-#define ffebld_cu_ptr_complexquad ffebld_cu_ptr_complex3
-#define ffebld_cu_ptr_character1(u) &(u).character1
-#define ffebld_cu_ptr_character2(u) &(u).character2
-#define ffebld_cu_ptr_character3(u) &(u).character3
-#define ffebld_cu_ptr_character4(u) &(u).character4
-#define ffebld_cu_ptr_character5(u) &(u).character5
-#define ffebld_cu_ptr_character6(u) &(u).character6
-#define ffebld_cu_ptr_character7(u) &(u).character7
-#define ffebld_cu_ptr_character8(u) &(u).character8
-#define ffebld_cu_val_typeless(u) (u).typeless
-#define ffebld_cu_val_hollerith(u) (u).hollerith
-#define ffebld_cu_val_integer1(u) (u).integer1
-#define ffebld_cu_val_integer2(u) (u).integer2
-#define ffebld_cu_val_integer3(u) (u).integer3
-#define ffebld_cu_val_integer4(u) (u).integer4
-#define ffebld_cu_val_integer5(u) (u).integer5
-#define ffebld_cu_val_integer6(u) (u).integer6
-#define ffebld_cu_val_integer7(u) (u).integer7
-#define ffebld_cu_val_integer8(u) (u).integer8
-#define ffebld_cu_val_integerdefault ffebld_cu_val_integer1
-#define ffebld_cu_val_logical1(u) (u).logical1
-#define ffebld_cu_val_logical2(u) (u).logical2
-#define ffebld_cu_val_logical3(u) (u).logical3
-#define ffebld_cu_val_logical4(u) (u).logical4
-#define ffebld_cu_val_logical5(u) (u).logical5
-#define ffebld_cu_val_logical6(u) (u).logical6
-#define ffebld_cu_val_logical7(u) (u).logical7
-#define ffebld_cu_val_logical8(u) (u).logical8
-#define ffebld_cu_val_logicaldefault ffebld_cu_val_logical
-#define ffebld_cu_val_real1(u) (u).real1
-#define ffebld_cu_val_real2(u) (u).real2
-#define ffebld_cu_val_real3(u) (u).real3
-#define ffebld_cu_val_real4(u) (u).real4
-#define ffebld_cu_val_real5(u) (u).real5
-#define ffebld_cu_val_real6(u) (u).real6
-#define ffebld_cu_val_real7(u) (u).real7
-#define ffebld_cu_val_real8(u) (u).real8
-#define ffebld_cu_val_realdefault ffebld_cu_val_real1
-#define ffebld_cu_val_realdouble ffebld_cu_val_real2
-#define ffebld_cu_val_realquad ffebld_cu_val_real3
-#define ffebld_cu_val_complex1(u) (u).complex1
-#define ffebld_cu_val_complex2(u) (u).complex2
-#define ffebld_cu_val_complex3(u) (u).complex3
-#define ffebld_cu_val_complex4(u) (u).complex4
-#define ffebld_cu_val_complex5(u) (u).complex5
-#define ffebld_cu_val_complex6(u) (u).complex6
-#define ffebld_cu_val_complex7(u) (u).complex7
-#define ffebld_cu_val_complex8(u) (u).complex8
-#define ffebld_cu_val_complexdefault ffebld_cu_val_complex1
-#define ffebld_cu_val_complexdouble ffebld_cu_val_complex2
-#define ffebld_cu_val_complexquad ffebld_cu_val_complex3
-#define ffebld_cu_val_character1(u) (u).character1
-#define ffebld_cu_val_character2(u) (u).character2
-#define ffebld_cu_val_character3(u) (u).character3
-#define ffebld_cu_val_character4(u) (u).character4
-#define ffebld_cu_val_character5(u) (u).character5
-#define ffebld_cu_val_character6(u) (u).character6
-#define ffebld_cu_val_character7(u) (u).character7
-#define ffebld_cu_val_character8(u) (u).character8
-#define ffebld_end_list(b) (*(b) = NULL)
-#define ffebld_head(b) ((b)->u.item.head)
-#define ffebld_info(b) ((b)->info)
-#define ffebld_init_3()
-#define ffebld_init_4()
-#define ffebld_init_list(l,b) (*(l) = NULL, *(b) = (l))
-#define ffebld_item_hook(b) ((b)->u.item.hook)
-#define ffebld_item_set_hook(b,h) ((b)->u.item.hook = (h))
-#define ffebld_kind(b) (ffeinfo_kind (ffebld_info ((b))))
-#define ffebld_kindtype(b) (ffeinfo_kindtype (ffebld_info ((b))))
-#define ffebld_labter(b) ((b)->u.labter)
-#define ffebld_labtok(b) ((b)->u.labtok)
-#define ffebld_left(b) ((b)->u.nonter.left)
-#define ffebld_name_string(n) ((n)->name)
-#define ffebld_new() \
- ((ffebld) malloc_new_kp(ffebld_pool(), "FFEBLD",sizeof(struct _ffebld_)))
-#define ffebld_new_any() ffebld_new_none(FFEBLD_opANY)
-#define ffebld_new_conter(c) ffebld_new_conter_with_orig((c),NULL)
-#define ffebld_new_star() ffebld_new_none(FFEBLD_opSTAR)
-#define ffebld_new_uplus(l) ffebld_new_one(FFEBLD_opUPLUS,(l))
-#define ffebld_new_uminus(l) ffebld_new_one(FFEBLD_opUMINUS,(l))
-#define ffebld_new_add(l,r) ffebld_new_two(FFEBLD_opADD,(l),(r))
-#define ffebld_new_subtract(l,r) ffebld_new_two(FFEBLD_opSUBTRACT,(l),(r))
-#define ffebld_new_multiply(l,r) ffebld_new_two(FFEBLD_opMULTIPLY,(l),(r))
-#define ffebld_new_divide(l,r) ffebld_new_two(FFEBLD_opDIVIDE,(l),(r))
-#define ffebld_new_power(l,r) ffebld_new_two(FFEBLD_opPOWER,(l),(r))
-#define ffebld_new_bounds(l,r) ffebld_new_two(FFEBLD_opBOUNDS,(l),(r))
-#define ffebld_new_concatenate(l,r) ffebld_new_two(FFEBLD_opCONCATENATE,(l),(r))
-#define ffebld_new_not(l) ffebld_new_one(FFEBLD_opNOT,(l))
-#define ffebld_new_lt(l,r) ffebld_new_two(FFEBLD_opLT,(l),(r))
-#define ffebld_new_le(l,r) ffebld_new_two(FFEBLD_opLE,(l),(r))
-#define ffebld_new_eq(l,r) ffebld_new_two(FFEBLD_opEQ,(l),(r))
-#define ffebld_new_ne(l,r) ffebld_new_two(FFEBLD_opNE,(l),(r))
-#define ffebld_new_gt(l,r) ffebld_new_two(FFEBLD_opGT,(l),(r))
-#define ffebld_new_ge(l,r) ffebld_new_two(FFEBLD_opGE,(l),(r))
-#define ffebld_new_and(l,r) ffebld_new_two(FFEBLD_opAND,(l),(r))
-#define ffebld_new_or(l,r) ffebld_new_two(FFEBLD_opOR,(l),(r))
-#define ffebld_new_xor(l,r) ffebld_new_two(FFEBLD_opXOR,(l),(r))
-#define ffebld_new_eqv(l,r) ffebld_new_two(FFEBLD_opEQV,(l),(r))
-#define ffebld_new_neqv(l,r) ffebld_new_two(FFEBLD_opNEQV,(l),(r))
-#define ffebld_new_paren(l) ffebld_new_one(FFEBLD_opPAREN,(l))
-#define ffebld_new_repeat(l,r) ffebld_new_two(FFEBLD_opREPEAT,(l),(r))
-#define ffebld_new_percent_descr(l) ffebld_new_one(FFEBLD_opPERCENT_DESCR,(l))
-#define ffebld_new_percent_loc(l) ffebld_new_one(FFEBLD_opPERCENT_LOC,(l))
-#define ffebld_new_percent_ref(l) ffebld_new_one(FFEBLD_opPERCENT_REF,(l))
-#define ffebld_new_percent_val(l) ffebld_new_one(FFEBLD_opPERCENT_VAL,(l))
-#define ffebld_new_complex(l,r) ffebld_new_two(FFEBLD_opCOMPLEX,(l),(r))
-#define ffebld_new_convert(l) ffebld_new_one(FFEBLD_opCONVERT,(l))
-#define ffebld_new_funcref(l,r) ffebld_new_two(FFEBLD_opFUNCREF,(l),(r))
-#define ffebld_new_subrref(l,r) ffebld_new_two(FFEBLD_opSUBRREF,(l),(r))
-#define ffebld_new_arrayref(l,r) ffebld_new_two(FFEBLD_opARRAYREF,(l),(r))
-#define ffebld_new_substr(l,r) ffebld_new_two(FFEBLD_opSUBSTR,(l),(r))
-#define ffebld_new_impdo(l,r) ffebld_new_two(FFEBLD_opIMPDO,(l),(r))
-#define ffebld_nonter_hook(b) ((b)->u.nonter.hook)
-#define ffebld_nonter_set_hook(b,h) ((b)->u.nonter.hook = (h))
-#define ffebld_op(b) ((b)->op)
-#define ffebld_pool() (ffebld_pool_stack_.pool)
-#define ffebld_rank(b) (ffeinfo_rank (ffebld_info ((b))))
-#define ffebld_right(b) ((b)->u.nonter.right)
-#define ffebld_set_accter(b,a) ((b)->u.accter.array = (a))
-#define ffebld_set_arrter(b,a) ((b)->u.arrter.array = (a))
-#define ffebld_set_conter(b,c) ((b)->u.conter.expr = (c))
-#define ffebld_set_info(b,i) ((b)->info = (i))
-#define ffebld_set_labter(b,l) ((b)->u.labter = (l))
-#define ffebld_set_op(b,o) ((b)->op = (o))
-#define ffebld_set_head(b,h) ((b)->u.item.head = (h))
-#define ffebld_set_left(b,l) ((b)->u.nonter.left = (l))
-#define ffebld_set_right(b,r) ((b)->u.nonter.right = (r))
-#define ffebld_set_trail(b,t) ((b)->u.item.trail = (t))
-#define ffebld_size(b) (ffeinfo_size (ffebld_info ((b))))
-#define ffebld_size_known(b) ffebld_size((b))
-#define ffebld_symter(b) ((b)->u.symter.symbol)
-#define ffebld_symter_generic(b) ((b)->u.symter.generic)
-#define ffebld_symter_doiter(b) ((b)->u.symter.do_iter)
-#define ffebld_symter_implementation(b) ((b)->u.symter.implementation)
-#define ffebld_symter_specific(b) ((b)->u.symter.specific)
-#define ffebld_symter_set_generic(b,g) ((b)->u.symter.generic = (g))
-#define ffebld_symter_set_implementation(b,i) \
- ((b)->u.symter.implementation = (i))
-#define ffebld_symter_set_is_doiter(b,f) ((b)->u.symter.do_iter = (f))
-#define ffebld_symter_set_specific(b,s) ((b)->u.symter.specific = (s))
-#define ffebld_terminate_0()
-#define ffebld_terminate_1()
-#define ffebld_terminate_2()
-#define ffebld_terminate_3()
-#define ffebld_terminate_4()
-#define ffebld_trail(b) ((b)->u.item.trail)
-#define ffebld_where(b) (ffeinfo_where (ffebld_info ((b))))
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_BLD_H */
+++ /dev/null
-@c Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
-@c This is part of the G77 manual.
-@c For copying conditions, see the file g77.texi.
-
-@c The text of this file appears in the file BUGS
-@c in the G77 distribution, as well as in the G77 manual.
-
-@c Keep this the same as the dates above, since it's used
-@c in the standalone derivations of this file (e.g. BUGS).
-@set copyrights-bugs 1995,1996,1997,1998,1999,2000,2001,2002,2004
-
-@set last-update-bugs 2004-05-18
-
-@ifset DOC-BUGS
-@include root.texi
-@c The immediately following lines apply to the BUGS file
-@c which is derived from this file.
-@emph{Note:} This file is automatically generated from the files
-@file{bugs0.texi} and @file{bugs.texi}.
-@file{BUGS} is @emph{not} a source file,
-although it is normally included within source distributions.
-
-This file lists known bugs in the @value{which-g77} version
-of the GNU Fortran compiler.
-Copyright (C) @value{copyrights-bugs} Free Software Foundation, Inc.
-You may copy, distribute, and modify it freely as long as you preserve
-this copyright notice and permission notice.
-
-@node Top,,, (dir)
-@chapter Known Bugs In GNU Fortran
-@end ifset
-
-@ifset DOC-G77
-@node Known Bugs
-@section Known Bugs In GNU Fortran
-@end ifset
-
-This section identifies bugs that @code{g77} @emph{users}
-might run into in the @value{which-g77} version
-of @code{g77}.
-This includes bugs that are actually in the @code{gcc}
-back end (GBE) or in @code{libf2c}, because those
-sets of code are at least somewhat under the control
-of (and necessarily intertwined with) @code{g77},
-so it isn't worth separating them out.
-
-@ifset DOC-G77
-For information on bugs in @emph{other} versions of @code{g77},
-see @ref{News,,News About GNU Fortran}.
-There, lists of bugs fixed in various versions of @code{g77}
-can help determine what bugs existed in prior versions.
-@end ifset
-
-@ifset DOC-BUGS
-For information on bugs in @emph{other} versions of @code{g77},
-see @file{@value{path-g77}/NEWS}.
-There, lists of bugs fixed in various versions of @code{g77}
-can help determine what bugs existed in prior versions.
-@end ifset
-
-@ifset DEVELOPMENT
-@emph{Warning:} The information below is still under development,
-and might not accurately reflect the @code{g77} code base
-of which it is a part.
-Efforts are made to keep it somewhat up-to-date,
-but they are particularly concentrated
-on any version of this information
-that is distributed as part of a @emph{released} @code{g77}.
-
-In particular, while this information is intended to apply to
-the @value{which-g77} version of @code{g77},
-only an official @emph{release} of that version
-is expected to contain documentation that is
-most consistent with the @code{g77} product in that version.
-@end ifset
-
-The following information was last updated on @value{last-update-bugs}:
-
-@itemize @bullet
-@item
-@code{g77} fails to warn about
-use of a ``live'' iterative-DO variable
-as an implied-DO variable
-in a @code{WRITE} or @code{PRINT} statement
-(although it does warn about this in a @code{READ} statement).
-
-@item
-Something about @code{g77}'s straightforward handling of
-label references and definitions sometimes prevents the GBE
-from unrolling loops.
-Until this is solved, try inserting or removing @code{CONTINUE}
-statements as the terminal statement, using the @code{END DO}
-form instead, and so on.
-
-@item
-Some confusion in diagnostics concerning failing @code{INCLUDE}
-statements from within @code{INCLUDE}'d or @code{#include}'d files.
-
-@cindex integer constants
-@cindex constants, integer
-@item
-@code{g77} assumes that @code{INTEGER(KIND=1)} constants range
-from @samp{-2**31} to @samp{2**31-1} (the range for
-two's-complement 32-bit values),
-instead of determining their range from the actual range of the
-type for the configuration (and, someday, for the constant).
-
-Further, it generally doesn't implement the handling
-of constants very well in that it makes assumptions about the
-configuration that it no longer makes regarding variables (types).
-
-Included with this item is the fact that @code{g77} doesn't recognize
-that, on IEEE-754/854-compliant systems, @samp{0./0.} should produce a NaN
-and no warning instead of the value @samp{0.} and a warning.
-
-@cindex compiler speed
-@cindex speed, of compiler
-@cindex compiler memory usage
-@cindex memory usage, of compiler
-@cindex large aggregate areas
-@cindex initialization, bug
-@cindex DATA statement
-@cindex statements, DATA
-@item
-@code{g77} uses way too much memory and CPU time to process large aggregate
-areas having any initialized elements.
-
-For example, @samp{REAL A(1000000)} followed by @samp{DATA A(1)/1/}
-takes up way too much time and space, including
-the size of the generated assembler file.
-
-Version 0.5.18 improves cases like this---specifically,
-cases of @emph{sparse} initialization that leave large, contiguous
-areas uninitialized---significantly.
-However, even with the improvements, these cases still
-require too much memory and CPU time.
-
-(Version 0.5.18 also improves cases where the initial values are
-zero to a much greater degree, so if the above example
-ends with @samp{DATA A(1)/0/}, the compile-time performance
-will be about as good as it will ever get, aside from unrelated
-improvements to the compiler.)
-
-Note that @code{g77} does display a warning message to
-notify the user before the compiler appears to hang.
-@ifset DOC-G77
-A warning message is issued when @code{g77} sees code that provides
-initial values (e.g. via @code{DATA}) to an aggregate area (@code{COMMON}
-or @code{EQUIVALENCE}, or even a large enough array or @code{CHARACTER}
-variable)
-that is large enough to increase @code{g77}'s compile time by roughly
-a factor of 10.
-
-This size currently is quite small, since @code{g77}
-currently has a known bug requiring too much memory
-and time to handle such cases.
-In @file{@value{path-g77}/data.c}, the macro
-@code{FFEDATA_sizeTOO_BIG_INIT_} is defined
-to the minimum size for the warning to appear.
-The size is specified in storage units,
-which can be bytes, words, or whatever, on a case-by-case basis.
-
-After changing this macro definition, you must
-(of course) rebuild and reinstall @code{g77} for
-the change to take effect.
-
-Note that, as of version 0.5.18, improvements have
-reduced the scope of the problem for @emph{sparse}
-initialization of large arrays, especially those
-with large, contiguous uninitialized areas.
-However, the warning is issued at a point prior to
-when @code{g77} knows whether the initialization is sparse,
-and delaying the warning could mean it is produced
-too late to be helpful.
-
-Therefore, the macro definition should not be adjusted to
-reflect sparse cases.
-Instead, adjust it to generate the warning when densely
-initialized arrays begin to cause responses noticeably slower
-than linear performance would suggest.
-@end ifset
-
-@cindex code, displaying main source
-@cindex displaying main source code
-@cindex debugging main source code
-@cindex printing main source
-@item
-When debugging, after starting up the debugger but before being able
-to see the source code for the main program unit, the user must currently
-set a breakpoint at @code{MAIN__} (or @code{MAIN___} or @code{MAIN_} if
-@code{MAIN__} doesn't exist)
-and run the program until it hits the breakpoint.
-At that point, the
-main program unit is activated and about to execute its first
-executable statement, but that's the state in which the debugger should
-start up, as is the case for languages like C.
-
-@cindex debugger
-@item
-Debugging @code{g77}-compiled code using debuggers other than
-@code{gdb} is likely not to work.
-
-Getting @code{g77} and @code{gdb} to work together is a known
-problem---getting @code{g77} to work properly with other
-debuggers, for which source code often is unavailable to @code{g77}
-developers, seems like a much larger, unknown problem,
-and is a lower priority than making @code{g77} and @code{gdb}
-work together properly.
-
-On the other hand, information about problems other debuggers
-have with @code{g77} output might make it easier to properly
-fix @code{g77}, and perhaps even improve @code{gdb}, so it
-is definitely welcome.
-Such information might even lead to all relevant products
-working together properly sooner.
-
-@cindex Alpha, support
-@cindex support, Alpha
-@item
-@code{g77} doesn't work perfectly on 64-bit configurations
-such as the Digital Semiconductor (``DEC'') Alpha.
-
-This problem is largely resolved as of version 0.5.23.
-
-@cindex padding
-@cindex structures
-@cindex common blocks
-@cindex equivalence areas
-@item
-@code{g77} currently inserts needless padding for things like
-@samp{COMMON A,IPAD} where @samp{A} is @code{CHARACTER*1} and @samp{IPAD}
-is @code{INTEGER(KIND=1)} on machines like x86,
-because the back end insists that @samp{IPAD}
-be aligned to a 4-byte boundary,
-but the processor has no such requirement
-(though it is usually good for performance).
-
-The @code{gcc} back end needs to provide a wider array
-of specifications of alignment requirements and preferences for targets,
-and front ends like @code{g77} should take advantage of this
-when it becomes available.
-
-@cindex complex performance
-@cindex aliasing
-@item
-The @code{libf2c} routines that perform some run-time
-arithmetic on @code{COMPLEX} operands
-were modified circa version 0.5.20 of @code{g77}
-to work properly even in the presence of aliased operands.
-
-While the @code{g77} and @code{netlib} versions of @code{libf2c}
-differ on how this is accomplished,
-the main differences are that we believe
-the @code{g77} version works properly
-even in the presence of @emph{partially} aliased operands.
-
-However, these modifications have reduced performance
-on targets such as x86,
-due to the extra copies of operands involved.
-@end itemize
+++ /dev/null
-\input texinfo @c -*-texinfo-*-
-@c %**start of header
-@setfilename BUGS
-@c %**end of header
-
-@c This tells bugs.texi that it's generating just the BUGS file.
-@set DOC-BUGS
-@include bugs.texi
-@bye
+++ /dev/null
-/* com-rt.def -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- com.c
-
- Modifications:
-*/
-
-/* DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX,CONST):
-
- CODE -- the #define name to use to refer to the function in g77 code
-
- NAME -- the name as seen by the back end and, with whatever massaging
- is normal, the linker
-
- TYPE -- a code for the tree for the type, assigned when first encountered
- (NOTE: There's a distinction made between the semantic return
- value for the function, and the actual return mechanism; e.g.
- `r_abs()' computes a single-precision `float' return value
- but returns it as a `double'. This distinction is important
- and is flagged via the _F2C_ versus _GNU_ suffix.)
-
- ARGS -- a string of codes representing the types of the arguments; the
- last type specifies the type for that and all following args,
- and the null pointer (0) means the same as "0":
-
- 0 Not applicable at and beyond this point
- & Pointer to type that follows
- a char
- c complex
- d doublereal
- e doublecomplex
- f real
- i integer
- j longint
-
- VOLATILE -- TRUE if the function never returns (gen's emit_barrier in
- g77 back end)
-
- COMPLEX -- TRUE if the return value is COMPLEX or DOUBLE COMPLEX and
- thus might need to be returned as ptr-to-1st-arg
-
- CONST -- TRUE if the function is const
- (does not have side effects and only depends on its arguments).
-
-*/
-
-DEFGFRT (FFECOM_gfrtCAT, "s_cat", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCMP, "s_cmp", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCOPY, "s_copy", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtPAUSE, "s_paus", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSTOP, "s_stop", FFECOM_rttypeVOID_, 0, TRUE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtRANGE, "s_rnge", FFECOM_rttypeINTEGER_, 0, TRUE, FALSE, FALSE)
-
-DEFGFRT (FFECOM_gfrtSRDUE, "s_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERDUE, "e_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRSUE, "s_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERSUE, "e_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRDFE, "s_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERDFE, "e_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRSFI, "s_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERSFI, "e_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRSFE, "s_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERSFE, "e_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRSLI, "s_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERSLI, "e_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRSLE, "s_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERSLE, "e_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRSNE, "s_rsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-
-DEFGFRT (FFECOM_gfrtSWDUE, "s_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEWDUE, "e_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSWSUE, "s_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEWSUE, "e_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSWDFE, "s_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEWDFE, "e_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSWSFI, "s_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEWSFI, "e_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSWSFE, "s_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEWSFE, "e_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSWSLI, "s_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEWSLI, "e_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSWSLE, "s_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEWSLE, "e_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSWSNE, "s_wsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-
-DEFGFRT (FFECOM_gfrtDOFIO, "do_fio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDOLIO, "do_lio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDOUIO, "do_uio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-
-DEFGFRT (FFECOM_gfrtFOPEN, "f_open", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFCLOS, "f_clos", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFINQU, "f_inqu", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-
-DEFGFRT (FFECOM_gfrtFBACK, "f_back", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFEND, "f_end", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFREW, "f_rew", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-
-DEFGFRT (FFECOM_gfrtABORT, "G77_abort_0", FFECOM_rttypeVOID_, 0, TRUE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtABS, "r_abs", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtACCESS, "G77_access_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtACOS, "r_acos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtAIMAG, "r_imag", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtAINT, "r_int", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtALARM, "G77_alarm_0", FFECOM_rttypeINTEGER_, "&i0", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtALOG, "r_log", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtALOG10, "r_lg10", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtAMOD, "r_mod", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtANINT, "r_nint", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtASIN, "r_asin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtATAN, "r_atan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtATAN2, "r_atn2", FFECOM_rttypeREAL_F2C_, "&f&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCABS, "c_abs", FFECOM_rttypeREAL_F2C_, "&c", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCCOS, "c_cos", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCEXP, "c_exp", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCHDIR, "G77_chdir_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCLOG, "c_log", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCHMOD, "G77_chmod_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCONJG, "r_cnjg", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCOS, "r_cos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCOSH, "r_cosh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCSIN, "c_sin", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCSQRT, "c_sqrt", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCTIME, "G77_ctime_0", FFECOM_rttypeCHARACTER_, "&j", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDABS, "d_abs", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDACOS, "d_acos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDASIN, "d_asin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDATAN, "d_atan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDATAN2, "d_atn2", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDATE, "G77_date_y2kbug_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDATE_AND_TIME, "G77_date_and_time_0", FFECOM_rttypeVOID_, "&a&a&a&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtL_BESJ0, "j0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_BESJ1, "j1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_BESJN, "jn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_BESY0, "y0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_BESY1, "y1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_BESYN, "yn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtDCOS, "d_cos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDCOSH, "d_cosh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDDIM, "d_dim", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDERF, "G77_derf_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDERFC, "G77_derfc_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDEXP, "d_exp", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDIM, "r_dim", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDINT, "d_int", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDLOG, "d_log", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDLOG10, "d_lg10", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDMOD, "d_mod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDNINT, "d_nint", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDPROD, "d_prod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDSIGN, "d_sign", FFECOM_rttypeDOUBLE_, "&d&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDSIN, "d_sin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDSINH, "d_sinh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDSQRT, "d_sqrt", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDTAN, "d_tan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDTANH, "d_tanh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtDTIME, "G77_dtime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERF, "G77_erf_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtERFC, "G77_erfc_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtETIME, "G77_etime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEXIT, "G77_exit_0", FFECOM_rttypeVOID_, "&i", TRUE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtEXP, "r_exp", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFDATE, "G77_fdate_0", FFECOM_rttypeCHARACTER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFGET, "G77_fget_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFGETC, "G77_fgetc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFLUSH, "G77_flush_0", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFLUSH1, "G77_flush1_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFNUM, "G77_fnum_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFPUT, "G77_fput_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFPUTC, "G77_fputc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFSTAT, "G77_fstat_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFTELL, "G77_ftell_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtFSEEK, "G77_fseek_0", FFECOM_rttypeINTEGER_, "&i&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGERROR, "G77_gerror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGETARG, "G77_getarg_0", FFECOM_rttypeVOID_, "&i&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGETCWD, "G77_getcwd_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGETGID, "G77_getgid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGETLOG, "G77_getlog_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGETPID, "G77_getpid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGETUID, "G77_getuid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGETENV, "G77_getenv_0", FFECOM_rttypeVOID_, "&a&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtGMTIME, "G77_gmtime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtHOSTNM, "G77_hostnm_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtIABS, "i_abs", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtIARGC, "G77_iargc_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtIDATE, "G77_idate_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtIDIM, "i_dim", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtIDNINT, "i_dnnt", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtIERRNO, "G77_ierrno_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtINDEX, "i_indx", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtIRAND, "G77_irand_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtISIGN, "i_sign", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtISATTY, "G77_isatty_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtITIME, "G77_itime_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtKILL, "G77_kill_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLEN, "i_len", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtLGE, "l_ge", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLGT, "l_gt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLINK, "G77_link_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLLE, "l_le", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLLT, "l_lt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLNBLNK, "G77_lnblnk_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLSTAT, "G77_lstat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtLTIME, "G77_ltime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtMCLOCK, "G77_mclock_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtMOD, "i_mod", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtNINT, "i_nint", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtPERROR, "G77_perror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtRAND, "G77_rand_0", FFECOM_rttypeREAL_F2C_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtRENAME, "G77_rename_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSECNDS, "G77_secnds_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSECOND, "G77_second_0", FFECOM_rttypeREAL_F2C_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSIGN, "r_sign", FFECOM_rttypeREAL_F2C_, "&f&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtL_SIGNAL, "G77_signal_0", FFECOM_rttypeVOIDSTAR_, "&i0", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSIN, "r_sin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSINH, "r_sinh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSLEEP, "G77_sleep_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSQRT, "r_sqrt", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSRAND, "G77_srand_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSTAT, "G77_stat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSYMLNK, "G77_symlnk_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSYSTEM, "G77_system_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtSYSTEM_CLOCK, "G77_system_clock_0", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtTAN, "r_tan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtTANH, "r_tanh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtTIME, "G77_time_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtTTYNAM, "G77_ttynam_0", FFECOM_rttypeCHARACTER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtUNLINK, "G77_unlink_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtUMASK, "G77_umask_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtVXTIDATE, "G77_vxtidate_y2kbug_0", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtVXTTIME, "G77_vxttime_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCDABS, "z_abs", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtCDCOS, "z_cos", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCDEXP, "z_exp", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCDLOG, "z_log", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtDCONJG, "d_cnjg", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCDSIN, "z_sin", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtCDSQRT, "z_sqrt", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtDIMAG, "d_imag", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE, FALSE)
-
-DEFGFRT (FFECOM_gfrtL_ACOS, "acos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_ASIN, "asin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_ATAN, "__builtin_atan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_ATAN2, "__builtin_atan2", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_COS, "__builtin_cos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_COSH, "cosh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_ERF, "erf", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_ERFC, "erfc", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_EXP, "__builtin_exp", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_FLOOR, "__builtin_floor", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_FMOD, "__builtin_fmod", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_LOG, "__builtin_log", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_LOG10, "log10", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_POW, "__builtin_pow", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_SIN, "__builtin_sin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_SINH, "sinh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_SQRT, "__builtin_sqrt", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_TAN, "__builtin_tan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-DEFGFRT (FFECOM_gfrtL_TANH, "tanh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
-
-DEFGFRT (FFECOM_gfrtPOW_CI, "pow_ci", FFECOM_rttypeCOMPLEX_F2C_, "&c&i", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtPOW_DD, "pow_dd", FFECOM_rttypeDOUBLE_, "&d&d", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtPOW_DI, "pow_di", FFECOM_rttypeDOUBLE_, "&d&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtPOW_II, "pow_ii", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtPOW_QQ, "pow_qq", FFECOM_rttypeLONGINT_, "&j&j", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtPOW_RI, "pow_ri", FFECOM_rttypeREAL_F2C_, "&f&i", FALSE, FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtPOW_ZI, "pow_zi", FFECOM_rttypeDBLCMPLX_F2C_, "&e&i", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtPOW_ZZ, "pow_zz", FFECOM_rttypeDBLCMPLX_F2C_, "&e&e", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtDIV_CC, "c_div", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
-DEFGFRT (FFECOM_gfrtDIV_ZZ, "z_div", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
+++ /dev/null
-/* com.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
- Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None
-
- Description:
- Contains compiler-specific functions.
-
- Modifications:
-*/
-
-/* Understanding this module means understanding the interface between
- the g77 front end and the gcc back end (or, perhaps, some other
- back end). In here are the functions called by the front end proper
- to notify whatever back end is in place about certain things, and
- also the back-end-specific functions. It's a bear to deal with, so
- lately I've been trying to simplify things, especially with regard
- to the gcc-back-end-specific stuff.
-
- Building expressions generally seems quite easy, but building decls
- has been challenging and is undergoing revision. gcc has several
- kinds of decls:
-
- TYPE_DECL -- a type (int, float, struct, function, etc.)
- CONST_DECL -- a constant of some type other than function
- LABEL_DECL -- a variable or a constant?
- PARM_DECL -- an argument to a function (a variable that is a dummy)
- RESULT_DECL -- the return value of a function (a variable)
- VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
- FUNCTION_DECL -- a function (either the actual function or an extern ref)
- FIELD_DECL -- a field in a struct or union (goes into types)
-
- g77 has a set of functions that somewhat parallels the gcc front end
- when it comes to building decls:
-
- Internal Function (one we define, not just declare as extern):
- if (is_nested) push_f_function_context ();
- start_function (get_identifier ("function_name"), function_type,
- is_nested, is_public);
- // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
- store_parm_decls (is_main_program);
- ffecom_start_compstmt ();
- // for stmts and decls inside function, do appropriate things;
- ffecom_end_compstmt ();
- finish_function (is_nested);
- if (is_nested) pop_f_function_context ();
-
- Everything Else:
- tree d;
- tree init;
- // fill in external, public, static, &c for decl, and
- // set DECL_INITIAL to error_mark_node if going to initialize
- // set is_top_level TRUE only if not at top level and decl
- // must go in top level (i.e. not within current function decl context)
- d = start_decl (decl, is_top_level);
- init = ...; // if have initializer
- finish_decl (d, init, is_top_level);
-
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "flags.h"
-#include "real.h"
-#include "rtl.h"
-#include "toplev.h"
-#include "tree.h"
-#include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
-#include "convert.h"
-#include "ggc.h"
-#include "diagnostic.h"
-#include "intl.h"
-#include "langhooks.h"
-#include "langhooks-def.h"
-#include "debug.h"
-
-/* VMS-specific definitions */
-#ifdef VMS
-#include <descrip.h>
-#define O_RDONLY 0 /* Open arg for Read/Only */
-#define O_WRONLY 1 /* Open arg for Write/Only */
-#define read(fd,buf,size) VMS_read (fd,buf,size)
-#define write(fd,buf,size) VMS_write (fd,buf,size)
-#define open(fname,mode,prot) VMS_open (fname,mode,prot)
-#define fopen(fname,mode) VMS_fopen (fname,mode)
-#define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
-#define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
-#define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
-static int VMS_fstat (), VMS_stat ();
-static char * VMS_strncat ();
-static int VMS_read ();
-static int VMS_write ();
-static int VMS_open ();
-static FILE * VMS_fopen ();
-static FILE * VMS_freopen ();
-static void hack_vms_include_specification ();
-typedef struct { unsigned :16, :16, :16; } vms_ino_t;
-#define ino_t vms_ino_t
-#define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
-#endif /* VMS */
-
-#define FFECOM_DETERMINE_TYPES 1 /* for com.h */
-#include "com.h"
-#include "bad.h"
-#include "bld.h"
-#include "equiv.h"
-#include "expr.h"
-#include "implic.h"
-#include "info.h"
-#include "malloc.h"
-#include "src.h"
-#include "st.h"
-#include "storag.h"
-#include "symbol.h"
-#include "target.h"
-#include "top.h"
-#include "type.h"
-
-/* Externals defined here. */
-
-/* Stream for reading from the input file. */
-FILE *finput;
-
-/* These definitions parallel those in c-decl.c so that code from that
- module can be used pretty much as is. Much of these defs aren't
- otherwise used, i.e. by g77 code per se, except some of them are used
- to build some of them that are. The ones that are global (i.e. not
- "static") are those that ste.c and such might use (directly
- or by using com macros that reference them in their definitions). */
-
-tree string_type_node;
-
-/* The rest of these are inventions for g77, though there might be
- similar things in the C front end. As they are found, these
- inventions should be renamed to be canonical. Note that only
- the ones currently required to be global are so. */
-
-static GTY(()) tree ffecom_tree_fun_type_void;
-
-tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
-tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
-tree ffecom_integer_one_node; /* " */
-tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
-
-/* _fun_type things are the f2c-specific versions. For -fno-f2c,
- just use build_function_type and build_pointer_type on the
- appropriate _tree_type array element. */
-
-static GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
-static GTY(()) tree
- ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
-static GTY(()) tree ffecom_tree_subr_type;
-static GTY(()) tree ffecom_tree_ptr_to_subr_type;
-static GTY(()) tree ffecom_tree_blockdata_type;
-
-static GTY(()) tree ffecom_tree_xargc_;
-
-ffecomSymbol ffecom_symbol_null_
-=
-{
- NULL_TREE,
- NULL_TREE,
- NULL_TREE,
- NULL_TREE,
- false
-};
-ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
-ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
-
-int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
-tree ffecom_f2c_integer_type_node;
-static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node;
-tree ffecom_f2c_address_type_node;
-tree ffecom_f2c_real_type_node;
-static GTY(()) tree ffecom_f2c_ptr_to_real_type_node;
-tree ffecom_f2c_doublereal_type_node;
-tree ffecom_f2c_complex_type_node;
-tree ffecom_f2c_doublecomplex_type_node;
-tree ffecom_f2c_longint_type_node;
-tree ffecom_f2c_logical_type_node;
-tree ffecom_f2c_flag_type_node;
-tree ffecom_f2c_ftnlen_type_node;
-tree ffecom_f2c_ftnlen_zero_node;
-tree ffecom_f2c_ftnlen_one_node;
-tree ffecom_f2c_ftnlen_two_node;
-tree ffecom_f2c_ptr_to_ftnlen_type_node;
-tree ffecom_f2c_ftnint_type_node;
-tree ffecom_f2c_ptr_to_ftnint_type_node;
-
-/* Simple definitions and enumerations. */
-
-#ifndef FFECOM_sizeMAXSTACKITEM
-#define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
- larger than this # bytes
- off stack if possible. */
-#endif
-
-/* For systems that have large enough stacks, they should define
- this to 0, and here, for ease of use later on, we just undefine
- it if it is 0. */
-
-#if FFECOM_sizeMAXSTACKITEM == 0
-#undef FFECOM_sizeMAXSTACKITEM
-#endif
-
-typedef enum
- {
- FFECOM_rttypeVOID_,
- FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
- FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
- FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */
- FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */
- FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */
- FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
- FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
- FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */
- FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */
- FFECOM_rttypeDOUBLE_, /* C's `double' type. */
- FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
- FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
- FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
- FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */
- FFECOM_rttype_
- } ffecomRttype_;
-
-/* Internal typedefs. */
-
-typedef struct _ffecom_concat_list_ ffecomConcatList_;
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-struct _ffecom_concat_list_
- {
- ffebld *exprs;
- int count;
- int max;
- ffetargetCharacterSize minlen;
- ffetargetCharacterSize maxlen;
- };
-
-/* Static functions (internal). */
-
-static tree ffe_type_for_mode (enum machine_mode, int);
-static tree ffe_type_for_size (unsigned int, int);
-static tree ffe_unsigned_type (tree);
-static tree ffe_signed_type (tree);
-static tree ffe_signed_or_unsigned_type (int, tree);
-static bool ffe_mark_addressable (tree);
-static tree ffe_truthvalue_conversion (tree);
-static void ffecom_init_decl_processing (void);
-static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
-static tree ffecom_widest_expr_type_ (ffebld list);
-static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
- tree dest_size, tree source_tree,
- ffebld source, bool scalar_arg);
-static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
- tree args, tree callee_commons,
- bool scalar_args);
-static tree ffecom_build_f2c_string_ (int i, const char *s);
-static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
- bool is_f2c_complex, tree type,
- tree args, tree dest_tree,
- ffebld dest, bool *dest_used,
- tree callee_commons, bool scalar_args, tree hook);
-static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
- bool is_f2c_complex, tree type,
- ffebld left, ffebld right,
- tree dest_tree, ffebld dest,
- bool *dest_used, tree callee_commons,
- bool scalar_args, bool ref, tree hook);
-static void ffecom_char_args_x_ (tree *xitem, tree *length,
- ffebld expr, bool with_null);
-static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
-static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
-static ffecomConcatList_
- ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
- ffebld expr,
- ffetargetCharacterSize max);
-static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
-static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
- ffetargetCharacterSize max);
-static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
- ffesymbol member, tree member_type,
- ffetargetOffset offset);
-static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
-static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
- bool *dest_used, bool assignp, bool widenp);
-static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
- ffebld dest, bool *dest_used);
-static tree ffecom_expr_power_integer_ (ffebld expr);
-static void ffecom_expr_transform_ (ffebld expr);
-static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
-static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
- int code);
-static ffeglobal ffecom_finish_global_ (ffeglobal global);
-static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
-static tree ffecom_get_appended_identifier_ (char us, const char *text);
-static tree ffecom_get_external_identifier_ (ffesymbol s);
-static tree ffecom_get_identifier_ (const char *text);
-static tree ffecom_gen_sfuncdef_ (ffesymbol s,
- ffeinfoBasictype bt,
- ffeinfoKindtype kt);
-static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
-static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
-static tree ffecom_init_zero_ (tree decl);
-static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
- tree *maybe_tree);
-static tree ffecom_intrinsic_len_ (ffebld expr);
-static void ffecom_let_char_ (tree dest_tree,
- tree dest_length,
- ffetargetCharacterSize dest_size,
- ffebld source);
-static void ffecom_make_gfrt_ (ffecomGfrt ix);
-static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
-static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
-static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
- ffebld source);
-static void ffecom_push_dummy_decls_ (ffebld dumlist,
- bool stmtfunc);
-static void ffecom_start_progunit_ (void);
-static ffesymbol ffecom_sym_transform_ (ffesymbol s);
-static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
-static void ffecom_transform_common_ (ffesymbol s);
-static void ffecom_transform_equiv_ (ffestorag st);
-static tree ffecom_transform_namelist_ (ffesymbol s);
-static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
- tree t);
-static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
- tree *size, tree tree);
-static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
- tree dest_tree, ffebld dest,
- bool *dest_used, tree hook);
-static tree ffecom_type_localvar_ (ffesymbol s,
- ffeinfoBasictype bt,
- ffeinfoKindtype kt);
-static tree ffecom_type_namelist_ (void);
-static tree ffecom_type_vardesc_ (void);
-static tree ffecom_vardesc_ (ffebld expr);
-static tree ffecom_vardesc_array_ (ffesymbol s);
-static tree ffecom_vardesc_dims_ (ffesymbol s);
-static tree ffecom_convert_narrow_ (tree type, tree expr);
-static tree ffecom_convert_widen_ (tree type, tree expr);
-
-/* These are static functions that parallel those found in the C front
- end and thus have the same names. */
-
-static tree bison_rule_compstmt_ (void);
-static void bison_rule_pushlevel_ (void);
-static void delete_block (tree block);
-static int duplicate_decls (tree newdecl, tree olddecl);
-static void finish_decl (tree decl, tree init, bool is_top_level);
-static void finish_function (int nested);
-static const char *ffe_printable_name (tree decl, int v);
-static void ffe_print_error_function (diagnostic_context *, const char *);
-static tree lookup_name_current_level (tree name);
-static struct f_binding_level *make_binding_level (void);
-static void pop_f_function_context (void);
-static void push_f_function_context (void);
-static void push_parm_decl (tree parm);
-static tree pushdecl_top_level (tree decl);
-static int kept_level_p (void);
-static tree storedecls (tree decls);
-static void store_parm_decls (int is_main_program);
-static tree start_decl (tree decl, bool is_top_level);
-static void start_function (tree name, tree type, int nested, int public);
-static void ffecom_file_ (const char *name);
-static void ffecom_close_include_ (FILE *f);
-static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
- ffewhereColumn c);
-
-/* Static objects accessed by functions in this module. */
-
-static ffesymbol ffecom_primary_entry_ = NULL;
-static ffesymbol ffecom_nested_entry_ = NULL;
-static ffeinfoKind ffecom_primary_entry_kind_;
-static bool ffecom_primary_entry_is_proc_;
-static GTY(()) tree ffecom_outer_function_decl_;
-static GTY(()) tree ffecom_previous_function_decl_;
-static GTY(()) tree ffecom_which_entrypoint_decl_;
-static GTY(()) tree ffecom_float_zero_;
-static GTY(()) tree ffecom_float_half_;
-static GTY(()) tree ffecom_double_zero_;
-static GTY(()) tree ffecom_double_half_;
-static GTY(()) tree ffecom_func_result_;/* For functions. */
-static GTY(()) tree ffecom_func_length_;/* For CHARACTER fns. */
-static ffebld ffecom_list_blockdata_;
-static ffebld ffecom_list_common_;
-static ffebld ffecom_master_arglist_;
-static ffeinfoBasictype ffecom_master_bt_;
-static ffeinfoKindtype ffecom_master_kt_;
-static ffetargetCharacterSize ffecom_master_size_;
-static int ffecom_num_fns_ = 0;
-static int ffecom_num_entrypoints_ = 0;
-static bool ffecom_is_altreturning_ = FALSE;
-static GTY(()) tree ffecom_multi_type_node_;
-static GTY(()) tree ffecom_multi_retval_;
-static GTY(()) tree
- ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
-static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
-static bool ffecom_doing_entry_ = FALSE;
-static bool ffecom_transform_only_dummies_ = FALSE;
-static int ffecom_typesize_pointer_;
-static int ffecom_typesize_integer1_;
-
-/* Holds pointer-to-function expressions. */
-
-static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];
-
-/* Holds the external names of the functions. */
-
-static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
-=
-{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
-#include "com-rt.def"
-#undef DEFGFRT
-};
-
-/* Whether the function returns. */
-
-static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
-=
-{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
-#include "com-rt.def"
-#undef DEFGFRT
-};
-
-/* Whether the function returns type complex. */
-
-static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
-=
-{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
-#include "com-rt.def"
-#undef DEFGFRT
-};
-
-/* Whether the function is const
- (i.e., has no side effects and only depends on its arguments). */
-
-static const bool ffecom_gfrt_const_[FFECOM_gfrt]
-=
-{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
-#include "com-rt.def"
-#undef DEFGFRT
-};
-
-/* Type code for the function return value. */
-
-static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
-=
-{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
-#include "com-rt.def"
-#undef DEFGFRT
-};
-
-/* String of codes for the function's arguments. */
-
-static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
-=
-{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
-#include "com-rt.def"
-#undef DEFGFRT
-};
-
-/* Internal macros. */
-
-/* We let tm.h override the types used here, to handle trivial differences
- such as the choice of unsigned int or long unsigned int for size_t.
- When machines start needing nontrivial differences in the size type,
- it would be best to do something here to figure out automatically
- from other information what type to use. */
-
-#ifndef SIZE_TYPE
-#define SIZE_TYPE "long unsigned int"
-#endif
-
-#define ffecom_concat_list_count_(catlist) ((catlist).count)
-#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
-#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
-#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
-
-#define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
-#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
-
-/* For each binding contour we allocate a binding_level structure
- * which records the names defined in that contour.
- * Contours include:
- * 0) the global one
- * 1) one for each function definition,
- * where internal declarations of the parameters appear.
- *
- * The current meaning of a name can be found by searching the levels from
- * the current one out to the global one.
- */
-
-/* Note that the information in the `names' component of the global contour
- is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
-
-struct f_binding_level GTY(())
- {
- /* A chain of _DECL nodes for all variables, constants, functions,
- and typedef types. These are in the reverse of the order supplied.
- */
- tree names;
-
- /* For each level (except not the global one),
- a chain of BLOCK nodes for all the levels
- that were entered and exited one level down. */
- tree blocks;
-
- /* The BLOCK node for this level, if one has been preallocated.
- If 0, the BLOCK is allocated (if needed) when the level is popped. */
- tree this_block;
-
- /* The binding level which this one is contained in (inherits from). */
- struct f_binding_level *level_chain;
-
- /* 0: no ffecom_prepare_* functions called at this level yet;
- 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
- 2: ffecom_prepare_end called. */
- int prep_state;
- };
-
-#define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
-
-/* The binding level currently in effect. */
-
-static GTY(()) struct f_binding_level *current_binding_level;
-
-/* A chain of binding_level structures awaiting reuse. */
-
-static GTY((deletable (""))) struct f_binding_level *free_binding_level;
-
-/* The outermost binding level, for names of file scope.
- This is created when the compiler is started and exists
- through the entire run. */
-
-static struct f_binding_level *global_binding_level;
-
-/* Binding level structures are initialized by copying this one. */
-
-static const struct f_binding_level clear_binding_level
-=
-{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
-
-/* Language-dependent contents of an identifier. */
-
-struct lang_identifier GTY(())
-{
- struct tree_identifier common;
- tree global_value;
- tree local_value;
- tree label_value;
- bool invented;
-};
-
-/* Macros for access to language-specific slots in an identifier. */
-/* Each of these slots contains a DECL node or null. */
-
-/* This represents the value which the identifier has in the
- file-scope namespace. */
-#define IDENTIFIER_GLOBAL_VALUE(NODE) \
- (((struct lang_identifier *)(NODE))->global_value)
-/* This represents the value which the identifier has in the current
- scope. */
-#define IDENTIFIER_LOCAL_VALUE(NODE) \
- (((struct lang_identifier *)(NODE))->local_value)
-/* This represents the value which the identifier has as a label in
- the current label scope. */
-#define IDENTIFIER_LABEL_VALUE(NODE) \
- (((struct lang_identifier *)(NODE))->label_value)
-/* This is nonzero if the identifier was "made up" by g77 code. */
-#define IDENTIFIER_INVENTED(NODE) \
- (((struct lang_identifier *)(NODE))->invented)
-
-/* The resulting tree type. */
-union lang_tree_node
- GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
- chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
-{
- union tree_node GTY ((tag ("0"),
- desc ("tree_node_structure (&%h)")))
- generic;
- struct lang_identifier GTY ((tag ("1"))) identifier;
-};
-
-/* Fortran doesn't use either of these. */
-struct lang_decl GTY(())
-{
-};
-struct lang_type GTY(())
-{
-};
-
-/* In identifiers, C uses the following fields in a special way:
- TREE_PUBLIC to record that there was a previous local extern decl.
- TREE_USED to record that such a decl was used.
- TREE_ADDRESSABLE to record that the address of such a decl was used. */
-
-/* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
- that have names. Here so we can clear out their names' definitions
- at the end of the function. */
-
-static GTY(()) tree named_labels;
-
-/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
-
-static GTY(()) tree shadowed_labels;
-\f
-/* Return the subscript expression, modified to do range-checking.
-
- `array' is the array type to be checked against.
- `element' is the subscript expression to check.
- `dim' is the dimension number (starting at 0).
- `total_dims' is the total number of dimensions (0 for CHARACTER substring).
- `item' is the array decl or NULL_TREE.
-*/
-
-static tree
-ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
- const char *array_name, tree item)
-{
- tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
- tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
- tree cond;
- tree die;
- tree args;
-
- if (element == error_mark_node)
- return element;
-
- if (TREE_TYPE (low) != TREE_TYPE (element))
- {
- if (TYPE_PRECISION (TREE_TYPE (low))
- > TYPE_PRECISION (TREE_TYPE (element)))
- element = convert (TREE_TYPE (low), element);
- else
- {
- low = convert (TREE_TYPE (element), low);
- if (high)
- high = convert (TREE_TYPE (element), high);
- }
- }
-
- element = ffecom_save_tree (element);
- if (total_dims == 0)
- {
- /* Special handling for substring range checks. Fortran allows the
- end subscript < begin subscript, which means that expressions like
- string(1:0) are valid (and yield a null string). In view of this,
- enforce two simpler conditions:
- 1) element<=high for end-substring;
- 2) element>=low for start-substring.
- Run-time character movement will enforce remaining conditions.
-
- More complicated checks would be better, but present structure only
- provides one index element at a time, so it is not possible to
- enforce a check of both i and j in string(i:j). If it were, the
- complete set of rules would read,
- if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
- ((low<=i<=high) && (low<=j<=high)) )
- ok ;
- else
- range error ;
- */
- if (dim)
- cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
- else
- cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
- }
- else
- {
- /* Array reference substring range checking. */
-
- cond = ffecom_2 (LE_EXPR, integer_type_node,
- low,
- element);
- if (high)
- {
- cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- cond,
- ffecom_2 (LE_EXPR, integer_type_node,
- element,
- high));
- }
- }
-
- /* If the array index is safe at compile-time, return element. */
- if (integer_nonzerop (cond))
- return element;
-
- {
- int len;
- char *proc;
- char *var;
- tree arg3;
- tree arg2;
- tree arg1;
- tree arg4;
-
- switch (total_dims)
- {
- case 0:
- var = concat (array_name, "[", (dim ? "end" : "start"),
- "-substring]", NULL);
- len = strlen (var) + 1;
- arg1 = build_string (len, var);
- free (var);
- break;
-
- case 1:
- len = strlen (array_name) + 1;
- arg1 = build_string (len, array_name);
- break;
-
- default:
- var = xmalloc (strlen (array_name) + 40);
- sprintf (var, "%s[subscript-%d-of-%d]",
- array_name,
- dim + 1, total_dims);
- len = strlen (var) + 1;
- arg1 = build_string (len, var);
- free (var);
- break;
- }
-
- TREE_TYPE (arg1)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2 (len, 0))),
- 1, 0);
- TREE_CONSTANT (arg1) = 1;
- TREE_STATIC (arg1) = 1;
- arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
- arg1);
-
- /* s_rnge adds one to the element to print it, so bias against
- that -- want to print a faithful *subscript* value. */
- arg2 = convert (ffecom_f2c_ftnint_type_node,
- ffecom_2 (MINUS_EXPR,
- TREE_TYPE (element),
- element,
- convert (TREE_TYPE (element),
- integer_one_node)));
-
- proc = concat (input_filename, "/",
- IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
- NULL);
- len = strlen (proc) + 1;
- arg3 = build_string (len, proc);
-
- free (proc);
-
- TREE_TYPE (arg3)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2 (len, 0))),
- 1, 0);
- TREE_CONSTANT (arg3) = 1;
- TREE_STATIC (arg3) = 1;
- arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
- arg3);
-
- arg4 = convert (ffecom_f2c_ftnint_type_node,
- build_int_2 (input_line, 0));
-
- arg1 = build_tree_list (NULL_TREE, arg1);
- arg2 = build_tree_list (NULL_TREE, arg2);
- arg3 = build_tree_list (NULL_TREE, arg3);
- arg4 = build_tree_list (NULL_TREE, arg4);
- TREE_CHAIN (arg3) = arg4;
- TREE_CHAIN (arg2) = arg3;
- TREE_CHAIN (arg1) = arg2;
-
- args = arg1;
- }
- die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
- args, NULL_TREE);
- TREE_SIDE_EFFECTS (die) = 1;
- die = convert (void_type_node, die);
-
- if (integer_zerop (cond) && item)
- ffe_mark_addressable (item);
-
- return ffecom_3 (COND_EXPR, TREE_TYPE (element), cond, element, die);
-}
-
-/* Return the computed element of an array reference.
-
- `item' is NULL_TREE, or the transformed pointer to the array.
- `expr' is the original opARRAYREF expression, which is transformed
- if `item' is NULL_TREE.
- `want_ptr' is nonzero if a pointer to the element, instead of
- the element itself, is to be returned. */
-
-static tree
-ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
-{
- ffebld dims[FFECOM_dimensionsMAX];
- int i;
- int total_dims;
- int flatten = ffe_is_flatten_arrays ();
- int need_ptr;
- tree array;
- tree element;
- tree tree_type;
- tree tree_type_x;
- const char *array_name;
- ffetype type;
- ffebld list;
-
- if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
- array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
- else
- array_name = "[expr?]";
-
- /* Build up ARRAY_REFs in reverse order (since we're column major
- here in Fortran land). */
-
- for (i = 0, list = ffebld_right (expr);
- list != NULL;
- ++i, list = ffebld_trail (list))
- {
- dims[i] = ffebld_head (list);
- type = ffeinfo_type (ffebld_basictype (dims[i]),
- ffebld_kindtype (dims[i]));
- if (! flatten
- && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
- && ffetype_size (type) > ffecom_typesize_integer1_)
- /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
- pointers and 32-bit integers. Do the full 64-bit pointer
- arithmetic, for codes using arrays for nonstandard heap-like
- work. */
- flatten = 1;
- }
-
- total_dims = i;
-
- need_ptr = want_ptr || flatten;
-
- if (! item)
- {
- if (need_ptr)
- item = ffecom_ptr_to_expr (ffebld_left (expr));
- else
- item = ffecom_expr (ffebld_left (expr));
-
- if (item == error_mark_node)
- return item;
-
- if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
- && ! ffe_mark_addressable (item))
- return error_mark_node;
- }
-
- if (item == error_mark_node)
- return item;
-
- if (need_ptr)
- {
- tree min;
-
- for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
- i >= 0;
- --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
- {
- min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
- element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
- if (flag_bounds_check)
- element = ffecom_subscript_check_ (array, element, i, total_dims,
- array_name, item);
- if (element == error_mark_node)
- return element;
-
- /* Widen integral arithmetic as desired while preserving
- signedness. */
- tree_type = TREE_TYPE (element);
- tree_type_x = tree_type;
- if (tree_type
- && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
- && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
- tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
-
- if (TREE_TYPE (min) != tree_type_x)
- min = convert (tree_type_x, min);
- if (TREE_TYPE (element) != tree_type_x)
- element = convert (tree_type_x, element);
-
- item = ffecom_2 (PLUS_EXPR,
- build_pointer_type (TREE_TYPE (array)),
- item,
- size_binop (MULT_EXPR,
- size_in_bytes (TREE_TYPE (array)),
- convert (sizetype,
- fold (build (MINUS_EXPR,
- tree_type_x,
- element, min)))));
- }
- if (! want_ptr)
- {
- item = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
- item);
- }
- }
- else
- {
- for (--i;
- i >= 0;
- --i)
- {
- array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
-
- element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
- if (flag_bounds_check)
- element = ffecom_subscript_check_ (array, element, i, total_dims,
- array_name, item);
- if (element == error_mark_node)
- return element;
-
- /* Widen integral arithmetic as desired while preserving
- signedness. */
- tree_type = TREE_TYPE (element);
- tree_type_x = tree_type;
- if (tree_type
- && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
- && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
- tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
-
- element = convert (tree_type_x, element);
-
- item = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
- item,
- element);
- }
- }
-
- return item;
-}
-
-/* This is like gcc's stabilize_reference -- in fact, most of the code
- comes from that -- but it handles the situation where the reference
- is going to have its subparts picked at, and it shouldn't change
- (or trigger extra invocations of functions in the subtrees) due to
- this. save_expr is a bit overzealous, because we don't need the
- entire thing calculated and saved like a temp. So, for DECLs, no
- change is needed, because these are stable aggregates, and ARRAY_REF
- and such might well be stable too, but for things like calculations,
- we do need to calculate a snapshot of a value before picking at it. */
-
-static tree
-ffecom_stabilize_aggregate_ (tree ref)
-{
- tree result;
- enum tree_code code = TREE_CODE (ref);
-
- switch (code)
- {
- case VAR_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- /* No action is needed in this case. */
- return ref;
-
- case NOP_EXPR:
- case CONVERT_EXPR:
- case FLOAT_EXPR:
- case FIX_TRUNC_EXPR:
- case FIX_FLOOR_EXPR:
- case FIX_ROUND_EXPR:
- case FIX_CEIL_EXPR:
- result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
- break;
-
- case INDIRECT_REF:
- result = build_nt (INDIRECT_REF,
- stabilize_reference_1 (TREE_OPERAND (ref, 0)));
- break;
-
- case COMPONENT_REF:
- result = build_nt (COMPONENT_REF,
- stabilize_reference (TREE_OPERAND (ref, 0)),
- TREE_OPERAND (ref, 1));
- break;
-
- case BIT_FIELD_REF:
- result = build_nt (BIT_FIELD_REF,
- stabilize_reference (TREE_OPERAND (ref, 0)),
- stabilize_reference_1 (TREE_OPERAND (ref, 1)),
- stabilize_reference_1 (TREE_OPERAND (ref, 2)));
- break;
-
- case ARRAY_REF:
- result = build_nt (ARRAY_REF,
- stabilize_reference (TREE_OPERAND (ref, 0)),
- stabilize_reference_1 (TREE_OPERAND (ref, 1)));
- break;
-
- case COMPOUND_EXPR:
- result = build_nt (COMPOUND_EXPR,
- stabilize_reference_1 (TREE_OPERAND (ref, 0)),
- stabilize_reference (TREE_OPERAND (ref, 1)));
- break;
-
- case RTL_EXPR:
- abort ();
-
-
- default:
- return save_expr (ref);
-
- case ERROR_MARK:
- return error_mark_node;
- }
-
- TREE_TYPE (result) = TREE_TYPE (ref);
- TREE_READONLY (result) = TREE_READONLY (ref);
- TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
-
- return result;
-}
-
-/* A rip-off of gcc's convert.c convert_to_complex function,
- reworked to handle complex implemented as C structures
- (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
-
-static tree
-ffecom_convert_to_complex_ (tree type, tree expr)
-{
- register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
- tree subtype;
-
- assert (TREE_CODE (type) == RECORD_TYPE);
-
- subtype = TREE_TYPE (TYPE_FIELDS (type));
-
- if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
- {
- expr = convert (subtype, expr);
- return ffecom_2 (COMPLEX_EXPR, type, expr,
- convert (subtype, integer_zero_node));
- }
-
- if (form == RECORD_TYPE)
- {
- tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
- if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
- return expr;
- else
- {
- expr = save_expr (expr);
- return ffecom_2 (COMPLEX_EXPR,
- type,
- convert (subtype,
- ffecom_1 (REALPART_EXPR,
- TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
- expr)),
- convert (subtype,
- ffecom_1 (IMAGPART_EXPR,
- TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
- expr)));
- }
- }
-
- if (form == POINTER_TYPE || form == REFERENCE_TYPE)
- error ("pointer value used where a complex was expected");
- else
- error ("aggregate value used where a complex was expected");
-
- return ffecom_2 (COMPLEX_EXPR, type,
- convert (subtype, integer_zero_node),
- convert (subtype, integer_zero_node));
-}
-
-/* Like gcc's convert(), but crashes if widening might happen. */
-
-static tree
-ffecom_convert_narrow_ (tree type, tree expr)
-{
- register tree e = expr;
- register enum tree_code code = TREE_CODE (type);
-
- if (type == TREE_TYPE (e)
- || TREE_CODE (e) == ERROR_MARK)
- return e;
- if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
- return fold (build1 (NOP_EXPR, type, e));
- if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
- || code == ERROR_MARK)
- return error_mark_node;
- if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
- {
- assert ("void value not ignored as it ought to be" == NULL);
- return error_mark_node;
- }
- assert (code != VOID_TYPE);
- if ((code != RECORD_TYPE)
- && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
- assert ("converting COMPLEX to REAL" == NULL);
- assert (code != ENUMERAL_TYPE);
- if (code == INTEGER_TYPE)
- {
- assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
- && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
- || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
- && (TYPE_PRECISION (type)
- == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
- return fold (convert_to_integer (type, e));
- }
- if (code == POINTER_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
- return fold (convert_to_pointer (type, e));
- }
- if (code == REAL_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
- assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
- return fold (convert_to_real (type, e));
- }
- if (code == COMPLEX_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
- assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
- return fold (convert_to_complex (type, e));
- }
- if (code == RECORD_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
- /* Check that at least the first field name agrees. */
- assert (DECL_NAME (TYPE_FIELDS (type))
- == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
- assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
- <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
- if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
- == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
- return e;
- return fold (ffecom_convert_to_complex_ (type, e));
- }
-
- assert ("conversion to non-scalar type requested" == NULL);
- return error_mark_node;
-}
-
-/* Like gcc's convert(), but crashes if narrowing might happen. */
-
-static tree
-ffecom_convert_widen_ (tree type, tree expr)
-{
- register tree e = expr;
- register enum tree_code code = TREE_CODE (type);
-
- if (type == TREE_TYPE (e)
- || TREE_CODE (e) == ERROR_MARK)
- return e;
- if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
- return fold (build1 (NOP_EXPR, type, e));
- if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
- || code == ERROR_MARK)
- return error_mark_node;
- if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
- {
- assert ("void value not ignored as it ought to be" == NULL);
- return error_mark_node;
- }
- assert (code != VOID_TYPE);
- if ((code != RECORD_TYPE)
- && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
- assert ("narrowing COMPLEX to REAL" == NULL);
- assert (code != ENUMERAL_TYPE);
- if (code == INTEGER_TYPE)
- {
- assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
- && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
- || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
- && (TYPE_PRECISION (type)
- == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
- return fold (convert_to_integer (type, e));
- }
- if (code == POINTER_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
- return fold (convert_to_pointer (type, e));
- }
- if (code == REAL_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
- assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
- return fold (convert_to_real (type, e));
- }
- if (code == COMPLEX_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
- assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
- return fold (convert_to_complex (type, e));
- }
- if (code == RECORD_TYPE)
- {
- assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
- /* Check that at least the first field name agrees. */
- assert (DECL_NAME (TYPE_FIELDS (type))
- == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
- assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
- >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
- if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
- == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
- return e;
- return fold (ffecom_convert_to_complex_ (type, e));
- }
-
- assert ("conversion to non-scalar type requested" == NULL);
- return error_mark_node;
-}
-
-/* Handles making a COMPLEX type, either the standard
- (but buggy?) gbe way, or the safer (but less elegant?)
- f2c way. */
-
-static tree
-ffecom_make_complex_type_ (tree subtype)
-{
- tree type;
- tree realfield;
- tree imagfield;
-
- if (ffe_is_emulate_complex ())
- {
- type = make_node (RECORD_TYPE);
- realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
- imagfield = ffecom_decl_field (type, realfield, "i", subtype);
- TYPE_FIELDS (type) = realfield;
- layout_type (type);
- }
- else
- {
- type = make_node (COMPLEX_TYPE);
- TREE_TYPE (type) = subtype;
- layout_type (type);
- }
-
- return type;
-}
-
-/* Chooses either the gbe or the f2c way to build a
- complex constant. */
-
-static tree
-ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
-{
- tree bothparts;
-
- if (ffe_is_emulate_complex ())
- {
- bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
- TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
- bothparts = build_constructor (type, bothparts);
- }
- else
- {
- bothparts = build_complex (type, realpart, imagpart);
- }
-
- return bothparts;
-}
-
-static tree
-ffecom_arglist_expr_ (const char *c, ffebld expr)
-{
- tree list;
- tree *plist = &list;
- tree trail = NULL_TREE; /* Append char length args here. */
- tree *ptrail = &trail;
- tree length;
- ffebld exprh;
- tree item;
- bool ptr = FALSE;
- tree wanted = NULL_TREE;
- static const char zed[] = "0";
-
- if (c == NULL)
- c = &zed[0];
-
- while (expr != NULL)
- {
- if (*c != '\0')
- {
- ptr = FALSE;
- if (*c == '&')
- {
- ptr = TRUE;
- ++c;
- }
- switch (*(c++))
- {
- case '\0':
- ptr = TRUE;
- wanted = NULL_TREE;
- break;
-
- case 'a':
- assert (ptr);
- wanted = NULL_TREE;
- break;
-
- case 'c':
- wanted = ffecom_f2c_complex_type_node;
- break;
-
- case 'd':
- wanted = ffecom_f2c_doublereal_type_node;
- break;
-
- case 'e':
- wanted = ffecom_f2c_doublecomplex_type_node;
- break;
-
- case 'f':
- wanted = ffecom_f2c_real_type_node;
- break;
-
- case 'i':
- wanted = ffecom_f2c_integer_type_node;
- break;
-
- case 'j':
- wanted = ffecom_f2c_longint_type_node;
- break;
-
- default:
- assert ("bad argstring code" == NULL);
- wanted = NULL_TREE;
- break;
- }
- }
-
- exprh = ffebld_head (expr);
- if (exprh == NULL)
- wanted = NULL_TREE;
-
- if ((wanted == NULL_TREE)
- || (ptr
- && (TYPE_MODE
- (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
- [ffeinfo_kindtype (ffebld_info (exprh))])
- == TYPE_MODE (wanted))))
- *plist
- = build_tree_list (NULL_TREE,
- ffecom_arg_ptr_to_expr (exprh,
- &length));
- else
- {
- item = ffecom_arg_expr (exprh, &length);
- item = ffecom_convert_widen_ (wanted, item);
- if (ptr)
- {
- item = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (item)),
- item);
- }
- *plist
- = build_tree_list (NULL_TREE,
- item);
- }
-
- plist = &TREE_CHAIN (*plist);
- expr = ffebld_trail (expr);
- if (length != NULL_TREE)
- {
- *ptrail = build_tree_list (NULL_TREE, length);
- ptrail = &TREE_CHAIN (*ptrail);
- }
- }
-
- /* We've run out of args in the call; if the implementation expects
- more, supply null pointers for them, which the implementation can
- check to see if an arg was omitted. */
-
- while (*c != '\0' && *c != '0')
- {
- if (*c == '&')
- ++c;
- else
- assert ("missing arg to run-time routine!" == NULL);
-
- switch (*(c++))
- {
- case '\0':
- case 'a':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'i':
- case 'j':
- break;
-
- default:
- assert ("bad arg string code" == NULL);
- break;
- }
- *plist
- = build_tree_list (NULL_TREE,
- null_pointer_node);
- plist = &TREE_CHAIN (*plist);
- }
-
- *plist = trail;
-
- return list;
-}
-
-static tree
-ffecom_widest_expr_type_ (ffebld list)
-{
- ffebld item;
- ffebld widest = NULL;
- ffetype type;
- ffetype widest_type = NULL;
- tree t;
-
- for (; list != NULL; list = ffebld_trail (list))
- {
- item = ffebld_head (list);
- if (item == NULL)
- continue;
- if ((widest != NULL)
- && (ffeinfo_basictype (ffebld_info (item))
- != ffeinfo_basictype (ffebld_info (widest))))
- continue;
- type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
- ffeinfo_kindtype (ffebld_info (item)));
- if ((widest == FFEINFO_kindtypeNONE)
- || (ffetype_size (type)
- > ffetype_size (widest_type)))
- {
- widest = item;
- widest_type = type;
- }
- }
-
- assert (widest != NULL);
- t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
- [ffeinfo_kindtype (ffebld_info (widest))];
- assert (t != NULL_TREE);
- return t;
-}
-
-/* Check whether a partial overlap between two expressions is possible.
-
- Can *starting* to write a portion of expr1 change the value
- computed (perhaps already, *partially*) by expr2?
-
- Currently, this is a concern only for a COMPLEX expr1. But if it
- isn't in COMMON or local EQUIVALENCE, since we don't support
- aliasing of arguments, it isn't a concern. */
-
-static bool
-ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
-{
- ffesymbol sym;
- ffestorag st;
-
- switch (ffebld_op (expr1))
- {
- case FFEBLD_opSYMTER:
- sym = ffebld_symter (expr1);
- break;
-
- case FFEBLD_opARRAYREF:
- if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
- return FALSE;
- sym = ffebld_symter (ffebld_left (expr1));
- break;
-
- default:
- return FALSE;
- }
-
- if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
- && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
- || ! (st = ffesymbol_storage (sym))
- || ! ffestorag_parent (st)))
- return FALSE;
-
- /* It's in COMMON or local EQUIVALENCE. */
-
- return TRUE;
-}
-
-/* Check whether dest and source might overlap. ffebld versions of these
- might or might not be passed, will be NULL if not.
-
- The test is really whether source_tree is modifiable and, if modified,
- might overlap destination such that the value(s) in the destination might
- change before it is finally modified. dest_* are the canonized
- destination itself. */
-
-static bool
-ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
- tree source_tree, ffebld source UNUSED, bool scalar_arg)
-{
- tree source_decl;
- tree source_offset;
- tree source_size;
- tree t;
-
- if (source_tree == NULL_TREE)
- return FALSE;
-
- switch (TREE_CODE (source_tree))
- {
- case ERROR_MARK:
- case IDENTIFIER_NODE:
- case INTEGER_CST:
- case REAL_CST:
- case COMPLEX_CST:
- case STRING_CST:
- case CONST_DECL:
- case VAR_DECL:
- case RESULT_DECL:
- case FIELD_DECL:
- case MINUS_EXPR:
- case MULT_EXPR:
- case TRUNC_DIV_EXPR:
- case CEIL_DIV_EXPR:
- case FLOOR_DIV_EXPR:
- case ROUND_DIV_EXPR:
- case TRUNC_MOD_EXPR:
- case CEIL_MOD_EXPR:
- case FLOOR_MOD_EXPR:
- case ROUND_MOD_EXPR:
- case RDIV_EXPR:
- case EXACT_DIV_EXPR:
- case FIX_TRUNC_EXPR:
- case FIX_CEIL_EXPR:
- case FIX_FLOOR_EXPR:
- case FIX_ROUND_EXPR:
- case FLOAT_EXPR:
- case NEGATE_EXPR:
- case MIN_EXPR:
- case MAX_EXPR:
- case ABS_EXPR:
- case LSHIFT_EXPR:
- case RSHIFT_EXPR:
- case LROTATE_EXPR:
- case RROTATE_EXPR:
- case BIT_IOR_EXPR:
- case BIT_XOR_EXPR:
- case BIT_AND_EXPR:
- case BIT_NOT_EXPR:
- case TRUTH_ANDIF_EXPR:
- case TRUTH_ORIF_EXPR:
- case TRUTH_AND_EXPR:
- case TRUTH_OR_EXPR:
- case TRUTH_XOR_EXPR:
- case TRUTH_NOT_EXPR:
- case LT_EXPR:
- case LE_EXPR:
- case GT_EXPR:
- case GE_EXPR:
- case EQ_EXPR:
- case NE_EXPR:
- case COMPLEX_EXPR:
- case CONJ_EXPR:
- case REALPART_EXPR:
- case IMAGPART_EXPR:
- case LABEL_EXPR:
- case COMPONENT_REF:
- return FALSE;
-
- case COMPOUND_EXPR:
- return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
- TREE_OPERAND (source_tree, 1), NULL,
- scalar_arg);
-
- case MODIFY_EXPR:
- return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
- TREE_OPERAND (source_tree, 0), NULL,
- scalar_arg);
-
- case CONVERT_EXPR:
- case NOP_EXPR:
- case NON_LVALUE_EXPR:
- case PLUS_EXPR:
- if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
- return TRUE;
-
- ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
- source_tree);
- source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
- break;
-
- case COND_EXPR:
- return
- ffecom_overlap_ (dest_decl, dest_offset, dest_size,
- TREE_OPERAND (source_tree, 1), NULL,
- scalar_arg)
- || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
- TREE_OPERAND (source_tree, 2), NULL,
- scalar_arg);
-
-
- case ADDR_EXPR:
- ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
- &source_size,
- TREE_OPERAND (source_tree, 0));
- break;
-
- case PARM_DECL:
- if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
- return TRUE;
-
- source_decl = source_tree;
- source_offset = bitsize_zero_node;
- source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
- break;
-
- case SAVE_EXPR:
- case REFERENCE_EXPR:
- case PREDECREMENT_EXPR:
- case PREINCREMENT_EXPR:
- case POSTDECREMENT_EXPR:
- case POSTINCREMENT_EXPR:
- case INDIRECT_REF:
- case ARRAY_REF:
- case CALL_EXPR:
- default:
- return TRUE;
- }
-
- /* Come here when source_decl, source_offset, and source_size filled
- in appropriately. */
-
- if (source_decl == NULL_TREE)
- return FALSE; /* No decl involved, so no overlap. */
-
- if (source_decl != dest_decl)
- return FALSE; /* Different decl, no overlap. */
-
- if (TREE_CODE (dest_size) == ERROR_MARK)
- return TRUE; /* Assignment into entire assumed-size
- array? Shouldn't happen.... */
-
- t = ffecom_2 (LE_EXPR, integer_type_node,
- ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
- dest_offset,
- convert (TREE_TYPE (dest_offset),
- dest_size)),
- convert (TREE_TYPE (dest_offset),
- source_offset));
-
- if (integer_onep (t))
- return FALSE; /* Destination precedes source. */
-
- if (!scalar_arg
- || (source_size == NULL_TREE)
- || (TREE_CODE (source_size) == ERROR_MARK)
- || integer_zerop (source_size))
- return TRUE; /* No way to tell if dest follows source. */
-
- t = ffecom_2 (LE_EXPR, integer_type_node,
- ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
- source_offset,
- convert (TREE_TYPE (source_offset),
- source_size)),
- convert (TREE_TYPE (source_offset),
- dest_offset));
-
- if (integer_onep (t))
- return FALSE; /* Destination follows source. */
-
- return TRUE; /* Destination and source overlap. */
-}
-
-/* Check whether dest might overlap any of a list of arguments or is
- in a COMMON area the callee might know about (and thus modify). */
-
-static bool
-ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED, tree args,
- tree callee_commons, bool scalar_args)
-{
- tree arg;
- tree dest_decl;
- tree dest_offset;
- tree dest_size;
-
- ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
- dest_tree);
-
- if (dest_decl == NULL_TREE)
- return FALSE; /* Seems unlikely! */
-
- /* If the decl cannot be determined reliably, or if its in COMMON
- and the callee isn't known to not futz with COMMON via other
- means, overlap might happen. */
-
- if ((TREE_CODE (dest_decl) == ERROR_MARK)
- || ((callee_commons != NULL_TREE)
- && TREE_PUBLIC (dest_decl)))
- return TRUE;
-
- for (; args != NULL_TREE; args = TREE_CHAIN (args))
- {
- if (((arg = TREE_VALUE (args)) != NULL_TREE)
- && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
- arg, NULL, scalar_args))
- return TRUE;
- }
-
- return FALSE;
-}
-
-/* Build a string for a variable name as used by NAMELIST. This means that
- if we're using the f2c library, we build an uppercase string, since
- f2c does this. */
-
-static tree
-ffecom_build_f2c_string_ (int i, const char *s)
-{
- if (!ffe_is_f2c_library ())
- return build_string (i, s);
-
- {
- char *tmp;
- const char *p;
- char *q;
- char space[34];
- tree t;
-
- if (((size_t) i) > ARRAY_SIZE (space))
- tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
- else
- tmp = &space[0];
-
- for (p = s, q = tmp; *p != '\0'; ++p, ++q)
- *q = TOUPPER (*p);
- *q = '\0';
-
- t = build_string (i, tmp);
-
- if (((size_t) i) > ARRAY_SIZE (space))
- malloc_kill_ks (malloc_pool_image (), tmp, i);
-
- return t;
- }
-}
-
-/* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
- type to just get whatever the function returns), handling the
- f2c value-returning convention, if required, by prepending
- to the arglist a pointer to a temporary to receive the return value. */
-
-static tree
-ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, tree type,
- tree args, tree dest_tree, ffebld dest, bool *dest_used,
- tree callee_commons, bool scalar_args, tree hook)
-{
- tree item;
- tree tempvar;
-
- if (dest_used != NULL)
- *dest_used = FALSE;
-
- if (is_f2c_complex)
- {
- if ((dest_used == NULL)
- || (dest == NULL)
- || (ffeinfo_basictype (ffebld_info (dest))
- != FFEINFO_basictypeCOMPLEX)
- || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
- || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
- || ffecom_args_overlapping_ (dest_tree, dest, args,
- callee_commons,
- scalar_args))
- {
- tempvar = hook;
- assert (tempvar);
- }
- else
- {
- *dest_used = TRUE;
- tempvar = dest_tree;
- type = NULL_TREE;
- }
-
- item
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (tempvar)),
- tempvar));
- TREE_CHAIN (item) = args;
-
- item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
- item, NULL_TREE);
-
- if (tempvar != dest_tree)
- item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
- }
- else
- item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
- args, NULL_TREE);
-
- if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
- item = ffecom_convert_narrow_ (type, item);
-
- return item;
-}
-
-/* Given two arguments, transform them and make a call to the given
- function via ffecom_call_. */
-
-static tree
-ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
- tree type, ffebld left, ffebld right, tree dest_tree,
- ffebld dest, bool *dest_used, tree callee_commons,
- bool scalar_args, bool ref, tree hook)
-{
- tree left_tree;
- tree right_tree;
- tree left_length;
- tree right_length;
-
- if (ref)
- {
- /* Pass arguments by reference. */
- left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
- right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
- }
- else
- {
- /* Pass arguments by value. */
- left_tree = ffecom_arg_expr (left, &left_length);
- right_tree = ffecom_arg_expr (right, &right_length);
- }
-
-
- left_tree = build_tree_list (NULL_TREE, left_tree);
- right_tree = build_tree_list (NULL_TREE, right_tree);
- TREE_CHAIN (left_tree) = right_tree;
-
- if (left_length != NULL_TREE)
- {
- left_length = build_tree_list (NULL_TREE, left_length);
- TREE_CHAIN (right_tree) = left_length;
- }
-
- if (right_length != NULL_TREE)
- {
- right_length = build_tree_list (NULL_TREE, right_length);
- if (left_length != NULL_TREE)
- TREE_CHAIN (left_length) = right_length;
- else
- TREE_CHAIN (right_tree) = right_length;
- }
-
- return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
- dest_tree, dest, dest_used, callee_commons,
- scalar_args, hook);
-}
-
-/* Return ptr/length args for char subexpression
-
- Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
- subexpressions by constructing the appropriate trees for the ptr-to-
- character-text and length-of-character-text arguments in a calling
- sequence.
-
- Note that if with_null is TRUE, and the expression is an opCONTER,
- a null byte is appended to the string. */
-
-static void
-ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
-{
- tree item;
- tree high;
- ffetargetCharacter1 val;
- ffetargetCharacterSize newlen;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opCONTER:
- val = ffebld_constant_character1 (ffebld_conter (expr));
- newlen = ffetarget_length_character1 (val);
- if (with_null)
- {
- /* Begin FFETARGET-NULL-KLUDGE. */
- if (newlen != 0)
- ++newlen;
- }
- *length = build_int_2 (newlen, 0);
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- high = build_int_2 (newlen, 0);
- TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
- item = build_string (newlen,
- ffetarget_text_character1 (val));
- /* End FFETARGET-NULL-KLUDGE. */
- TREE_TYPE (item)
- = build_type_variant
- (build_array_type
- (char_type_node,
- build_range_type
- (ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- high)),
- 1, 0);
- TREE_CONSTANT (item) = 1;
- TREE_STATIC (item) = 1;
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- break;
-
- case FFEBLD_opSYMTER:
- {
- ffesymbol s = ffebld_symter (expr);
-
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
- if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
- {
- if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
- *length = ffesymbol_hook (s).length_tree;
- else
- {
- *length = build_int_2 (ffesymbol_size (s), 0);
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- }
- }
- else if (item == error_mark_node)
- *length = error_mark_node;
- else
- /* FFEINFO_kindFUNCTION. */
- *length = NULL_TREE;
- if (!ffesymbol_hook (s).addr
- && (item != error_mark_node))
- item = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (item)),
- item);
- }
- break;
-
- case FFEBLD_opARRAYREF:
- {
- ffecom_char_args_ (&item, length, ffebld_left (expr));
-
- if (item == error_mark_node || *length == error_mark_node)
- {
- item = *length = error_mark_node;
- break;
- }
-
- item = ffecom_arrayref_ (item, expr, 1);
- }
- break;
-
- case FFEBLD_opSUBSTR:
- {
- ffebld start;
- ffebld end;
- ffebld thing = ffebld_right (expr);
- tree start_tree;
- tree end_tree;
- const char *char_name;
- ffebld left_symter;
- tree array;
-
- assert (ffebld_op (thing) == FFEBLD_opITEM);
- start = ffebld_head (thing);
- thing = ffebld_trail (thing);
- assert (ffebld_trail (thing) == NULL);
- end = ffebld_head (thing);
-
- /* Determine name for pretty-printing range-check errors. */
- for (left_symter = ffebld_left (expr);
- left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
- left_symter = ffebld_left (left_symter))
- ;
- if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
- char_name = ffesymbol_text (ffebld_symter (left_symter));
- else
- char_name = "[expr?]";
-
- ffecom_char_args_ (&item, length, ffebld_left (expr));
-
- if (item == error_mark_node || *length == error_mark_node)
- {
- item = *length = error_mark_node;
- break;
- }
-
- array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
-
- /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
-
- if (start == NULL)
- {
- if (end == NULL)
- ;
- else
- {
- end_tree = ffecom_expr (end);
- if (flag_bounds_check)
- end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
- char_name, NULL_TREE);
- end_tree = convert (ffecom_f2c_ftnlen_type_node,
- end_tree);
-
- if (end_tree == error_mark_node)
- {
- item = *length = error_mark_node;
- break;
- }
-
- *length = end_tree;
- }
- }
- else
- {
- start_tree = ffecom_expr (start);
- if (flag_bounds_check)
- start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
- char_name, NULL_TREE);
- start_tree = convert (ffecom_f2c_ftnlen_type_node,
- start_tree);
-
- if (start_tree == error_mark_node)
- {
- item = *length = error_mark_node;
- break;
- }
-
- start_tree = ffecom_save_tree (start_tree);
-
- item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
- item,
- ffecom_2 (MINUS_EXPR,
- TREE_TYPE (start_tree),
- start_tree,
- ffecom_f2c_ftnlen_one_node));
-
- if (end == NULL)
- {
- *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- ffecom_2 (MINUS_EXPR,
- ffecom_f2c_ftnlen_type_node,
- *length,
- start_tree));
- }
- else
- {
- end_tree = ffecom_expr (end);
- if (flag_bounds_check)
- end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
- char_name, NULL_TREE);
- end_tree = convert (ffecom_f2c_ftnlen_type_node,
- end_tree);
-
- if (end_tree == error_mark_node)
- {
- item = *length = error_mark_node;
- break;
- }
-
- *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- ffecom_2 (MINUS_EXPR,
- ffecom_f2c_ftnlen_type_node,
- end_tree, start_tree));
- }
- }
- }
- break;
-
- case FFEBLD_opFUNCREF:
- {
- ffesymbol s = ffebld_symter (ffebld_left (expr));
- tree tempvar;
- tree args;
- ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
- ffecomGfrt ix;
-
- if (size == FFETARGET_charactersizeNONE)
- /* ~~Kludge alert! This should someday be fixed. */
- size = 24;
-
- *length = build_int_2 (size, 0);
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
-
- if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
- == FFEINFO_whereINTRINSIC)
- {
- if (size == 1)
- {
- /* Invocation of an intrinsic returning CHARACTER*1. */
- item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
- NULL, NULL);
- break;
- }
- ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
- assert (ix != FFECOM_gfrt);
- item = ffecom_gfrt_tree_ (ix);
- }
- else
- {
- ix = FFECOM_gfrt;
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
- if (item == error_mark_node)
- {
- item = *length = error_mark_node;
- break;
- }
-
- if (!ffesymbol_hook (s).addr)
- item = ffecom_1_fn (item);
- }
- tempvar = ffebld_nonter_hook (expr);
- assert (tempvar);
- tempvar = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (tempvar)),
- tempvar);
-
- args = build_tree_list (NULL_TREE, tempvar);
-
- if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
- TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
- else
- {
- TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
- if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
- {
- TREE_CHAIN (TREE_CHAIN (args))
- = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
- ffebld_right (expr));
- }
- else
- {
- TREE_CHAIN (TREE_CHAIN (args))
- = ffecom_list_ptr_to_expr (ffebld_right (expr));
- }
- }
-
- item = ffecom_3s (CALL_EXPR,
- TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
- item, args, NULL_TREE);
- item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
- tempvar);
- }
- break;
-
- case FFEBLD_opCONVERT:
-
- ffecom_char_args_ (&item, length, ffebld_left (expr));
-
- if (item == error_mark_node || *length == error_mark_node)
- {
- item = *length = error_mark_node;
- break;
- }
-
- if ((ffebld_size_known (ffebld_left (expr))
- == FFETARGET_charactersizeNONE)
- || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
- { /* Possible blank-padding needed, copy into
- temporary. */
- tree tempvar;
- tree args;
- tree newlen;
-
- tempvar = ffebld_nonter_hook (expr);
- assert (tempvar);
- tempvar = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (tempvar)),
- tempvar);
-
- newlen = build_int_2 (ffebld_size (expr), 0);
- TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
-
- args = build_tree_list (NULL_TREE, tempvar);
- TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
- TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
- = build_tree_list (NULL_TREE, *length);
-
- item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
- TREE_SIDE_EFFECTS (item) = 1;
- item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
- tempvar);
- *length = newlen;
- }
- else
- { /* Just truncate the length. */
- *length = build_int_2 (ffebld_size (expr), 0);
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- }
- break;
-
- default:
- assert ("bad op for single char arg expr" == NULL);
- item = NULL_TREE;
- break;
- }
-
- *xitem = item;
-}
-
-/* Check the size of the type to be sure it doesn't overflow the
- "portable" capacities of the compiler back end. `dummy' types
- can generally overflow the normal sizes as long as the computations
- themselves don't overflow. A particular target of the back end
- must still enforce its size requirements, though, and the back
- end takes care of this in stor-layout.c. */
-
-static tree
-ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
-{
- if (TREE_CODE (type) == ERROR_MARK)
- return type;
-
- if (TYPE_SIZE (type) == NULL_TREE)
- return type;
-
- if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
- return type;
-
- /* An array is too large if size is negative or the type_size overflows
- or its "upper half" is larger than 3 (which would make the signed
- byte size and offset computations overflow). */
-
- if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
- || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
- || TREE_OVERFLOW (TYPE_SIZE (type)))))
- {
- ffebad_start (FFEBAD_ARRAY_LARGE);
- ffebad_string (ffesymbol_text (s));
- ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
- ffebad_finish ();
-
- return error_mark_node;
- }
-
- return type;
-}
-
-/* Builds a length argument (PARM_DECL). Also wraps type in an array type
- where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
- known, length_arg if not known (FFETARGET_charactersizeNONE). */
-
-static tree
-ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
-{
- ffetargetCharacterSize sz = ffesymbol_size (s);
- tree highval;
- tree tlen;
- tree type = *xtype;
-
- if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
- tlen = NULL_TREE; /* A statement function, no length passed. */
- else
- {
- if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
- tlen = ffecom_get_invented_identifier ("__g77_length_%s",
- ffesymbol_text (s));
- else
- tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
- tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
- DECL_ARTIFICIAL (tlen) = 1;
- }
-
- if (sz == FFETARGET_charactersizeNONE)
- {
- assert (tlen != NULL_TREE);
- highval = variable_size (tlen);
- }
- else
- {
- highval = build_int_2 (sz, 0);
- TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
- }
-
- type = build_array_type (type,
- build_range_type (ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- highval));
-
- *xtype = type;
- return tlen;
-}
-
-/* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
-
- ffecomConcatList_ catlist;
- ffebld expr; // expr of CHARACTER basictype.
- ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
- catlist = ffecom_concat_list_gather_(catlist,expr,max);
-
- Scans expr for character subexpressions, updates and returns catlist
- accordingly. */
-
-static ffecomConcatList_
-ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
- ffetargetCharacterSize max)
-{
- ffetargetCharacterSize sz;
-
- recurse:
-
- if (expr == NULL)
- return catlist;
-
- if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
- return catlist; /* Don't append any more items. */
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opCONTER:
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opFUNCREF:
- case FFEBLD_opSUBSTR:
- case FFEBLD_opCONVERT: /* Callers should strip this off beforehand
- if they don't need to preserve it. */
- if (catlist.count == catlist.max)
- { /* Make a (larger) list. */
- ffebld *newx;
- int newmax;
-
- newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
- newx = malloc_new_ks (malloc_pool_image (), "catlist",
- newmax * sizeof (newx[0]));
- if (catlist.max != 0)
- {
- memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
- malloc_kill_ks (malloc_pool_image (), catlist.exprs,
- catlist.max * sizeof (newx[0]));
- }
- catlist.max = newmax;
- catlist.exprs = newx;
- }
- if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
- catlist.minlen += sz;
- else
- ++catlist.minlen; /* Not true for F90; can be 0 length. */
- if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
- catlist.maxlen = sz;
- else
- catlist.maxlen += sz;
- if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
- { /* This item overlaps (or is beyond) the end
- of the destination. */
- switch (ffebld_op (expr))
- {
- case FFEBLD_opCONTER:
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opFUNCREF:
- case FFEBLD_opSUBSTR:
- /* ~~Do useful truncations here. */
- break;
-
- default:
- assert ("op changed or inconsistent switches!" == NULL);
- break;
- }
- }
- catlist.exprs[catlist.count++] = expr;
- return catlist;
-
- case FFEBLD_opPAREN:
- expr = ffebld_left (expr);
- goto recurse; /* :::::::::::::::::::: */
-
- case FFEBLD_opCONCATENATE:
- catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
- expr = ffebld_right (expr);
- goto recurse; /* :::::::::::::::::::: */
-
-#if 0 /* Breaks passing small actual arg to larger
- dummy arg of sfunc */
- case FFEBLD_opCONVERT:
- expr = ffebld_left (expr);
- {
- ffetargetCharacterSize cmax;
-
- cmax = catlist.len + ffebld_size_known (expr);
-
- if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
- max = cmax;
- }
- goto recurse; /* :::::::::::::::::::: */
-#endif
-
- case FFEBLD_opANY:
- return catlist;
-
- default:
- assert ("bad op in _gather_" == NULL);
- return catlist;
- }
-}
-
-/* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
-
- ffecomConcatList_ catlist;
- ffecom_concat_list_kill_(catlist);
-
- Anything allocated within the list info is deallocated. */
-
-static void
-ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
-{
- if (catlist.max != 0)
- malloc_kill_ks (malloc_pool_image (), catlist.exprs,
- catlist.max * sizeof (catlist.exprs[0]));
-}
-
-/* Make list of concatenated string exprs.
-
- Returns a flattened list of concatenated subexpressions given a
- tree of such expressions. */
-
-static ffecomConcatList_
-ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
-{
- ffecomConcatList_ catlist;
-
- catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
- return ffecom_concat_list_gather_ (catlist, expr, max);
-}
-
-/* Provide some kind of useful info on member of aggregate area,
- since current g77/gcc technology does not provide debug info
- on these members. */
-
-static void
-ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
- tree member_type UNUSED, ffetargetOffset offset)
-{
- tree value;
- tree decl;
- int len;
- char *buff;
- char space[120];
-#if 0
- tree type_id;
-
- for (type_id = member_type;
- TREE_CODE (type_id) != IDENTIFIER_NODE;
- )
- {
- switch (TREE_CODE (type_id))
- {
- case INTEGER_TYPE:
- case REAL_TYPE:
- type_id = TYPE_NAME (type_id);
- break;
-
- case ARRAY_TYPE:
- case COMPLEX_TYPE:
- type_id = TREE_TYPE (type_id);
- break;
-
- default:
- assert ("no IDENTIFIER_NODE for type!" == NULL);
- type_id = error_mark_node;
- break;
- }
- }
-#endif
-
- if (ffecom_transform_only_dummies_
- || !ffe_is_debug_kludge ())
- return; /* Can't do this yet, maybe later. */
-
- len = 60
- + strlen (aggr_type)
- + IDENTIFIER_LENGTH (DECL_NAME (aggr));
-#if 0
- + IDENTIFIER_LENGTH (type_id);
-#endif
-
- if (((size_t) len) >= ARRAY_SIZE (space))
- buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
- else
- buff = &space[0];
-
- sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
- aggr_type,
- IDENTIFIER_POINTER (DECL_NAME (aggr)),
- (long int) offset);
-
- value = build_string (len, buff);
- TREE_TYPE (value)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2 (strlen (buff), 0))),
- 1, 0);
- decl = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (member)),
- TREE_TYPE (value));
- TREE_CONSTANT (decl) = 1;
- TREE_STATIC (decl) = 1;
- DECL_INITIAL (decl) = error_mark_node;
- DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
- decl = start_decl (decl, FALSE);
- finish_decl (decl, value, FALSE);
-
- if (buff != &space[0])
- malloc_kill_ks (malloc_pool_image (), buff, len + 1);
-}
-
-/* ffecom_do_entry_ -- Do compilation of a particular entrypoint
-
- ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
- int i; // entry# for this entrypoint (used by master fn)
- ffecom_do_entrypoint_(s,i);
-
- Makes a public entry point that calls our private master fn (already
- compiled). */
-
-static void
-ffecom_do_entry_ (ffesymbol fn, int entrynum)
-{
- ffebld item;
- tree type; /* Type of function. */
- tree multi_retval; /* Var holding return value (union). */
- tree result; /* Var holding result. */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeglobal g;
- ffeglobalType gt;
- bool charfunc; /* All entry points return same type
- CHARACTER. */
- bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
- bool multi; /* Master fn has multiple return types. */
- bool altreturning = FALSE; /* This entry point has alternate
- returns. */
- location_t old_loc = input_location;
-
- input_filename = ffesymbol_where_filename (fn);
- input_line = ffesymbol_where_filelinenum (fn);
-
- ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
-
- switch (ffecom_primary_entry_kind_)
- {
- case FFEINFO_kindFUNCTION:
-
- /* Determine actual return type for function. */
-
- gt = FFEGLOBAL_typeFUNC;
- bt = ffesymbol_basictype (fn);
- kt = ffesymbol_kindtype (fn);
- if (bt == FFEINFO_basictypeNONE)
- {
- ffeimplic_establish_symbol (fn);
- if (ffesymbol_funcresult (fn) != NULL)
- ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
- bt = ffesymbol_basictype (fn);
- kt = ffesymbol_kindtype (fn);
- }
-
- if (bt == FFEINFO_basictypeCHARACTER)
- charfunc = TRUE, cmplxfunc = FALSE;
- else if ((bt == FFEINFO_basictypeCOMPLEX)
- && ffesymbol_is_f2c (fn))
- charfunc = FALSE, cmplxfunc = TRUE;
- else
- charfunc = cmplxfunc = FALSE;
-
- if (charfunc)
- type = ffecom_tree_fun_type_void;
- else if (ffesymbol_is_f2c (fn))
- type = ffecom_tree_fun_type[bt][kt];
- else
- type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
-
- if ((type == NULL_TREE)
- || (TREE_TYPE (type) == NULL_TREE))
- type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
-
- multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
- break;
-
- case FFEINFO_kindSUBROUTINE:
- gt = FFEGLOBAL_typeSUBR;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- if (ffecom_is_altreturning_)
- { /* Am _I_ altreturning? */
- for (item = ffesymbol_dummyargs (fn);
- item != NULL;
- item = ffebld_trail (item))
- {
- if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
- {
- altreturning = TRUE;
- break;
- }
- }
- if (altreturning)
- type = ffecom_tree_subr_type;
- else
- type = ffecom_tree_fun_type_void;
- }
- else
- type = ffecom_tree_fun_type_void;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- multi = FALSE;
- break;
-
- default:
- assert ("say what??" == NULL);
- /* Fall through. */
- case FFEINFO_kindANY:
- gt = FFEGLOBAL_typeANY;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = error_mark_node;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- multi = FALSE;
- break;
- }
-
- /* build_decl uses the current lineno and input_filename to set the decl
- source info. So, I've putzed with ffestd and ffeste code to update that
- source info to point to the appropriate statement just before calling
- ffecom_do_entrypoint (which calls this fn). */
-
- start_function (ffecom_get_external_identifier_ (fn),
- type,
- 0, /* nested/inline */
- 1); /* TREE_PUBLIC */
-
- if (((g = ffesymbol_global (fn)) != NULL)
- && ((ffeglobal_type (g) == gt)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- {
- ffeglobal_set_hook (g, current_function_decl);
- }
-
- /* Reset args in master arg list so they get retransitioned. */
-
- for (item = ffecom_master_arglist_;
- item != NULL;
- item = ffebld_trail (item))
- {
- ffebld arg;
- ffesymbol s;
-
- arg = ffebld_head (item);
- if (ffebld_op (arg) != FFEBLD_opSYMTER)
- continue; /* Alternate return or some such thing. */
- s = ffebld_symter (arg);
- ffesymbol_hook (s).decl_tree = NULL_TREE;
- ffesymbol_hook (s).length_tree = NULL_TREE;
- }
-
- /* Build dummy arg list for this entry point. */
-
- if (charfunc || cmplxfunc)
- { /* Prepend arg for where result goes. */
- tree type;
- tree length;
-
- if (charfunc)
- type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
- else
- type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
-
- result = ffecom_get_invented_identifier ("__g77_%s", "result");
-
- /* Make length arg _and_ enhance type info for CHAR arg itself. */
-
- if (charfunc)
- length = ffecom_char_enhance_arg_ (&type, fn);
- else
- length = NULL_TREE; /* Not ref'd if !charfunc. */
-
- type = build_pointer_type (type);
- result = build_decl (PARM_DECL, result, type);
-
- push_parm_decl (result);
- ffecom_func_result_ = result;
-
- if (charfunc)
- {
- push_parm_decl (length);
- ffecom_func_length_ = length;
- }
- }
- else
- result = DECL_RESULT (current_function_decl);
-
- ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
-
- store_parm_decls (0);
-
- ffecom_start_compstmt ();
- /* Disallow temp vars at this level. */
- current_binding_level->prep_state = 2;
-
- /* Make local var to hold return type for multi-type master fn. */
-
- if (multi)
- {
- multi_retval = ffecom_get_invented_identifier ("__g77_%s",
- "multi_retval");
- multi_retval = build_decl (VAR_DECL, multi_retval,
- ffecom_multi_type_node_);
- multi_retval = start_decl (multi_retval, FALSE);
- finish_decl (multi_retval, NULL_TREE, FALSE);
- }
- else
- multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
-
- /* Here we emit the actual code for the entry point. */
-
- {
- ffebld list;
- ffebld arg;
- ffesymbol s;
- tree arglist = NULL_TREE;
- tree *plist = &arglist;
- tree prepend;
- tree call;
- tree actarg;
- tree master_fn;
-
- /* Prepare actual arg list based on master arg list. */
-
- for (list = ffecom_master_arglist_;
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) != FFEBLD_opSYMTER)
- continue;
- s = ffebld_symter (arg);
- if (ffesymbol_hook (s).decl_tree == NULL_TREE
- || ffesymbol_hook (s).decl_tree == error_mark_node)
- actarg = null_pointer_node; /* We don't have this arg. */
- else
- actarg = ffesymbol_hook (s).decl_tree;
- *plist = build_tree_list (NULL_TREE, actarg);
- plist = &TREE_CHAIN (*plist);
- }
-
- /* This code appends the length arguments for character
- variables/arrays. */
-
- for (list = ffecom_master_arglist_;
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) != FFEBLD_opSYMTER)
- continue;
- s = ffebld_symter (arg);
- if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
- continue; /* Only looking for CHARACTER arguments. */
- if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
- continue; /* Only looking for variables and arrays. */
- if (ffesymbol_hook (s).length_tree == NULL_TREE
- || ffesymbol_hook (s).length_tree == error_mark_node)
- actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
- else
- actarg = ffesymbol_hook (s).length_tree;
- *plist = build_tree_list (NULL_TREE, actarg);
- plist = &TREE_CHAIN (*plist);
- }
-
- /* Prepend character-value return info to actual arg list. */
-
- if (charfunc)
- {
- prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
- TREE_CHAIN (prepend)
- = build_tree_list (NULL_TREE, ffecom_func_length_);
- TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
- arglist = prepend;
- }
-
- /* Prepend multi-type return value to actual arg list. */
-
- if (multi)
- {
- prepend
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (multi_retval)),
- multi_retval));
- TREE_CHAIN (prepend) = arglist;
- arglist = prepend;
- }
-
- /* Prepend my entry-point number to the actual arg list. */
-
- prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
- TREE_CHAIN (prepend) = arglist;
- arglist = prepend;
-
- /* Build the call to the master function. */
-
- master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
- call = ffecom_3s (CALL_EXPR,
- TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
- master_fn, arglist, NULL_TREE);
-
- /* Decide whether the master function is a function or subroutine, and
- handle the return value for my entry point. */
-
- if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
- && !altreturning))
- {
- expand_expr_stmt (call);
- expand_null_return ();
- }
- else if (multi && cmplxfunc)
- {
- expand_expr_stmt (call);
- result
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
- result);
- result = ffecom_modify (NULL_TREE, result,
- ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
- multi_retval,
- ffecom_multi_fields_[bt][kt]));
- expand_expr_stmt (result);
- expand_null_return ();
- }
- else if (multi)
- {
- expand_expr_stmt (call);
- result
- = ffecom_modify (NULL_TREE, result,
- convert (TREE_TYPE (result),
- ffecom_2 (COMPONENT_REF,
- ffecom_tree_type[bt][kt],
- multi_retval,
- ffecom_multi_fields_[bt][kt])));
- expand_return (result);
- }
- else if (cmplxfunc)
- {
- result
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
- result);
- result = ffecom_modify (NULL_TREE, result, call);
- expand_expr_stmt (result);
- expand_null_return ();
- }
- else
- {
- result = ffecom_modify (NULL_TREE,
- result,
- convert (TREE_TYPE (result),
- call));
- expand_return (result);
- }
- }
-
- ffecom_end_compstmt ();
-
- finish_function (0);
-
- input_location = old_loc;
-
- ffecom_doing_entry_ = FALSE;
-}
-
-/* Transform expr into gcc tree with possible destination
-
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. If destination supplied and compatible
- with temporary that would be made in certain cases, temporary isn't
- made, destination used instead, and dest_used flag set TRUE. */
-
-static tree
-ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, bool *dest_used,
- bool assignp, bool widenp)
-{
- tree item;
- tree list;
- tree args;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- tree t;
- tree dt; /* decl_tree for an ffesymbol. */
- tree tree_type, tree_type_x;
- tree left, right;
- ffesymbol s;
- enum tree_code code;
-
- assert (expr != NULL);
-
- if (dest_used != NULL)
- *dest_used = FALSE;
-
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
- tree_type = ffecom_tree_type[bt][kt];
-
- /* Widen integral arithmetic as desired while preserving signedness. */
- tree_type_x = NULL_TREE;
- if (widenp && tree_type
- && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
- && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
- tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opACCTER:
- {
- ffebitCount i;
- ffebit bits = ffebld_accter_bits (expr);
- ffetargetOffset source_offset = 0;
- ffetargetOffset dest_offset = ffebld_accter_pad (expr);
- tree purpose;
-
- assert (dest_offset == 0
- || (bt == FFEINFO_basictypeCHARACTER
- && kt == FFEINFO_kindtypeCHARACTER1));
-
- list = item = NULL;
- for (;;)
- {
- ffebldConstantUnion cu;
- ffebitCount length;
- bool value;
- ffebldConstantArray ca = ffebld_accter (expr);
-
- ffebit_test (bits, source_offset, &value, &length);
- if (length == 0)
- break;
-
- if (value)
- {
- for (i = 0; i < length; ++i)
- {
- cu = ffebld_constantarray_get (ca, bt, kt,
- source_offset + i);
-
- t = ffecom_constantunion (&cu, bt, kt, tree_type);
-
- if (i == 0
- && dest_offset != 0)
- purpose = build_int_2 (dest_offset, 0);
- else
- purpose = NULL_TREE;
-
- if (list == NULL_TREE)
- list = item = build_tree_list (purpose, t);
- else
- {
- TREE_CHAIN (item) = build_tree_list (purpose, t);
- item = TREE_CHAIN (item);
- }
- }
- }
- source_offset += length;
- dest_offset += length;
- }
- }
-
- item = build_int_2 ((ffebld_accter_size (expr)
- + ffebld_accter_pad (expr)) - 1, 0);
- ffebit_kill (ffebld_accter_bits (expr));
- TREE_TYPE (item) = ffecom_integer_type_node;
- item
- = build_array_type
- (tree_type,
- build_range_type (ffecom_integer_type_node,
- ffecom_integer_zero_node,
- item));
- list = build_constructor (item, list);
- TREE_CONSTANT (list) = 1;
- TREE_STATIC (list) = 1;
- return list;
-
- case FFEBLD_opARRTER:
- {
- ffetargetOffset i;
-
- list = NULL_TREE;
- if (ffebld_arrter_pad (expr) == 0)
- item = NULL_TREE;
- else
- {
- assert (bt == FFEINFO_basictypeCHARACTER
- && kt == FFEINFO_kindtypeCHARACTER1);
-
- /* Becomes PURPOSE first time through loop. */
- item = build_int_2 (ffebld_arrter_pad (expr), 0);
- }
-
- for (i = 0; i < ffebld_arrter_size (expr); ++i)
- {
- ffebldConstantUnion cu
- = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
-
- t = ffecom_constantunion (&cu, bt, kt, tree_type);
-
- if (list == NULL_TREE)
- /* Assume item is PURPOSE first time through loop. */
- list = item = build_tree_list (item, t);
- else
- {
- TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
- item = TREE_CHAIN (item);
- }
- }
- }
-
- item = build_int_2 ((ffebld_arrter_size (expr)
- + ffebld_arrter_pad (expr)) - 1, 0);
- TREE_TYPE (item) = ffecom_integer_type_node;
- item
- = build_array_type
- (tree_type,
- build_range_type (ffecom_integer_type_node,
- ffecom_integer_zero_node,
- item));
- list = build_constructor (item, list);
- TREE_CONSTANT (list) = 1;
- TREE_STATIC (list) = 1;
- return list;
-
- case FFEBLD_opCONTER:
- assert (ffebld_conter_pad (expr) == 0);
- item
- = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
- bt, kt, tree_type);
- return item;
-
- case FFEBLD_opSYMTER:
- if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
- || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
- return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
- s = ffebld_symter (expr);
- t = ffesymbol_hook (s).decl_tree;
-
- if (assignp)
- { /* ASSIGN'ed-label expr. */
- if (ffe_is_ugly_assign ())
- {
- /* User explicitly wants ASSIGN'ed variables to be at the same
- memory address as the variables when used in non-ASSIGN
- contexts. That can make old, arcane, non-standard code
- work, but don't try to do it when a pointer wouldn't fit
- in the normal variable (take other approach, and warn,
- instead). */
-
- if (t == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- t = ffesymbol_hook (s).decl_tree;
- assert (t != NULL_TREE);
- }
-
- if (t == error_mark_node)
- return t;
-
- if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
- >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
- {
- if (ffesymbol_hook (s).addr)
- t = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
- return t;
- }
-
- if (ffesymbol_hook (s).assign_tree == NULL_TREE)
- {
- /* xgettext:no-c-format */
- ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
- FFEBAD_severityWARNING);
- ffebad_string (ffesymbol_text (s));
- ffebad_here (0, ffesymbol_where_line (s),
- ffesymbol_where_column (s));
- ffebad_finish ();
- }
- }
-
- /* Don't use the normal variable's tree for ASSIGN, though mark
- it as in the system header (housekeeping). Use an explicit,
- specially created sibling that is known to be wide enough
- to hold pointers to labels. */
-
- if (t != NULL_TREE
- && TREE_CODE (t) == VAR_DECL)
- DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */
-
- t = ffesymbol_hook (s).assign_tree;
- if (t == NULL_TREE)
- {
- s = ffecom_sym_transform_assign_ (s);
- t = ffesymbol_hook (s).assign_tree;
- assert (t != NULL_TREE);
- }
- }
- else
- {
- if (t == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- t = ffesymbol_hook (s).decl_tree;
- assert (t != NULL_TREE);
- }
- if (ffesymbol_hook (s).addr)
- t = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
- }
- return t;
-
- case FFEBLD_opARRAYREF:
- return ffecom_arrayref_ (NULL_TREE, expr, 0);
-
- case FFEBLD_opUPLUS:
- left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- return ffecom_1 (NOP_EXPR, tree_type, left);
-
- case FFEBLD_opPAREN:
- /* ~~~Make sure Fortran rules respected here */
- left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- return ffecom_1 (NOP_EXPR, tree_type, left);
-
- case FFEBLD_opUMINUS:
- left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
- {
- tree_type = tree_type_x;
- left = convert (tree_type, left);
- }
- return ffecom_1 (NEGATE_EXPR, tree_type, left);
-
- case FFEBLD_opADD:
- left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
- {
- tree_type = tree_type_x;
- left = convert (tree_type, left);
- right = convert (tree_type, right);
- }
- return ffecom_2 (PLUS_EXPR, tree_type, left, right);
-
- case FFEBLD_opSUBTRACT:
- left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
- {
- tree_type = tree_type_x;
- left = convert (tree_type, left);
- right = convert (tree_type, right);
- }
- return ffecom_2 (MINUS_EXPR, tree_type, left, right);
-
- case FFEBLD_opMULTIPLY:
- left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
- {
- tree_type = tree_type_x;
- left = convert (tree_type, left);
- right = convert (tree_type, right);
- }
- return ffecom_2 (MULT_EXPR, tree_type, left, right);
-
- case FFEBLD_opDIVIDE:
- left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
- {
- tree_type = tree_type_x;
- left = convert (tree_type, left);
- right = convert (tree_type, right);
- }
- return ffecom_tree_divide_ (tree_type, left, right,
- dest_tree, dest, dest_used,
- ffebld_nonter_hook (expr));
-
- case FFEBLD_opPOWER:
- {
- ffebld left = ffebld_left (expr);
- ffebld right = ffebld_right (expr);
- ffecomGfrt code;
- ffeinfoKindtype rtkt;
- ffeinfoKindtype ltkt;
- bool ref = TRUE;
-
- switch (ffeinfo_basictype (ffebld_info (right)))
- {
-
- case FFEINFO_basictypeINTEGER:
- if (1 || optimize)
- {
- item = ffecom_expr_power_integer_ (expr);
- if (item != NULL_TREE)
- return item;
- }
-
- rtkt = FFEINFO_kindtypeINTEGER1;
- switch (ffeinfo_basictype (ffebld_info (left)))
- {
- case FFEINFO_basictypeINTEGER:
- if ((ffeinfo_kindtype (ffebld_info (left))
- == FFEINFO_kindtypeINTEGER4)
- || (ffeinfo_kindtype (ffebld_info (right))
- == FFEINFO_kindtypeINTEGER4))
- {
- code = FFECOM_gfrtPOW_QQ;
- ltkt = FFEINFO_kindtypeINTEGER4;
- rtkt = FFEINFO_kindtypeINTEGER4;
- }
- else
- {
- code = FFECOM_gfrtPOW_II;
- ltkt = FFEINFO_kindtypeINTEGER1;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- if (ffeinfo_kindtype (ffebld_info (left))
- == FFEINFO_kindtypeREAL1)
- {
- code = FFECOM_gfrtPOW_RI;
- ltkt = FFEINFO_kindtypeREAL1;
- }
- else
- {
- code = FFECOM_gfrtPOW_DI;
- ltkt = FFEINFO_kindtypeREAL2;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- if (ffeinfo_kindtype (ffebld_info (left))
- == FFEINFO_kindtypeREAL1)
- {
- code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
- ltkt = FFEINFO_kindtypeREAL1;
- }
- else
- {
- code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
- ltkt = FFEINFO_kindtypeREAL2;
- }
- break;
-
- default:
- assert ("bad pow_*i" == NULL);
- code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
- ltkt = FFEINFO_kindtypeREAL1;
- break;
- }
- if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
- left = ffeexpr_convert (left, NULL, NULL,
- ffeinfo_basictype (ffebld_info (left)),
- ltkt, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
- right = ffeexpr_convert (right, NULL, NULL,
- FFEINFO_basictypeINTEGER,
- rtkt, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeREAL:
- if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
- left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREALDOUBLE, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- if (ffeinfo_kindtype (ffebld_info (right))
- == FFEINFO_kindtypeREAL1)
- right = ffeexpr_convert (right, NULL, NULL,
- FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREALDOUBLE, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* We used to call FFECOM_gfrtPOW_DD here,
- which passes arguments by reference. */
- code = FFECOM_gfrtL_POW;
- /* Pass arguments by value. */
- ref = FALSE;
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
- left = ffeexpr_convert (left, NULL, NULL,
- FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREALDOUBLE, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- if (ffeinfo_kindtype (ffebld_info (right))
- == FFEINFO_kindtypeREAL1)
- right = ffeexpr_convert (right, NULL, NULL,
- FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREALDOUBLE, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
- ref = TRUE; /* Pass arguments by reference. */
- break;
-
- default:
- assert ("bad pow_x*" == NULL);
- code = FFECOM_gfrtPOW_II;
- break;
- }
- return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
- ffecom_gfrt_kindtype (code),
- (ffe_is_f2c_library ()
- && ffecom_gfrt_complex_[code]),
- tree_type, left, right,
- dest_tree, dest, dest_used,
- NULL_TREE, FALSE, ref,
- ffebld_nonter_hook (expr));
- }
-
- case FFEBLD_opNOT:
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
- return convert (tree_type, item);
-
- case FFEINFO_basictypeINTEGER:
- return ffecom_1 (BIT_NOT_EXPR, tree_type,
- ffecom_expr (ffebld_left (expr)));
-
- default:
- assert ("NOT bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- case FFEBLD_opFUNCREF:
- assert (ffeinfo_basictype (ffebld_info (expr))
- != FFEINFO_basictypeCHARACTER);
- /* Fall through. */
- case FFEBLD_opSUBRREF:
- if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
- == FFEINFO_whereINTRINSIC)
- { /* Invocation of an intrinsic. */
- item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
- dest_used);
- return item;
- }
- s = ffebld_symter (ffebld_left (expr));
- dt = ffesymbol_hook (s).decl_tree;
- if (dt == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- dt = ffesymbol_hook (s).decl_tree;
- }
- if (dt == error_mark_node)
- return dt;
-
- if (ffesymbol_hook (s).addr)
- item = dt;
- else
- item = ffecom_1_fn (dt);
-
- if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
- args = ffecom_list_expr (ffebld_right (expr));
- else
- args = ffecom_list_ptr_to_expr (ffebld_right (expr));
-
- if (args == error_mark_node)
- return error_mark_node;
-
- item = ffecom_call_ (item, kt,
- ffesymbol_is_f2c (s)
- && (bt == FFEINFO_basictypeCOMPLEX)
- && (ffesymbol_where (s)
- != FFEINFO_whereCONSTANT),
- tree_type,
- args,
- dest_tree, dest, dest_used,
- error_mark_node, FALSE,
- ffebld_nonter_hook (expr));
- TREE_SIDE_EFFECTS (item) = 1;
- return item;
-
- case FFEBLD_opAND:
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- item
- = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
- ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
- return convert (tree_type, item);
-
- case FFEINFO_basictypeINTEGER:
- return ffecom_2 (BIT_AND_EXPR, tree_type,
- ffecom_expr (ffebld_left (expr)),
- ffecom_expr (ffebld_right (expr)));
-
- default:
- assert ("AND bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- case FFEBLD_opOR:
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- item
- = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
- ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
- ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
- return convert (tree_type, item);
-
- case FFEINFO_basictypeINTEGER:
- return ffecom_2 (BIT_IOR_EXPR, tree_type,
- ffecom_expr (ffebld_left (expr)),
- ffecom_expr (ffebld_right (expr)));
-
- default:
- assert ("OR bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- case FFEBLD_opXOR:
- case FFEBLD_opNEQV:
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- item
- = ffecom_2 (NE_EXPR, integer_type_node,
- ffecom_expr (ffebld_left (expr)),
- ffecom_expr (ffebld_right (expr)));
- return convert (tree_type, ffecom_truth_value (item));
-
- case FFEINFO_basictypeINTEGER:
- return ffecom_2 (BIT_XOR_EXPR, tree_type,
- ffecom_expr (ffebld_left (expr)),
- ffecom_expr (ffebld_right (expr)));
-
- default:
- assert ("XOR/NEQV bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- case FFEBLD_opEQV:
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- item
- = ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_expr (ffebld_left (expr)),
- ffecom_expr (ffebld_right (expr)));
- return convert (tree_type, ffecom_truth_value (item));
-
- case FFEINFO_basictypeINTEGER:
- return
- ffecom_1 (BIT_NOT_EXPR, tree_type,
- ffecom_2 (BIT_XOR_EXPR, tree_type,
- ffecom_expr (ffebld_left (expr)),
- ffecom_expr (ffebld_right (expr))));
-
- default:
- assert ("EQV bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- case FFEBLD_opCONVERT:
- if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
- return error_mark_node;
-
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- return convert (tree_type, ffecom_expr (ffebld_left (expr)));
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeLOGICAL:
- case FFEINFO_basictypeREAL:
- item = ffecom_expr (ffebld_left (expr));
- if (item == error_mark_node)
- return error_mark_node;
- /* convert() takes care of converting to the subtype first,
- at least in gcc-2.7.2. */
- item = convert (tree_type, item);
- return item;
-
- case FFEINFO_basictypeCOMPLEX:
- return convert (tree_type, ffecom_expr (ffebld_left (expr)));
-
- default:
- assert ("CONVERT COMPLEX bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- default:
- assert ("CONVERT bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- case FFEBLD_opLT:
- code = LT_EXPR;
- goto relational; /* :::::::::::::::::::: */
-
- case FFEBLD_opLE:
- code = LE_EXPR;
- goto relational; /* :::::::::::::::::::: */
-
- case FFEBLD_opEQ:
- code = EQ_EXPR;
- goto relational; /* :::::::::::::::::::: */
-
- case FFEBLD_opNE:
- code = NE_EXPR;
- goto relational; /* :::::::::::::::::::: */
-
- case FFEBLD_opGT:
- code = GT_EXPR;
- goto relational; /* :::::::::::::::::::: */
-
- case FFEBLD_opGE:
- code = GE_EXPR;
-
- relational: /* :::::::::::::::::::: */
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeLOGICAL:
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- item = ffecom_2 (code, integer_type_node,
- ffecom_expr (ffebld_left (expr)),
- ffecom_expr (ffebld_right (expr)));
- return convert (tree_type, item);
-
- case FFEINFO_basictypeCOMPLEX:
- assert (code == EQ_EXPR || code == NE_EXPR);
- {
- tree real_type;
- tree arg1 = ffecom_expr (ffebld_left (expr));
- tree arg2 = ffecom_expr (ffebld_right (expr));
-
- if (arg1 == error_mark_node || arg2 == error_mark_node)
- return error_mark_node;
-
- arg1 = ffecom_save_tree (arg1);
- arg2 = ffecom_save_tree (arg2);
-
- if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
- {
- real_type = TREE_TYPE (TREE_TYPE (arg1));
- assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
- }
- else
- {
- real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
- assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
- }
-
- item
- = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_1 (REALPART_EXPR, real_type, arg1),
- ffecom_1 (REALPART_EXPR, real_type, arg2)),
- ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_1 (IMAGPART_EXPR, real_type, arg1),
- ffecom_1 (IMAGPART_EXPR, real_type,
- arg2)));
- if (code == EQ_EXPR)
- item = ffecom_truth_value (item);
- else
- item = ffecom_truth_value_invert (item);
- return convert (tree_type, item);
- }
-
- case FFEINFO_basictypeCHARACTER:
- {
- ffebld left = ffebld_left (expr);
- ffebld right = ffebld_right (expr);
- tree left_tree;
- tree right_tree;
- tree left_length;
- tree right_length;
-
- /* f2c run-time functions do the implicit blank-padding for us,
- so we don't usually have to implement blank-padding ourselves.
- (The exception is when we pass an argument to a separately
- compiled statement function -- if we know the arg is not the
- same length as the dummy, we must truncate or extend it. If
- we "inline" statement functions, that necessity goes away as
- well.)
-
- Strip off the CONVERT operators that blank-pad. (Truncation by
- CONVERT shouldn't happen here, but it can happen in
- assignments.) */
-
- while (ffebld_op (left) == FFEBLD_opCONVERT)
- left = ffebld_left (left);
- while (ffebld_op (right) == FFEBLD_opCONVERT)
- right = ffebld_left (right);
-
- left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
- right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
-
- if (left_tree == error_mark_node || left_length == error_mark_node
- || right_tree == error_mark_node
- || right_length == error_mark_node)
- return error_mark_node;
-
- if ((ffebld_size_known (left) == 1)
- && (ffebld_size_known (right) == 1))
- {
- left_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
- left_tree);
- right_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
- right_tree);
-
- item
- = ffecom_2 (code, integer_type_node,
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
- left_tree,
- integer_one_node),
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
- right_tree,
- integer_one_node));
- }
- else
- {
- item = build_tree_list (NULL_TREE, left_tree);
- TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
- TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
- left_length);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
- = build_tree_list (NULL_TREE, right_length);
- item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
- item = ffecom_2 (code, integer_type_node,
- item,
- convert (TREE_TYPE (item),
- integer_zero_node));
- }
- item = convert (tree_type, item);
- }
-
- return item;
-
- default:
- assert ("relational bad basictype" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
- break;
-
- case FFEBLD_opPERCENT_LOC:
- item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
- return convert (tree_type, item);
-
- case FFEBLD_opPERCENT_VAL:
- item = ffecom_arg_expr (ffebld_left (expr), &list);
- return convert (tree_type, item);
-
- case FFEBLD_opITEM:
- case FFEBLD_opSTAR:
- case FFEBLD_opBOUNDS:
- case FFEBLD_opREPEAT:
- case FFEBLD_opLABTER:
- case FFEBLD_opLABTOK:
- case FFEBLD_opIMPDO:
- case FFEBLD_opCONCATENATE:
- case FFEBLD_opSUBSTR:
- default:
- assert ("bad op" == NULL);
- /* Fall through. */
- case FFEBLD_opANY:
- return error_mark_node;
- }
-
-#if 1
- assert ("didn't think anything got here anymore!!" == NULL);
-#else
- switch (ffebld_arity (expr))
- {
- case 2:
- TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
- TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
- if (TREE_OPERAND (item, 0) == error_mark_node
- || TREE_OPERAND (item, 1) == error_mark_node)
- return error_mark_node;
- break;
-
- case 1:
- TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
- if (TREE_OPERAND (item, 0) == error_mark_node)
- return error_mark_node;
- break;
-
- default:
- break;
- }
-
- return fold (item);
-#endif
-}
-
-/* Returns the tree that does the intrinsic invocation.
-
- Note: this function applies only to intrinsics returning
- CHARACTER*1 or non-CHARACTER results, and to intrinsic
- subroutines. */
-
-static tree
-ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, ffebld dest,
- bool *dest_used)
-{
- tree expr_tree;
- tree saved_expr1; /* For those who need it. */
- tree saved_expr2; /* For those who need it. */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- tree tree_type;
- tree arg1_type;
- tree real_type; /* REAL type corresponding to COMPLEX. */
- tree tempvar;
- ffebld list = ffebld_right (expr); /* List of (some) args. */
- ffebld arg1; /* For handy reference. */
- ffebld arg2;
- ffebld arg3;
- ffeintrinImp codegen_imp;
- ffecomGfrt gfrt;
-
- assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
-
- if (dest_used != NULL)
- *dest_used = FALSE;
-
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
- tree_type = ffecom_tree_type[bt][kt];
-
- if (list != NULL)
- {
- arg1 = ffebld_head (list);
- if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
- return error_mark_node;
- if ((list = ffebld_trail (list)) != NULL)
- {
- arg2 = ffebld_head (list);
- if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
- return error_mark_node;
- if ((list = ffebld_trail (list)) != NULL)
- {
- arg3 = ffebld_head (list);
- if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
- return error_mark_node;
- }
- else
- arg3 = NULL;
- }
- else
- arg2 = arg3 = NULL;
- }
- else
- arg1 = arg2 = arg3 = NULL;
-
- /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
- args. This is used by the MAX/MIN expansions. */
-
- if (arg1 != NULL)
- arg1_type = ffecom_tree_type
- [ffeinfo_basictype (ffebld_info (arg1))]
- [ffeinfo_kindtype (ffebld_info (arg1))];
- else
- arg1_type = NULL_TREE; /* Really not needed, but might catch bugs
- here. */
-
- /* There are several ways for each of the cases in the following switch
- statements to exit (from simplest to use to most complicated):
-
- break; (when expr_tree == NULL)
-
- A standard call is made to the specific intrinsic just as if it had been
- passed in as a dummy procedure and called as any old procedure. This
- method can produce slower code but in some cases it's the easiest way for
- now. However, if a (presumably faster) direct call is available,
- that is used, so this is the easiest way in many more cases now.
-
- gfrt = FFECOM_gfrtWHATEVER;
- break;
-
- gfrt contains the gfrt index of a library function to call, passing the
- argument(s) by value rather than by reference. Used when a more
- careful choice of library function is needed than that provided
- by the vanilla `break;'.
-
- return expr_tree;
-
- The expr_tree has been completely set up and is ready to be returned
- as is. No further actions are taken. Use this when the tree is not
- in the simple form for one of the arity_n labels. */
-
- /* For info on how the switch statement cases were written, see the files
- enclosed in comments below the switch statement. */
-
- codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
- gfrt = ffeintrin_gfrt_direct (codegen_imp);
- if (gfrt == FFECOM_gfrt)
- gfrt = ffeintrin_gfrt_indirect (codegen_imp);
-
- switch (codegen_imp)
- {
- case FFEINTRIN_impABS:
- case FFEINTRIN_impCABS:
- case FFEINTRIN_impCDABS:
- case FFEINTRIN_impDABS:
- case FFEINTRIN_impIABS:
- if (ffeinfo_basictype (ffebld_info (arg1))
- == FFEINFO_basictypeCOMPLEX)
- {
- if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtCABS;
- else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtCDABS;
- break;
- }
- return ffecom_1 (ABS_EXPR, tree_type,
- convert (tree_type, ffecom_expr (arg1)));
-
- case FFEINTRIN_impACOS:
- case FFEINTRIN_impDACOS:
- break;
-
- case FFEINTRIN_impAIMAG:
- case FFEINTRIN_impDIMAG:
- case FFEINTRIN_impIMAGPART:
- if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
- arg1_type = TREE_TYPE (arg1_type);
- else
- arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
-
- return
- convert (tree_type,
- ffecom_1 (IMAGPART_EXPR, arg1_type,
- ffecom_expr (arg1)));
-
- case FFEINTRIN_impAINT:
- case FFEINTRIN_impDINT:
-#if 0
- /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
- return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
-#else /* in the meantime, must use floor to avoid range problems with ints */
- /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
- saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
- return
- convert (tree_type,
- ffecom_3 (COND_EXPR, double_type_node,
- ffecom_truth_value
- (ffecom_2 (GE_EXPR, integer_type_node,
- saved_expr1,
- convert (arg1_type,
- ffecom_float_zero_))),
- ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
- build_tree_list (NULL_TREE,
- convert (double_type_node,
- saved_expr1)),
- NULL_TREE),
- ffecom_1 (NEGATE_EXPR, double_type_node,
- ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
- build_tree_list (NULL_TREE,
- convert (double_type_node,
- ffecom_1 (NEGATE_EXPR,
- arg1_type,
- saved_expr1))),
- NULL_TREE)
- ))
- );
-#endif
-
- case FFEINTRIN_impANINT:
- case FFEINTRIN_impDNINT:
-#if 0 /* This way of doing it won't handle real
- numbers of large magnitudes. */
- saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
- expr_tree = convert (tree_type,
- convert (integer_type_node,
- ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (GE_EXPR,
- integer_type_node,
- saved_expr1,
- ffecom_float_zero_)),
- ffecom_2 (PLUS_EXPR,
- tree_type,
- saved_expr1,
- ffecom_float_half_),
- ffecom_2 (MINUS_EXPR,
- tree_type,
- saved_expr1,
- ffecom_float_half_))));
- return expr_tree;
-#else /* So we instead call floor. */
- /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
- saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
- return
- convert (tree_type,
- ffecom_3 (COND_EXPR, double_type_node,
- ffecom_truth_value
- (ffecom_2 (GE_EXPR, integer_type_node,
- saved_expr1,
- convert (arg1_type,
- ffecom_float_zero_))),
- ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
- build_tree_list (NULL_TREE,
- convert (double_type_node,
- ffecom_2 (PLUS_EXPR,
- arg1_type,
- saved_expr1,
- convert (arg1_type,
- ffecom_float_half_)))),
- NULL_TREE),
- ffecom_1 (NEGATE_EXPR, double_type_node,
- ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
- build_tree_list (NULL_TREE,
- convert (double_type_node,
- ffecom_2 (MINUS_EXPR,
- arg1_type,
- convert (arg1_type,
- ffecom_float_half_),
- saved_expr1))),
- NULL_TREE))
- )
- );
-#endif
-
- case FFEINTRIN_impASIN:
- case FFEINTRIN_impDASIN:
- case FFEINTRIN_impATAN:
- case FFEINTRIN_impDATAN:
- case FFEINTRIN_impATAN2:
- case FFEINTRIN_impDATAN2:
- break;
-
- case FFEINTRIN_impCHAR:
- case FFEINTRIN_impACHAR:
- tempvar = ffebld_nonter_hook (expr);
- assert (tempvar);
- {
- tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
-
- expr_tree = ffecom_modify (tmv,
- ffecom_2 (ARRAY_REF, tmv, tempvar,
- integer_one_node),
- convert (tmv, ffecom_expr (arg1)));
- }
- expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
- expr_tree,
- tempvar);
- expr_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (expr_tree)),
- expr_tree);
- return expr_tree;
-
- case FFEINTRIN_impCMPLX:
- case FFEINTRIN_impDCMPLX:
- if (arg2 == NULL)
- return
- convert (tree_type, ffecom_expr (arg1));
-
- real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
- return
- ffecom_2 (COMPLEX_EXPR, tree_type,
- convert (real_type, ffecom_expr (arg1)),
- convert (real_type,
- ffecom_expr (arg2)));
-
- case FFEINTRIN_impCOMPLEX:
- return
- ffecom_2 (COMPLEX_EXPR, tree_type,
- ffecom_expr (arg1),
- ffecom_expr (arg2));
-
- case FFEINTRIN_impCONJG:
- case FFEINTRIN_impDCONJG:
- {
- tree arg1_tree;
-
- real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
- arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
- return
- ffecom_2 (COMPLEX_EXPR, tree_type,
- ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
- ffecom_1 (NEGATE_EXPR, real_type,
- ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
- }
-
- case FFEINTRIN_impCOS:
- case FFEINTRIN_impCCOS:
- case FFEINTRIN_impCDCOS:
- case FFEINTRIN_impDCOS:
- if (bt == FFEINFO_basictypeCOMPLEX)
- {
- if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
- else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */
- }
- break;
-
- case FFEINTRIN_impCOSH:
- case FFEINTRIN_impDCOSH:
- break;
-
- case FFEINTRIN_impDBLE:
- case FFEINTRIN_impDFLOAT:
- case FFEINTRIN_impDREAL:
- case FFEINTRIN_impFLOAT:
- case FFEINTRIN_impIDINT:
- case FFEINTRIN_impIFIX:
- case FFEINTRIN_impINT2:
- case FFEINTRIN_impINT8:
- case FFEINTRIN_impINT:
- case FFEINTRIN_impLONG:
- case FFEINTRIN_impREAL:
- case FFEINTRIN_impSHORT:
- case FFEINTRIN_impSNGL:
- return convert (tree_type, ffecom_expr (arg1));
-
- case FFEINTRIN_impDIM:
- case FFEINTRIN_impDDIM:
- case FFEINTRIN_impIDIM:
- saved_expr1 = ffecom_save_tree (convert (tree_type,
- ffecom_expr (arg1)));
- saved_expr2 = ffecom_save_tree (convert (tree_type,
- ffecom_expr (arg2)));
- return
- ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (GT_EXPR, integer_type_node,
- saved_expr1,
- saved_expr2)),
- ffecom_2 (MINUS_EXPR, tree_type,
- saved_expr1,
- saved_expr2),
- convert (tree_type, ffecom_float_zero_));
-
- case FFEINTRIN_impDPROD:
- return
- ffecom_2 (MULT_EXPR, tree_type,
- convert (tree_type, ffecom_expr (arg1)),
- convert (tree_type, ffecom_expr (arg2)));
-
- case FFEINTRIN_impEXP:
- case FFEINTRIN_impCDEXP:
- case FFEINTRIN_impCEXP:
- case FFEINTRIN_impDEXP:
- if (bt == FFEINFO_basictypeCOMPLEX)
- {
- if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
- else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */
- }
- break;
-
- case FFEINTRIN_impICHAR:
- case FFEINTRIN_impIACHAR:
-#if 0 /* The simple approach. */
- ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
- expr_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
- expr_tree);
- expr_tree
- = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
- expr_tree,
- integer_one_node);
- return convert (tree_type, expr_tree);
-#else /* The more interesting (and more optimal) approach. */
- expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
- expr_tree = ffecom_3 (COND_EXPR, tree_type,
- saved_expr1,
- expr_tree,
- convert (tree_type, integer_zero_node));
- return expr_tree;
-#endif
-
- case FFEINTRIN_impINDEX:
- break;
-
- case FFEINTRIN_impLEN:
-#if 0
- break; /* The simple approach. */
-#else
- return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */
-#endif
-
- case FFEINTRIN_impLGE:
- case FFEINTRIN_impLGT:
- case FFEINTRIN_impLLE:
- case FFEINTRIN_impLLT:
- break;
-
- case FFEINTRIN_impLOG:
- case FFEINTRIN_impALOG:
- case FFEINTRIN_impCDLOG:
- case FFEINTRIN_impCLOG:
- case FFEINTRIN_impDLOG:
- if (bt == FFEINFO_basictypeCOMPLEX)
- {
- if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
- else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */
- }
- break;
-
- case FFEINTRIN_impLOG10:
- case FFEINTRIN_impALOG10:
- case FFEINTRIN_impDLOG10:
- if (gfrt != FFECOM_gfrt)
- break; /* Already picked one, stick with it. */
-
- if (kt == FFEINFO_kindtypeREAL1)
- /* We used to call FFECOM_gfrtALOG10 here. */
- gfrt = FFECOM_gfrtL_LOG10;
- else if (kt == FFEINFO_kindtypeREAL2)
- /* We used to call FFECOM_gfrtDLOG10 here. */
- gfrt = FFECOM_gfrtL_LOG10;
- break;
-
- case FFEINTRIN_impMAX:
- case FFEINTRIN_impAMAX0:
- case FFEINTRIN_impAMAX1:
- case FFEINTRIN_impDMAX1:
- case FFEINTRIN_impMAX0:
- case FFEINTRIN_impMAX1:
- if (bt != ffeinfo_basictype (ffebld_info (arg1)))
- arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
- else
- arg1_type = tree_type;
- expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
- convert (arg1_type, ffecom_expr (arg1)),
- convert (arg1_type, ffecom_expr (arg2)));
- for (; list != NULL; list = ffebld_trail (list))
- {
- if ((ffebld_head (list) == NULL)
- || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
- continue;
- expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
- expr_tree,
- convert (arg1_type,
- ffecom_expr (ffebld_head (list))));
- }
- return convert (tree_type, expr_tree);
-
- case FFEINTRIN_impMIN:
- case FFEINTRIN_impAMIN0:
- case FFEINTRIN_impAMIN1:
- case FFEINTRIN_impDMIN1:
- case FFEINTRIN_impMIN0:
- case FFEINTRIN_impMIN1:
- if (bt != ffeinfo_basictype (ffebld_info (arg1)))
- arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
- else
- arg1_type = tree_type;
- expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
- convert (arg1_type, ffecom_expr (arg1)),
- convert (arg1_type, ffecom_expr (arg2)));
- for (; list != NULL; list = ffebld_trail (list))
- {
- if ((ffebld_head (list) == NULL)
- || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
- continue;
- expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
- expr_tree,
- convert (arg1_type,
- ffecom_expr (ffebld_head (list))));
- }
- return convert (tree_type, expr_tree);
-
- case FFEINTRIN_impMOD:
- case FFEINTRIN_impAMOD:
- case FFEINTRIN_impDMOD:
- if (bt != FFEINFO_basictypeREAL)
- return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
- convert (tree_type, ffecom_expr (arg1)),
- convert (tree_type, ffecom_expr (arg2)));
-
- if (kt == FFEINFO_kindtypeREAL1)
- /* We used to call FFECOM_gfrtAMOD here. */
- gfrt = FFECOM_gfrtL_FMOD;
- else if (kt == FFEINFO_kindtypeREAL2)
- /* We used to call FFECOM_gfrtDMOD here. */
- gfrt = FFECOM_gfrtL_FMOD;
- break;
-
- case FFEINTRIN_impNINT:
- case FFEINTRIN_impIDNINT:
-#if 0
- /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
- return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
-#else
- /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
- saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
- return
- convert (ffecom_integer_type_node,
- ffecom_3 (COND_EXPR, arg1_type,
- ffecom_truth_value
- (ffecom_2 (GE_EXPR, integer_type_node,
- saved_expr1,
- convert (arg1_type,
- ffecom_float_zero_))),
- ffecom_2 (PLUS_EXPR, arg1_type,
- saved_expr1,
- convert (arg1_type,
- ffecom_float_half_)),
- ffecom_2 (MINUS_EXPR, arg1_type,
- saved_expr1,
- convert (arg1_type,
- ffecom_float_half_))));
-#endif
-
- case FFEINTRIN_impSIGN:
- case FFEINTRIN_impDSIGN:
- case FFEINTRIN_impISIGN:
- {
- tree arg2_tree = ffecom_expr (arg2);
-
- saved_expr1
- = ffecom_save_tree
- (ffecom_1 (ABS_EXPR, tree_type,
- convert (tree_type,
- ffecom_expr (arg1))));
- expr_tree
- = ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (GE_EXPR, integer_type_node,
- arg2_tree,
- convert (TREE_TYPE (arg2_tree),
- integer_zero_node))),
- saved_expr1,
- ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
- /* Make sure SAVE_EXPRs get referenced early enough. */
- expr_tree
- = ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node, saved_expr1),
- expr_tree);
- }
- return expr_tree;
-
- case FFEINTRIN_impSIN:
- case FFEINTRIN_impCDSIN:
- case FFEINTRIN_impCSIN:
- case FFEINTRIN_impDSIN:
- if (bt == FFEINFO_basictypeCOMPLEX)
- {
- if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
- else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */
- }
- break;
-
- case FFEINTRIN_impSINH:
- case FFEINTRIN_impDSINH:
- break;
-
- case FFEINTRIN_impSQRT:
- case FFEINTRIN_impCDSQRT:
- case FFEINTRIN_impCSQRT:
- case FFEINTRIN_impDSQRT:
- if (bt == FFEINFO_basictypeCOMPLEX)
- {
- if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */
- else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
- }
- break;
-
- case FFEINTRIN_impTAN:
- case FFEINTRIN_impDTAN:
- case FFEINTRIN_impTANH:
- case FFEINTRIN_impDTANH:
- break;
-
- case FFEINTRIN_impREALPART:
- if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
- arg1_type = TREE_TYPE (arg1_type);
- else
- arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
-
- return
- convert (tree_type,
- ffecom_1 (REALPART_EXPR, arg1_type,
- ffecom_expr (arg1)));
-
- case FFEINTRIN_impIAND:
- case FFEINTRIN_impAND:
- return ffecom_2 (BIT_AND_EXPR, tree_type,
- convert (tree_type,
- ffecom_expr (arg1)),
- convert (tree_type,
- ffecom_expr (arg2)));
-
- case FFEINTRIN_impIOR:
- case FFEINTRIN_impOR:
- return ffecom_2 (BIT_IOR_EXPR, tree_type,
- convert (tree_type,
- ffecom_expr (arg1)),
- convert (tree_type,
- ffecom_expr (arg2)));
-
- case FFEINTRIN_impIEOR:
- case FFEINTRIN_impXOR:
- return ffecom_2 (BIT_XOR_EXPR, tree_type,
- convert (tree_type,
- ffecom_expr (arg1)),
- convert (tree_type,
- ffecom_expr (arg2)));
-
- case FFEINTRIN_impLSHIFT:
- return ffecom_2 (LSHIFT_EXPR, tree_type,
- ffecom_expr (arg1),
- convert (integer_type_node,
- ffecom_expr (arg2)));
-
- case FFEINTRIN_impRSHIFT:
- return ffecom_2 (RSHIFT_EXPR, tree_type,
- ffecom_expr (arg1),
- convert (integer_type_node,
- ffecom_expr (arg2)));
-
- case FFEINTRIN_impNOT:
- return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
-
- case FFEINTRIN_impBIT_SIZE:
- return convert (tree_type, TYPE_SIZE (arg1_type));
-
- case FFEINTRIN_impBTEST:
- {
- ffetargetLogical1 target_true;
- ffetargetLogical1 target_false;
- tree true_tree;
- tree false_tree;
-
- ffetarget_logical1 (&target_true, TRUE);
- ffetarget_logical1 (&target_false, FALSE);
- if (target_true == 1)
- true_tree = convert (tree_type, integer_one_node);
- else
- true_tree = convert (tree_type, build_int_2 (target_true, 0));
- if (target_false == 0)
- false_tree = convert (tree_type, integer_zero_node);
- else
- false_tree = convert (tree_type, build_int_2 (target_false, 0));
-
- return
- ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_2 (BIT_AND_EXPR, arg1_type,
- ffecom_expr (arg1),
- ffecom_2 (LSHIFT_EXPR, arg1_type,
- convert (arg1_type,
- integer_one_node),
- convert (integer_type_node,
- ffecom_expr (arg2)))),
- convert (arg1_type,
- integer_zero_node))),
- false_tree,
- true_tree);
- }
-
- case FFEINTRIN_impIBCLR:
- return
- ffecom_2 (BIT_AND_EXPR, tree_type,
- ffecom_expr (arg1),
- ffecom_1 (BIT_NOT_EXPR, tree_type,
- ffecom_2 (LSHIFT_EXPR, tree_type,
- convert (tree_type,
- integer_one_node),
- convert (integer_type_node,
- ffecom_expr (arg2)))));
-
- case FFEINTRIN_impIBITS:
- {
- tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
- ffecom_expr (arg3)));
- tree uns_type
- = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
-
- expr_tree
- = ffecom_2 (BIT_AND_EXPR, tree_type,
- ffecom_2 (RSHIFT_EXPR, tree_type,
- ffecom_expr (arg1),
- convert (integer_type_node,
- ffecom_expr (arg2))),
- convert (tree_type,
- ffecom_2 (RSHIFT_EXPR, uns_type,
- ffecom_1 (BIT_NOT_EXPR,
- uns_type,
- convert (uns_type,
- integer_zero_node)),
- ffecom_2 (MINUS_EXPR,
- integer_type_node,
- TYPE_SIZE (uns_type),
- arg3_tree))));
- /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
- expr_tree
- = ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (NE_EXPR, integer_type_node,
- arg3_tree,
- integer_zero_node)),
- expr_tree,
- convert (tree_type, integer_zero_node));
- }
- return expr_tree;
-
- case FFEINTRIN_impIBSET:
- return
- ffecom_2 (BIT_IOR_EXPR, tree_type,
- ffecom_expr (arg1),
- ffecom_2 (LSHIFT_EXPR, tree_type,
- convert (tree_type, integer_one_node),
- convert (integer_type_node,
- ffecom_expr (arg2))));
-
- case FFEINTRIN_impISHFT:
- {
- tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
- tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
- ffecom_expr (arg2)));
- tree uns_type
- = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
-
- expr_tree
- = ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (GE_EXPR, integer_type_node,
- arg2_tree,
- integer_zero_node)),
- ffecom_2 (LSHIFT_EXPR, tree_type,
- arg1_tree,
- arg2_tree),
- convert (tree_type,
- ffecom_2 (RSHIFT_EXPR, uns_type,
- convert (uns_type, arg1_tree),
- ffecom_1 (NEGATE_EXPR,
- integer_type_node,
- arg2_tree))));
- /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
- expr_tree
- = ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (NE_EXPR, integer_type_node,
- ffecom_1 (ABS_EXPR,
- integer_type_node,
- arg2_tree),
- TYPE_SIZE (uns_type))),
- expr_tree,
- convert (tree_type, integer_zero_node));
- /* Make sure SAVE_EXPRs get referenced early enough. */
- expr_tree
- = ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node, arg1_tree),
- ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node, arg2_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impISHFTC:
- {
- tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
- tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
- ffecom_expr (arg2)));
- tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
- : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
- tree shift_neg;
- tree shift_pos;
- tree mask_arg1;
- tree masked_arg1;
- tree uns_type
- = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
-
- mask_arg1
- = ffecom_2 (LSHIFT_EXPR, tree_type,
- ffecom_1 (BIT_NOT_EXPR, tree_type,
- convert (tree_type, integer_zero_node)),
- arg3_tree);
- /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
- mask_arg1
- = ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (NE_EXPR, integer_type_node,
- arg3_tree,
- TYPE_SIZE (uns_type))),
- mask_arg1,
- convert (tree_type, integer_zero_node));
- mask_arg1 = ffecom_save_tree (mask_arg1);
- masked_arg1
- = ffecom_2 (BIT_AND_EXPR, tree_type,
- arg1_tree,
- ffecom_1 (BIT_NOT_EXPR, tree_type,
- mask_arg1));
- masked_arg1 = ffecom_save_tree (masked_arg1);
- shift_neg
- = ffecom_2 (BIT_IOR_EXPR, tree_type,
- convert (tree_type,
- ffecom_2 (RSHIFT_EXPR, uns_type,
- convert (uns_type, masked_arg1),
- ffecom_1 (NEGATE_EXPR,
- integer_type_node,
- arg2_tree))),
- ffecom_2 (LSHIFT_EXPR, tree_type,
- arg1_tree,
- ffecom_2 (PLUS_EXPR, integer_type_node,
- arg2_tree,
- arg3_tree)));
- shift_pos
- = ffecom_2 (BIT_IOR_EXPR, tree_type,
- ffecom_2 (LSHIFT_EXPR, tree_type,
- arg1_tree,
- arg2_tree),
- convert (tree_type,
- ffecom_2 (RSHIFT_EXPR, uns_type,
- convert (uns_type, masked_arg1),
- ffecom_2 (MINUS_EXPR,
- integer_type_node,
- arg3_tree,
- arg2_tree))));
- expr_tree
- = ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (LT_EXPR, integer_type_node,
- arg2_tree,
- integer_zero_node)),
- shift_neg,
- shift_pos);
- expr_tree
- = ffecom_2 (BIT_IOR_EXPR, tree_type,
- ffecom_2 (BIT_AND_EXPR, tree_type,
- mask_arg1,
- arg1_tree),
- ffecom_2 (BIT_AND_EXPR, tree_type,
- ffecom_1 (BIT_NOT_EXPR, tree_type,
- mask_arg1),
- expr_tree));
- expr_tree
- = ffecom_3 (COND_EXPR, tree_type,
- ffecom_truth_value
- (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
- ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_1 (ABS_EXPR,
- integer_type_node,
- arg2_tree),
- arg3_tree),
- ffecom_2 (EQ_EXPR, integer_type_node,
- arg2_tree,
- integer_zero_node))),
- arg1_tree,
- expr_tree);
- /* Make sure SAVE_EXPRs get referenced early enough. */
- expr_tree
- = ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node, arg1_tree),
- ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node, arg2_tree),
- ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node,
- mask_arg1),
- ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node,
- masked_arg1),
- expr_tree))));
- expr_tree
- = ffecom_2 (COMPOUND_EXPR, tree_type,
- convert (void_type_node,
- arg3_tree),
- expr_tree);
- }
- return expr_tree;
-
- case FFEINTRIN_impLOC:
- {
- tree arg1_tree = ffecom_expr (arg1);
-
- expr_tree
- = convert (tree_type,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impMVBITS:
- {
- tree arg1_tree;
- tree arg2_tree;
- tree arg3_tree;
- ffebld arg4 = ffebld_head (ffebld_trail (list));
- tree arg4_tree;
- tree arg4_type;
- ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
- tree arg5_tree;
- tree prep_arg1;
- tree prep_arg4;
- tree arg5_plus_arg3;
-
- arg2_tree = convert (integer_type_node,
- ffecom_expr (arg2));
- arg3_tree = ffecom_save_tree (convert (integer_type_node,
- ffecom_expr (arg3)));
- arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
- arg4_type = TREE_TYPE (arg4_tree);
-
- arg1_tree = ffecom_save_tree (convert (arg4_type,
- ffecom_expr (arg1)));
-
- arg5_tree = ffecom_save_tree (convert (integer_type_node,
- ffecom_expr (arg5)));
-
- prep_arg1
- = ffecom_2 (LSHIFT_EXPR, arg4_type,
- ffecom_2 (BIT_AND_EXPR, arg4_type,
- ffecom_2 (RSHIFT_EXPR, arg4_type,
- arg1_tree,
- arg2_tree),
- ffecom_1 (BIT_NOT_EXPR, arg4_type,
- ffecom_2 (LSHIFT_EXPR, arg4_type,
- ffecom_1 (BIT_NOT_EXPR,
- arg4_type,
- convert
- (arg4_type,
- integer_zero_node)),
- arg3_tree))),
- arg5_tree);
- arg5_plus_arg3
- = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
- arg5_tree,
- arg3_tree));
- prep_arg4
- = ffecom_2 (LSHIFT_EXPR, arg4_type,
- ffecom_1 (BIT_NOT_EXPR, arg4_type,
- convert (arg4_type,
- integer_zero_node)),
- arg5_plus_arg3);
- /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
- prep_arg4
- = ffecom_3 (COND_EXPR, arg4_type,
- ffecom_truth_value
- (ffecom_2 (NE_EXPR, integer_type_node,
- arg5_plus_arg3,
- convert (TREE_TYPE (arg5_plus_arg3),
- TYPE_SIZE (arg4_type)))),
- prep_arg4,
- convert (arg4_type, integer_zero_node));
- prep_arg4
- = ffecom_2 (BIT_AND_EXPR, arg4_type,
- arg4_tree,
- ffecom_2 (BIT_IOR_EXPR, arg4_type,
- prep_arg4,
- ffecom_1 (BIT_NOT_EXPR, arg4_type,
- ffecom_2 (LSHIFT_EXPR, arg4_type,
- ffecom_1 (BIT_NOT_EXPR,
- arg4_type,
- convert
- (arg4_type,
- integer_zero_node)),
- arg5_tree))));
- prep_arg1
- = ffecom_2 (BIT_IOR_EXPR, arg4_type,
- prep_arg1,
- prep_arg4);
- /* Fix up (twice), because LSHIFT_EXPR above
- can't shift over TYPE_SIZE. */
- prep_arg1
- = ffecom_3 (COND_EXPR, arg4_type,
- ffecom_truth_value
- (ffecom_2 (NE_EXPR, integer_type_node,
- arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- integer_zero_node))),
- prep_arg1,
- arg4_tree);
- prep_arg1
- = ffecom_3 (COND_EXPR, arg4_type,
- ffecom_truth_value
- (ffecom_2 (NE_EXPR, integer_type_node,
- arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- TYPE_SIZE (arg4_type)))),
- prep_arg1,
- arg1_tree);
- expr_tree
- = ffecom_2s (MODIFY_EXPR, void_type_node,
- arg4_tree,
- prep_arg1);
- /* Make sure SAVE_EXPRs get referenced early enough. */
- expr_tree
- = ffecom_2 (COMPOUND_EXPR, void_type_node,
- arg1_tree,
- ffecom_2 (COMPOUND_EXPR, void_type_node,
- arg3_tree,
- ffecom_2 (COMPOUND_EXPR, void_type_node,
- arg5_tree,
- ffecom_2 (COMPOUND_EXPR, void_type_node,
- arg5_plus_arg3,
- expr_tree))));
- expr_tree
- = ffecom_2 (COMPOUND_EXPR, void_type_node,
- arg4_tree,
- expr_tree);
-
- }
- return expr_tree;
-
- case FFEINTRIN_impDERF:
- case FFEINTRIN_impERF:
- case FFEINTRIN_impDERFC:
- case FFEINTRIN_impERFC:
- break;
-
- case FFEINTRIN_impIARGC:
- /* extern int xargc; i__1 = xargc - 1; */
- expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
- ffecom_tree_xargc_,
- convert (TREE_TYPE (ffecom_tree_xargc_),
- integer_one_node));
- return expr_tree;
-
- case FFEINTRIN_impSIGNAL_func:
- case FFEINTRIN_impSIGNAL_subr:
- {
- tree arg1_tree;
- tree arg2_tree;
- tree arg3_tree;
-
- arg1_tree = convert (ffecom_f2c_integer_type_node,
- ffecom_expr (arg1));
- arg1_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree);
-
- /* Pass procedure as a pointer to it, anything else by value. */
- if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
- arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
- else
- arg2_tree = ffecom_ptr_to_expr (arg2);
- arg2_tree = convert (TREE_TYPE (null_pointer_node),
- arg2_tree);
-
- if (arg3 != NULL)
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
- else
- arg3_tree = NULL_TREE;
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- TREE_CHAIN (arg1_tree) = arg2_tree;
-
- expr_tree
- = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
- NULL_TREE :
- tree_type),
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
-
- if (arg3_tree != NULL_TREE)
- expr_tree
- = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impALARM:
- {
- tree arg1_tree;
- tree arg2_tree;
- tree arg3_tree;
-
- arg1_tree = convert (ffecom_f2c_integer_type_node,
- ffecom_expr (arg1));
- arg1_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree);
-
- /* Pass procedure as a pointer to it, anything else by value. */
- if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
- arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
- else
- arg2_tree = ffecom_ptr_to_expr (arg2);
- arg2_tree = convert (TREE_TYPE (null_pointer_node),
- arg2_tree);
-
- if (arg3 != NULL)
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
- else
- arg3_tree = NULL_TREE;
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- TREE_CHAIN (arg1_tree) = arg2_tree;
-
- expr_tree
- = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
-
- if (arg3_tree != NULL_TREE)
- expr_tree
- = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impCHDIR_subr:
- case FFEINTRIN_impFDATE_subr:
- case FFEINTRIN_impFGET_subr:
- case FFEINTRIN_impFPUT_subr:
- case FFEINTRIN_impGETCWD_subr:
- case FFEINTRIN_impHOSTNM_subr:
- case FFEINTRIN_impSYSTEM_subr:
- case FFEINTRIN_impUNLINK_subr:
- {
- tree arg1_len = integer_zero_node;
- tree arg1_tree;
- tree arg2_tree;
-
- arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
-
- if (arg2 != NULL)
- arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
- else
- arg2_tree = NULL_TREE;
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg1_len = build_tree_list (NULL_TREE, arg1_len);
- TREE_CHAIN (arg1_tree) = arg1_len;
-
- expr_tree
- = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
-
- if (arg2_tree != NULL_TREE)
- expr_tree
- = ffecom_modify (NULL_TREE, arg2_tree,
- convert (TREE_TYPE (arg2_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impEXIT:
- if (arg1 != NULL)
- break;
-
- expr_tree = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type
- (ffecom_integer_type_node),
- integer_zero_node));
-
- return
- ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- void_type_node,
- expr_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
-
- case FFEINTRIN_impFLUSH:
- if (arg1 == NULL)
- gfrt = FFECOM_gfrtFLUSH;
- else
- gfrt = FFECOM_gfrtFLUSH1;
- break;
-
- case FFEINTRIN_impCHMOD_subr:
- case FFEINTRIN_impLINK_subr:
- case FFEINTRIN_impRENAME_subr:
- case FFEINTRIN_impSYMLNK_subr:
- {
- tree arg1_len = integer_zero_node;
- tree arg1_tree;
- tree arg2_len = integer_zero_node;
- tree arg2_tree;
- tree arg3_tree;
-
- arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
- arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
- if (arg3 != NULL)
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
- else
- arg3_tree = NULL_TREE;
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg1_len = build_tree_list (NULL_TREE, arg1_len);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- arg2_len = build_tree_list (NULL_TREE, arg2_len);
- TREE_CHAIN (arg1_tree) = arg2_tree;
- TREE_CHAIN (arg2_tree) = arg1_len;
- TREE_CHAIN (arg1_len) = arg2_len;
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
- if (arg3_tree != NULL_TREE)
- expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impLSTAT_subr:
- case FFEINTRIN_impSTAT_subr:
- {
- tree arg1_len = integer_zero_node;
- tree arg1_tree;
- tree arg2_tree;
- tree arg3_tree;
-
- arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
-
- arg2_tree = ffecom_ptr_to_expr (arg2);
-
- if (arg3 != NULL)
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
- else
- arg3_tree = NULL_TREE;
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg1_len = build_tree_list (NULL_TREE, arg1_len);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- TREE_CHAIN (arg1_tree) = arg2_tree;
- TREE_CHAIN (arg2_tree) = arg1_len;
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
- if (arg3_tree != NULL_TREE)
- expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impFGETC_subr:
- case FFEINTRIN_impFPUTC_subr:
- {
- tree arg1_tree;
- tree arg2_tree;
- tree arg2_len = integer_zero_node;
- tree arg3_tree;
-
- arg1_tree = convert (ffecom_f2c_integer_type_node,
- ffecom_expr (arg1));
- arg1_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree);
-
- arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
- if (arg3 != NULL)
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
- else
- arg3_tree = NULL_TREE;
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- arg2_len = build_tree_list (NULL_TREE, arg2_len);
- TREE_CHAIN (arg1_tree) = arg2_tree;
- TREE_CHAIN (arg2_tree) = arg2_len;
-
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
- if (arg3_tree != NULL_TREE)
- expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impFSTAT_subr:
- {
- tree arg1_tree;
- tree arg2_tree;
- tree arg3_tree;
-
- arg1_tree = convert (ffecom_f2c_integer_type_node,
- ffecom_expr (arg1));
- arg1_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree);
-
- arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
- ffecom_ptr_to_expr (arg2));
-
- if (arg3 == NULL)
- arg3_tree = NULL_TREE;
- else
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- TREE_CHAIN (arg1_tree) = arg2_tree;
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
- if (arg3_tree != NULL_TREE) {
- expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
- }
- }
- return expr_tree;
-
- case FFEINTRIN_impKILL_subr:
- {
- tree arg1_tree;
- tree arg2_tree;
- tree arg3_tree;
-
- arg1_tree = convert (ffecom_f2c_integer_type_node,
- ffecom_expr (arg1));
- arg1_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree);
-
- arg2_tree = convert (ffecom_f2c_integer_type_node,
- ffecom_expr (arg2));
- arg2_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg2_tree)),
- arg2_tree);
-
- if (arg3 == NULL)
- arg3_tree = NULL_TREE;
- else
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- TREE_CHAIN (arg1_tree) = arg2_tree;
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
- if (arg3_tree != NULL_TREE) {
- expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
- }
- }
- return expr_tree;
-
- case FFEINTRIN_impCTIME_subr:
- case FFEINTRIN_impTTYNAM_subr:
- {
- tree arg1_len = integer_zero_node;
- tree arg1_tree;
- tree arg2_tree;
-
- arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
-
- arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
- ffecom_f2c_longint_type_node :
- ffecom_f2c_integer_type_node),
- ffecom_expr (arg1));
- arg2_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg2_tree)),
- arg2_tree);
-
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
- arg1_len = build_tree_list (NULL_TREE, arg1_len);
- arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
- TREE_CHAIN (arg1_len) = arg2_tree;
- TREE_CHAIN (arg1_tree) = arg1_len;
-
- expr_tree
- = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
- TREE_SIDE_EFFECTS (expr_tree) = 1;
- }
- return expr_tree;
-
- case FFEINTRIN_impIRAND:
- case FFEINTRIN_impRAND:
- /* Arg defaults to 0 (normal random case) */
- {
- tree arg1_tree;
-
- if (arg1 == NULL)
- arg1_tree = ffecom_integer_zero_node;
- else
- arg1_tree = ffecom_expr (arg1);
- arg1_tree = convert (ffecom_f2c_integer_type_node,
- arg1_tree);
- arg1_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree);
- arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
-
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- ((codegen_imp == FFEINTRIN_impIRAND) ?
- ffecom_f2c_integer_type_node :
- ffecom_f2c_real_type_node),
- arg1_tree,
- dest_tree, dest, dest_used,
- NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
- }
- return expr_tree;
-
- case FFEINTRIN_impFTELL_subr:
- case FFEINTRIN_impUMASK_subr:
- {
- tree arg1_tree;
- tree arg2_tree;
-
- arg1_tree = convert (ffecom_f2c_integer_type_node,
- ffecom_expr (arg1));
- arg1_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (arg1_tree)),
- arg1_tree);
-
- if (arg2 == NULL)
- arg2_tree = NULL_TREE;
- else
- arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
-
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- build_tree_list (NULL_TREE, arg1_tree),
- NULL_TREE, NULL, NULL, NULL_TREE,
- TRUE,
- ffebld_nonter_hook (expr));
- if (arg2_tree != NULL_TREE) {
- expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
- convert (TREE_TYPE (arg2_tree),
- expr_tree));
- }
- }
- return expr_tree;
-
- case FFEINTRIN_impCPU_TIME:
- case FFEINTRIN_impSECOND_subr:
- {
- tree arg1_tree;
-
- arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
-
- expr_tree
- = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- NULL_TREE,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
-
- expr_tree
- = ffecom_modify (NULL_TREE, arg1_tree,
- convert (TREE_TYPE (arg1_tree),
- expr_tree));
- }
- return expr_tree;
-
- case FFEINTRIN_impDTIME_subr:
- case FFEINTRIN_impETIME_subr:
- {
- tree arg1_tree;
- tree result_tree;
-
- result_tree = ffecom_expr_w (NULL_TREE, arg2);
-
- arg1_tree = ffecom_ptr_to_expr (arg1);
-
- expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
- ffecom_gfrt_kindtype (gfrt),
- FALSE,
- NULL_TREE,
- build_tree_list (NULL_TREE, arg1_tree),
- NULL_TREE, NULL, NULL, NULL_TREE,
- TRUE,
- ffebld_nonter_hook (expr));
- expr_tree = ffecom_modify (NULL_TREE, result_tree,
- convert (TREE_TYPE (result_tree),
- expr_tree));
- }
- return expr_tree;
-
- /* Straightforward calls of libf2c routines: */
- case FFEINTRIN_impABORT:
- case FFEINTRIN_impACCESS:
- case FFEINTRIN_impBESJ0:
- case FFEINTRIN_impBESJ1:
- case FFEINTRIN_impBESJN:
- case FFEINTRIN_impBESY0:
- case FFEINTRIN_impBESY1:
- case FFEINTRIN_impBESYN:
- case FFEINTRIN_impCHDIR_func:
- case FFEINTRIN_impCHMOD_func:
- case FFEINTRIN_impDATE:
- case FFEINTRIN_impDATE_AND_TIME:
- case FFEINTRIN_impDBESJ0:
- case FFEINTRIN_impDBESJ1:
- case FFEINTRIN_impDBESJN:
- case FFEINTRIN_impDBESY0:
- case FFEINTRIN_impDBESY1:
- case FFEINTRIN_impDBESYN:
- case FFEINTRIN_impDTIME_func:
- case FFEINTRIN_impETIME_func:
- case FFEINTRIN_impFGETC_func:
- case FFEINTRIN_impFGET_func:
- case FFEINTRIN_impFNUM:
- case FFEINTRIN_impFPUTC_func:
- case FFEINTRIN_impFPUT_func:
- case FFEINTRIN_impFSEEK:
- case FFEINTRIN_impFSTAT_func:
- case FFEINTRIN_impFTELL_func:
- case FFEINTRIN_impGERROR:
- case FFEINTRIN_impGETARG:
- case FFEINTRIN_impGETCWD_func:
- case FFEINTRIN_impGETENV:
- case FFEINTRIN_impGETGID:
- case FFEINTRIN_impGETLOG:
- case FFEINTRIN_impGETPID:
- case FFEINTRIN_impGETUID:
- case FFEINTRIN_impGMTIME:
- case FFEINTRIN_impHOSTNM_func:
- case FFEINTRIN_impIDATE_unix:
- case FFEINTRIN_impIDATE_vxt:
- case FFEINTRIN_impIERRNO:
- case FFEINTRIN_impISATTY:
- case FFEINTRIN_impITIME:
- case FFEINTRIN_impKILL_func:
- case FFEINTRIN_impLINK_func:
- case FFEINTRIN_impLNBLNK:
- case FFEINTRIN_impLSTAT_func:
- case FFEINTRIN_impLTIME:
- case FFEINTRIN_impMCLOCK8:
- case FFEINTRIN_impMCLOCK:
- case FFEINTRIN_impPERROR:
- case FFEINTRIN_impRENAME_func:
- case FFEINTRIN_impSECNDS:
- case FFEINTRIN_impSECOND_func:
- case FFEINTRIN_impSLEEP:
- case FFEINTRIN_impSRAND:
- case FFEINTRIN_impSTAT_func:
- case FFEINTRIN_impSYMLNK_func:
- case FFEINTRIN_impSYSTEM_CLOCK:
- case FFEINTRIN_impSYSTEM_func:
- case FFEINTRIN_impTIME8:
- case FFEINTRIN_impTIME_unix:
- case FFEINTRIN_impTIME_vxt:
- case FFEINTRIN_impUMASK_func:
- case FFEINTRIN_impUNLINK_func:
- break;
-
- case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
- case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
- case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */
- case FFEINTRIN_impNONE:
- case FFEINTRIN_imp: /* Hush up gcc warning. */
- fprintf (stderr, "No %s implementation.\n",
- ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
- assert ("unimplemented intrinsic" == NULL);
- return error_mark_node;
- }
-
- assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
-
- expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
- ffebld_right (expr));
-
- return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
- (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
- tree_type,
- expr_tree, dest_tree, dest, dest_used,
- NULL_TREE, TRUE,
- ffebld_nonter_hook (expr));
-
- /* See bottom of this file for f2c transforms used to determine
- many of the above implementations. The info seems to confuse
- Emacs's C mode indentation, which is why it's been moved to
- the bottom of this source file. */
-}
-
-/* For power (exponentiation) where right-hand operand is type INTEGER,
- generate in-line code to do it the fast way (which, if the operand
- is a constant, might just mean a series of multiplies). */
-
-static tree
-ffecom_expr_power_integer_ (ffebld expr)
-{
- tree l = ffecom_expr (ffebld_left (expr));
- tree r = ffecom_expr (ffebld_right (expr));
- tree ltype = TREE_TYPE (l);
- tree rtype = TREE_TYPE (r);
- tree result = NULL_TREE;
-
- if (l == error_mark_node
- || r == error_mark_node)
- return error_mark_node;
-
- if (TREE_CODE (r) == INTEGER_CST)
- {
- int sgn = tree_int_cst_sgn (r);
-
- if (sgn == 0)
- return convert (ltype, integer_one_node);
-
- if ((TREE_CODE (ltype) == INTEGER_TYPE)
- && (sgn < 0))
- {
- /* Reciprocal of integer is either 0, -1, or 1, so after
- calculating that (which we leave to the back end to do
- or not do optimally), don't bother with any multiplying. */
-
- result = ffecom_tree_divide_ (ltype,
- convert (ltype, integer_one_node),
- l,
- NULL_TREE, NULL, NULL, NULL_TREE);
- r = ffecom_1 (NEGATE_EXPR,
- rtype,
- r);
- if ((TREE_INT_CST_LOW (r) & 1) == 0)
- result = ffecom_1 (ABS_EXPR, rtype,
- result);
- }
-
- /* Generate appropriate series of multiplies, preceded
- by divide if the exponent is negative. */
-
- l = save_expr (l);
-
- if (sgn < 0)
- {
- l = ffecom_tree_divide_ (ltype,
- convert (ltype, integer_one_node),
- l,
- NULL_TREE, NULL, NULL,
- ffebld_nonter_hook (expr));
- r = ffecom_1 (NEGATE_EXPR, rtype, r);
- assert (TREE_CODE (r) == INTEGER_CST);
-
- if (tree_int_cst_sgn (r) < 0)
- { /* The "most negative" number. */
- r = ffecom_1 (NEGATE_EXPR, rtype,
- ffecom_2 (RSHIFT_EXPR, rtype,
- r,
- integer_one_node));
- l = save_expr (l);
- l = ffecom_2 (MULT_EXPR, ltype,
- l,
- l);
- }
- }
-
- for (;;)
- {
- if (TREE_INT_CST_LOW (r) & 1)
- {
- if (result == NULL_TREE)
- result = l;
- else
- result = ffecom_2 (MULT_EXPR, ltype,
- result,
- l);
- }
-
- r = ffecom_2 (RSHIFT_EXPR, rtype,
- r,
- integer_one_node);
- if (integer_zerop (r))
- break;
- assert (TREE_CODE (r) == INTEGER_CST);
-
- l = save_expr (l);
- l = ffecom_2 (MULT_EXPR, ltype,
- l,
- l);
- }
- return result;
- }
-
- /* Though rhs isn't a constant, in-line code cannot be expanded
- while transforming dummies
- because the back end cannot be easily convinced to generate
- stores (MODIFY_EXPR), handle temporaries, and so on before
- all the appropriate rtx's have been generated for things like
- dummy args referenced in rhs -- which doesn't happen until
- store_parm_decls() is called (expand_function_start, I believe,
- does the actual rtx-stuffing of PARM_DECLs).
-
- So, in this case, let the caller generate the call to the
- run-time-library function to evaluate the power for us. */
-
- if (ffecom_transform_only_dummies_)
- return NULL_TREE;
-
- /* Right-hand operand not a constant, expand in-line code to figure
- out how to do the multiplies, &c.
-
- The returned expression is expressed this way in GNU C, where l and
- r are the "inputs":
-
- ({ typeof (r) rtmp = r;
- typeof (l) ltmp = l;
- typeof (l) result;
-
- if (rtmp == 0)
- result = 1;
- else
- {
- if ((basetypeof (l) == basetypeof (int))
- && (rtmp < 0))
- {
- result = ((typeof (l)) 1) / ltmp;
- if ((ltmp < 0) && (((-rtmp) & 1) == 0))
- result = -result;
- }
- else
- {
- result = 1;
- if ((basetypeof (l) != basetypeof (int))
- && (rtmp < 0))
- {
- ltmp = ((typeof (l)) 1) / ltmp;
- rtmp = -rtmp;
- if (rtmp < 0)
- {
- rtmp = -(rtmp >> 1);
- ltmp *= ltmp;
- }
- }
- for (;;)
- {
- if (rtmp & 1)
- result *= ltmp;
- if ((rtmp >>= 1) == 0)
- break;
- ltmp *= ltmp;
- }
- }
- }
- result;
- })
-
- Note that some of the above is compile-time collapsable, such as
- the first part of the if statements that checks the base type of
- l against int. The if statements are phrased that way to suggest
- an easy way to generate the if/else constructs here, knowing that
- the back end should (and probably does) eliminate the resulting
- dead code (either the int case or the non-int case), something
- it couldn't do without the redundant phrasing, requiring explicit
- dead-code elimination here, which would be kind of difficult to
- read. */
-
- {
- tree rtmp;
- tree ltmp;
- tree divide;
- tree basetypeof_l_is_int;
- tree se;
- tree t;
-
- basetypeof_l_is_int
- = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
-
- se = expand_start_stmt_expr (/*has_scope=*/1);
-
- ffecom_start_compstmt ();
-
- rtmp = ffecom_make_tempvar ("power_r", rtype,
- FFETARGET_charactersizeNONE, -1);
- ltmp = ffecom_make_tempvar ("power_l", ltype,
- FFETARGET_charactersizeNONE, -1);
- result = ffecom_make_tempvar ("power_res", ltype,
- FFETARGET_charactersizeNONE, -1);
- if (TREE_CODE (ltype) == COMPLEX_TYPE
- || TREE_CODE (ltype) == RECORD_TYPE)
- divide = ffecom_make_tempvar ("power_div", ltype,
- FFETARGET_charactersizeNONE, -1);
- else
- divide = NULL_TREE;
-
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- r));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- l));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (EQ_EXPR, integer_type_node,
- rtmp,
- convert (rtype, integer_zero_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- convert (ltype, integer_one_node)));
- expand_start_else ();
- if (! integer_zerop (basetypeof_l_is_int))
- {
- expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype,
- integer_zero_node)),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_tree_divide_
- (ltype,
- convert (ltype, integer_one_node),
- ltmp,
- NULL_TREE, NULL, NULL,
- divide)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_2 (LT_EXPR, integer_type_node,
- ltmp,
- convert (ltype,
- integer_zero_node)),
- ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_2 (BIT_AND_EXPR,
- rtype,
- ffecom_1 (NEGATE_EXPR,
- rtype,
- rtmp),
- convert (rtype,
- integer_one_node)),
- convert (rtype,
- integer_zero_node)))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_1 (NEGATE_EXPR,
- ltype,
- result)));
- expand_end_cond ();
- expand_start_else ();
- }
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- convert (ltype, integer_one_node)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_truth_value_invert
- (basetypeof_l_is_int),
- ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype,
- integer_zero_node)))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_tree_divide_
- (ltype,
- convert (ltype, integer_one_node),
- ltmp,
- NULL_TREE, NULL, NULL,
- divide)));
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- ffecom_1 (NEGATE_EXPR, rtype,
- rtmp)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype, integer_zero_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- ffecom_1 (NEGATE_EXPR, rtype,
- ffecom_2 (RSHIFT_EXPR,
- rtype,
- rtmp,
- integer_one_node))));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_2 (MULT_EXPR, ltype,
- ltmp,
- ltmp)));
- expand_end_cond ();
- expand_end_cond ();
- expand_start_loop (1);
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (BIT_AND_EXPR, rtype,
- rtmp,
- convert (rtype, integer_one_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_2 (MULT_EXPR, ltype,
- result,
- ltmp)));
- expand_end_cond ();
- expand_exit_loop_if_false (NULL,
- ffecom_truth_value
- (ffecom_modify (rtype,
- rtmp,
- ffecom_2 (RSHIFT_EXPR,
- rtype,
- rtmp,
- integer_one_node))));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_2 (MULT_EXPR, ltype,
- ltmp,
- ltmp)));
- expand_end_loop ();
- expand_end_cond ();
- if (!integer_zerop (basetypeof_l_is_int))
- expand_end_cond ();
- expand_expr_stmt (result);
-
- t = ffecom_end_compstmt ();
-
- result = expand_end_stmt_expr (se);
-
- /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
-
- if (TREE_CODE (t) == BLOCK)
- {
- /* Make a BIND_EXPR for the BLOCK already made. */
- result = build (BIND_EXPR, TREE_TYPE (result),
- NULL_TREE, result, t);
- /* Remove the block from the tree at this point.
- It gets put back at the proper place
- when the BIND_EXPR is expanded. */
- delete_block (t);
- }
- else
- result = t;
- }
-
- return result;
-}
-
-/* ffecom_expr_transform_ -- Transform symbols in expr
-
- ffebld expr; // FFE expression.
- ffecom_expr_transform_ (expr);
-
- Recursive descent on expr while transforming any untransformed SYMTERs. */
-
-static void
-ffecom_expr_transform_ (ffebld expr)
-{
- tree t;
- ffesymbol s;
-
- tail_recurse:
-
- if (expr == NULL)
- return;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- s = ffebld_symter (expr);
- t = ffesymbol_hook (s).decl_tree;
- if ((t == NULL_TREE)
- && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
- || ((ffesymbol_where (s) != FFEINFO_whereNONE)
- && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
- {
- s = ffecom_sym_transform_ (s);
- t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
- DIMENSION expr? */
- }
- break; /* Ok if (t == NULL) here. */
-
- case FFEBLD_opITEM:
- ffecom_expr_transform_ (ffebld_head (expr));
- expr = ffebld_trail (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- switch (ffebld_arity (expr))
- {
- case 2:
- ffecom_expr_transform_ (ffebld_left (expr));
- expr = ffebld_right (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- case 1:
- expr = ffebld_left (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- return;
-}
-
-/* Make a type based on info in live f2c.h file. */
-
-static void
-ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
-{
- switch (tcode)
- {
- case FFECOM_f2ccodeCHAR:
- *type = make_signed_type (CHAR_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeSHORT:
- *type = make_signed_type (SHORT_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeINT:
- *type = make_signed_type (INT_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeLONG:
- *type = make_signed_type (LONG_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeLONGLONG:
- *type = make_signed_type (LONG_LONG_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeCHARPTR:
- *type = build_pointer_type (DEFAULT_SIGNED_CHAR
- ? signed_char_type_node
- : unsigned_char_type_node);
- break;
-
- case FFECOM_f2ccodeFLOAT:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
- layout_type (*type);
- break;
-
- case FFECOM_f2ccodeDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
-
- case FFECOM_f2ccodeLONGDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
-
- case FFECOM_f2ccodeTWOREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
- break;
-
- case FFECOM_f2ccodeTWODOUBLEREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
- break;
-
- default:
- assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
- *type = error_mark_node;
- return;
- }
-
- pushdecl (build_decl (TYPE_DECL,
- ffecom_get_invented_identifier ("__g77_f2c_%s", name),
- *type));
-}
-
-/* Set the f2c list-directed-I/O code for whatever (integral) type has the
- given size. */
-
-static void
-ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, int code)
-{
- int j;
- tree t;
-
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
- && compare_tree_int (TYPE_SIZE (t), size) == 0)
- {
- assert (code != -1);
- ffecom_f2c_typecode_[bt][j] = code;
- code = -1;
- }
-}
-
-/* Finish up globals after doing all program units in file
-
- Need to handle only uninitialized COMMON areas. */
-
-static ffeglobal
-ffecom_finish_global_ (ffeglobal global)
-{
- tree cbtype;
- tree cbt;
- tree size;
-
- if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
- return global;
-
- if (ffeglobal_common_init (global))
- return global;
-
- cbt = ffeglobal_hook (global);
- if ((cbt == NULL_TREE)
- || !ffeglobal_common_have_size (global))
- return global; /* No need to make common, never ref'd. */
-
- DECL_EXTERNAL (cbt) = 0;
-
- /* Give the array a size now. */
-
- size = build_int_2 ((ffeglobal_common_size (global)
- + ffeglobal_common_pad (global)) - 1,
- 0);
-
- cbtype = TREE_TYPE (cbt);
- TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
- integer_zero_node,
- size);
- if (!TREE_TYPE (size))
- TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
- layout_type (cbtype);
-
- cbt = start_decl (cbt, FALSE);
- assert (cbt == ffeglobal_hook (global));
-
- finish_decl (cbt, NULL_TREE, FALSE);
-
- return global;
-}
-
-/* Finish up any untransformed symbols. */
-
-static ffesymbol
-ffecom_finish_symbol_transform_ (ffesymbol s)
-{
- if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
- return s;
-
- /* It's easy to know to transform an untransformed symbol, to make sure
- we put out debugging info for it. But COMMON variables, unlike
- EQUIVALENCE ones, aren't given declarations in addition to the
- tree expressions that specify offsets, because COMMON variables
- can be referenced in the outer scope where only dummy arguments
- (PARM_DECLs) should really be seen. To be safe, just don't do any
- VAR_DECLs for COMMON variables when we transform them for real
- use, and therefore we do all the VAR_DECL creating here. */
-
- if (ffesymbol_hook (s).decl_tree == NULL_TREE)
- {
- if (ffesymbol_kind (s) != FFEINFO_kindNONE
- || (ffesymbol_where (s) != FFEINFO_whereNONE
- && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
- && ffesymbol_where (s) != FFEINFO_whereDUMMY))
- /* Not transformed, and not CHARACTER*(*), and not a dummy
- argument, which can happen only if the entry point names
- it "rides in on" are all invalidated for other reasons. */
- s = ffecom_sym_transform_ (s);
- }
-
- if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
- && (ffesymbol_hook (s).decl_tree != error_mark_node))
- {
- /* This isn't working, at least for dbxout. The .s file looks
- okay to me (burley), but in gdb 4.9 at least, the variables
- appear to reside somewhere outside of the common area, so
- it doesn't make sense to mislead anyone by generating the info
- on those variables until this is fixed. NOTE: Same problem
- with EQUIVALENCE, sadly...see similar #if later. */
- ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
- ffesymbol_storage (s));
- }
-
- return s;
-}
-
-/* Append underscore(s) to name before calling get_identifier. "us"
- is nonzero if the name already contains an underscore and thus
- needs two underscores appended. */
-
-static tree
-ffecom_get_appended_identifier_ (char us, const char *name)
-{
- int i;
- char *newname;
- tree id;
-
- newname = xmalloc ((i = strlen (name)) + 1
- + ffe_is_underscoring ()
- + us);
- memcpy (newname, name, i);
- newname[i] = '_';
- newname[i + us] = '_';
- newname[i + 1 + us] = '\0';
- id = get_identifier (newname);
-
- free (newname);
-
- return id;
-}
-
-/* Decide whether to append underscore to name before calling
- get_identifier. */
-
-static tree
-ffecom_get_external_identifier_ (ffesymbol s)
-{
- char us;
- const char *name = ffesymbol_text (s);
-
- /* If name is a built-in name, just return it as is. */
-
- if (!ffe_is_underscoring ()
- || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
- || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
- || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
- return get_identifier (name);
-
- us = ffe_is_second_underscore ()
- ? (strchr (name, '_') != NULL)
- : 0;
-
- return ffecom_get_appended_identifier_ (us, name);
-}
-
-/* Decide whether to append underscore to internal name before calling
- get_identifier.
-
- This is for non-external, top-function-context names only. Transform
- identifier so it doesn't conflict with the transformed result
- of using a _different_ external name. E.g. if "CALL FOO" is
- transformed into "FOO_();", then the variable in "FOO_ = 3"
- must be transformed into something that does not conflict, since
- these two things should be independent.
-
- The transformation is as follows. If the name does not contain
- an underscore, there is no possible conflict, so just return.
- If the name does contain an underscore, then transform it just
- like we transform an external identifier. */
-
-static tree
-ffecom_get_identifier_ (const char *name)
-{
- /* If name does not contain an underscore, just return it as is. */
-
- if (!ffe_is_underscoring ()
- || (strchr (name, '_') == NULL))
- return get_identifier (name);
-
- return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
- name);
-}
-
-/* ffecom_gen_sfuncdef_ -- Generate definition of statement function
-
- tree t;
- ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
- t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
- ffesymbol_kindtype(s));
-
- Call after setting up containing function and getting trees for all
- other symbols. */
-
-static tree
-ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
-{
- ffebld expr = ffesymbol_sfexpr (s);
- tree type;
- tree func;
- tree result;
- bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
- static bool recurse = FALSE;
- location_t old_loc = input_location;
-
- ffecom_nested_entry_ = s;
-
- /* For now, we don't have a handy pointer to where the sfunc is actually
- defined, though that should be easy to add to an ffesymbol. (The
- token/where info available might well point to the place where the type
- of the sfunc is declared, especially if that precedes the place where
- the sfunc itself is defined, which is typically the case.) We should
- put out a null pointer rather than point somewhere wrong, but I want to
- see how it works at this point. */
-
- input_filename = ffesymbol_where_filename (s);
- input_line = ffesymbol_where_filelinenum (s);
-
- /* Pretransform the expression so any newly discovered things belong to the
- outer program unit, not to the statement function. */
-
- ffecom_expr_transform_ (expr);
-
- /* Make sure no recursive invocation of this fn (a specific case of failing
- to pretransform an sfunc's expression, i.e. where its expression
- references another untransformed sfunc) happens. */
-
- assert (!recurse);
- recurse = TRUE;
-
- push_f_function_context ();
-
- if (charfunc)
- type = void_type_node;
- else
- {
- type = ffecom_tree_type[bt][kt];
- if (type == NULL_TREE)
- type = integer_type_node; /* _sym_exec_transition reports
- error. */
- }
-
- start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
- build_function_type (type, NULL_TREE),
- 1, /* nested/inline */
- 0); /* TREE_PUBLIC */
-
- /* We don't worry about COMPLEX return values here, because this is
- entirely internal to our code, and gcc has the ability to return COMPLEX
- directly as a value. */
-
- if (charfunc)
- { /* Prepend arg for where result goes. */
- tree type;
-
- type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
-
- result = ffecom_get_invented_identifier ("__g77_%s", "result");
-
- ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
-
- type = build_pointer_type (type);
- result = build_decl (PARM_DECL, result, type);
-
- push_parm_decl (result);
- }
- else
- result = NULL_TREE; /* Not ref'd if !charfunc. */
-
- ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
-
- store_parm_decls (0);
-
- ffecom_start_compstmt ();
-
- if (expr != NULL)
- {
- if (charfunc)
- {
- ffetargetCharacterSize sz = ffesymbol_size (s);
- tree result_length;
-
- result_length = build_int_2 (sz, 0);
- TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
-
- ffecom_prepare_let_char_ (sz, expr);
-
- ffecom_prepare_end ();
-
- ffecom_let_char_ (result, result_length, sz, expr);
- expand_null_return ();
- }
- else
- {
- ffecom_prepare_expr (expr);
-
- ffecom_prepare_end ();
-
- expand_return (ffecom_modify (NULL_TREE,
- DECL_RESULT (current_function_decl),
- ffecom_expr (expr)));
- }
- }
-
- ffecom_end_compstmt ();
-
- func = current_function_decl;
- finish_function (1);
-
- pop_f_function_context ();
-
- recurse = FALSE;
-
- input_location = old_loc;
-
- ffecom_nested_entry_ = NULL;
-
- return func;
-}
-
-static const char *
-ffecom_gfrt_args_ (ffecomGfrt ix)
-{
- return ffecom_gfrt_argstring_[ix];
-}
-
-static tree
-ffecom_gfrt_tree_ (ffecomGfrt ix)
-{
- if (ffecom_gfrt_[ix] == NULL_TREE)
- ffecom_make_gfrt_ (ix);
-
- return ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
- ffecom_gfrt_[ix]);
-}
-
-/* Return initialize-to-zero expression for this VAR_DECL. */
-
-/* A somewhat evil way to prevent the garbage collector
- from collecting 'tree' structures. */
-#define NUM_TRACKED_CHUNK 63
-struct tree_ggc_tracker GTY(())
-{
- struct tree_ggc_tracker *next;
- tree trees[NUM_TRACKED_CHUNK];
-};
-static GTY(()) struct tree_ggc_tracker *tracker_head;
-
-void
-ffecom_save_tree_forever (tree t)
-{
- int i;
- if (tracker_head != NULL)
- for (i = 0; i < NUM_TRACKED_CHUNK; i++)
- if (tracker_head->trees[i] == NULL)
- {
- tracker_head->trees[i] = t;
- return;
- }
-
- {
- /* Need to allocate a new block. */
- struct tree_ggc_tracker *old_head = tracker_head;
-
- tracker_head = ggc_alloc (sizeof (*tracker_head));
- tracker_head->next = old_head;
- tracker_head->trees[0] = t;
- for (i = 1; i < NUM_TRACKED_CHUNK; i++)
- tracker_head->trees[i] = NULL;
- }
-}
-
-static tree
-ffecom_init_zero_ (tree decl)
-{
- tree init;
- int incremental = TREE_STATIC (decl);
- tree type = TREE_TYPE (decl);
-
- if (incremental)
- {
- make_decl_rtl (decl, NULL);
- assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
- }
-
- if ((TREE_CODE (type) != ARRAY_TYPE)
- && (TREE_CODE (type) != RECORD_TYPE)
- && (TREE_CODE (type) != UNION_TYPE)
- && !incremental)
- init = convert (type, integer_zero_node);
- else if (!incremental)
- {
- init = build_constructor (type, NULL_TREE);
- TREE_CONSTANT (init) = 1;
- TREE_STATIC (init) = 1;
- }
- else
- {
- assemble_zeros (int_size_in_bytes (type));
- init = error_mark_node;
- }
-
- return init;
-}
-
-static tree
-ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, tree *maybe_tree)
-{
- tree expr_tree;
- tree length_tree;
-
- switch (ffebld_op (arg))
- {
- case FFEBLD_opCONTER: /* For F90, check 0-length. */
- if (ffetarget_length_character1
- (ffebld_constant_character1
- (ffebld_conter (arg))) == 0)
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
-
- *maybe_tree = integer_one_node;
- expr_tree = build_int_2 (*ffetarget_text_character1
- (ffebld_constant_character1
- (ffebld_conter (arg))),
- 0);
- TREE_TYPE (expr_tree) = tree_type;
- return expr_tree;
-
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opFUNCREF:
- case FFEBLD_opSUBSTR:
- ffecom_char_args_ (&expr_tree, &length_tree, arg);
-
- if ((expr_tree == error_mark_node)
- || (length_tree == error_mark_node))
- {
- *maybe_tree = error_mark_node;
- return error_mark_node;
- }
-
- if (integer_zerop (length_tree))
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
-
- expr_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
- expr_tree);
- expr_tree
- = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
- expr_tree,
- integer_one_node);
- expr_tree = convert (tree_type, expr_tree);
-
- if (TREE_CODE (length_tree) == INTEGER_CST)
- *maybe_tree = integer_one_node;
- else /* Must check length at run time. */
- *maybe_tree
- = ffecom_truth_value
- (ffecom_2 (GT_EXPR, integer_type_node,
- length_tree,
- ffecom_f2c_ftnlen_zero_node));
- return expr_tree;
-
- case FFEBLD_opPAREN:
- case FFEBLD_opCONVERT:
- if (ffeinfo_size (ffebld_info (arg)) == 0)
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
- return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
- maybe_tree);
-
- case FFEBLD_opCONCATENATE:
- {
- tree maybe_left;
- tree maybe_right;
- tree expr_left;
- tree expr_right;
-
- expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
- &maybe_left);
- expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
- &maybe_right);
- *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
- maybe_left,
- maybe_right);
- expr_tree = ffecom_3 (COND_EXPR, tree_type,
- maybe_left,
- expr_left,
- expr_right);
- return expr_tree;
- }
-
- default:
- assert ("bad op in ICHAR" == NULL);
- return error_mark_node;
- }
-}
-
-/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
-
- tree length_arg;
- ffebld expr;
- length_arg = ffecom_intrinsic_len_ (expr);
-
- Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
- subexpressions by constructing the appropriate tree for the
- length-of-character-text argument in a calling sequence. */
-
-static tree
-ffecom_intrinsic_len_ (ffebld expr)
-{
- ffetargetCharacter1 val;
- tree length;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opCONTER:
- val = ffebld_constant_character1 (ffebld_conter (expr));
- length = build_int_2 (ffetarget_length_character1 (val), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- break;
-
- case FFEBLD_opSYMTER:
- {
- ffesymbol s = ffebld_symter (expr);
- tree item;
-
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
- if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
- {
- if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
- length = ffesymbol_hook (s).length_tree;
- else
- {
- length = build_int_2 (ffesymbol_size (s), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- }
- }
- else if (item == error_mark_node)
- length = error_mark_node;
- else /* FFEINFO_kindFUNCTION: */
- length = NULL_TREE;
- }
- break;
-
- case FFEBLD_opARRAYREF:
- length = ffecom_intrinsic_len_ (ffebld_left (expr));
- break;
-
- case FFEBLD_opSUBSTR:
- {
- ffebld start;
- ffebld end;
- ffebld thing = ffebld_right (expr);
- tree start_tree;
- tree end_tree;
-
- assert (ffebld_op (thing) == FFEBLD_opITEM);
- start = ffebld_head (thing);
- thing = ffebld_trail (thing);
- assert (ffebld_trail (thing) == NULL);
- end = ffebld_head (thing);
-
- length = ffecom_intrinsic_len_ (ffebld_left (expr));
-
- if (length == error_mark_node)
- break;
-
- if (start == NULL)
- {
- if (end == NULL)
- ;
- else
- {
- length = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (end));
- }
- }
- else
- {
- start_tree = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (start));
-
- if (start_tree == error_mark_node)
- {
- length = error_mark_node;
- break;
- }
-
- if (end == NULL)
- {
- length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- ffecom_2 (MINUS_EXPR,
- ffecom_f2c_ftnlen_type_node,
- length,
- start_tree));
- }
- else
- {
- end_tree = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (end));
-
- if (end_tree == error_mark_node)
- {
- length = error_mark_node;
- break;
- }
-
- length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- ffecom_2 (MINUS_EXPR,
- ffecom_f2c_ftnlen_type_node,
- end_tree, start_tree));
- }
- }
- }
- break;
-
- case FFEBLD_opCONCATENATE:
- length
- = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_intrinsic_len_ (ffebld_left (expr)),
- ffecom_intrinsic_len_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opFUNCREF:
- case FFEBLD_opCONVERT:
- length = build_int_2 (ffebld_size (expr), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- break;
-
- default:
- assert ("bad op for single char arg expr" == NULL);
- length = ffecom_f2c_ftnlen_zero_node;
- break;
- }
-
- assert (length != NULL_TREE);
-
- return length;
-}
-
-/* Handle CHARACTER assignments.
-
- Generates code to do the assignment. Used by ordinary assignment
- statement handler ffecom_let_stmt and by statement-function
- handler to generate code for a statement function. */
-
-static void
-ffecom_let_char_ (tree dest_tree, tree dest_length,
- ffetargetCharacterSize dest_size, ffebld source)
-{
- ffecomConcatList_ catlist;
- tree source_length;
- tree source_tree;
- tree expr_tree;
-
- if ((dest_tree == error_mark_node)
- || (dest_length == error_mark_node))
- return;
-
- assert (dest_tree != NULL_TREE);
- assert (dest_length != NULL_TREE);
-
- /* Source might be an opCONVERT, which just means it is a different size
- than the destination. Since the underlying implementation here handles
- that (directly or via the s_copy or s_cat run-time-library functions),
- we don't need the "convenience" of an opCONVERT that tells us to
- truncate or blank-pad, particularly since the resulting implementation
- would probably be slower than otherwise. */
-
- while (ffebld_op (source) == FFEBLD_opCONVERT)
- source = ffebld_left (source);
-
- catlist = ffecom_concat_list_new_ (source, dest_size);
- switch (ffecom_concat_list_count_ (catlist))
- {
- case 0: /* Shouldn't happen, but in case it does... */
- ffecom_concat_list_kill_ (catlist);
- source_tree = null_pointer_node;
- source_length = ffecom_f2c_ftnlen_zero_node;
- expr_tree = build_tree_list (NULL_TREE, dest_tree);
- TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
- TREE_CHAIN (TREE_CHAIN (expr_tree))
- = build_tree_list (NULL_TREE, dest_length);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
- = build_tree_list (NULL_TREE, source_length);
-
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
-
- expand_expr_stmt (expr_tree);
-
- return;
-
- case 1: /* The (fairly) easy case. */
- ffecom_char_args_ (&source_tree, &source_length,
- ffecom_concat_list_expr_ (catlist, 0));
- ffecom_concat_list_kill_ (catlist);
- assert (source_tree != NULL_TREE);
- assert (source_length != NULL_TREE);
-
- if ((source_tree == error_mark_node)
- || (source_length == error_mark_node))
- return;
-
- if (dest_size == 1)
- {
- dest_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (dest_tree))),
- dest_tree);
- dest_tree
- = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (dest_tree))),
- dest_tree,
- integer_one_node);
- source_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (source_tree))),
- source_tree);
- source_tree
- = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (source_tree))),
- source_tree,
- integer_one_node);
-
- expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
-
- expand_expr_stmt (expr_tree);
-
- return;
- }
-
- expr_tree = build_tree_list (NULL_TREE, dest_tree);
- TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
- TREE_CHAIN (TREE_CHAIN (expr_tree))
- = build_tree_list (NULL_TREE, dest_length);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
- = build_tree_list (NULL_TREE, source_length);
-
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
-
- expand_expr_stmt (expr_tree);
-
- return;
-
- default: /* Must actually concatenate things. */
- break;
- }
-
- /* Heavy-duty concatenation. */
-
- {
- int count = ffecom_concat_list_count_ (catlist);
- int i;
- tree lengths;
- tree items;
- tree length_array;
- tree item_array;
- tree citem;
- tree clength;
-
- {
- tree hook;
-
- hook = ffebld_nonter_hook (source);
- assert (hook);
- assert (TREE_CODE (hook) == TREE_VEC);
- assert (TREE_VEC_LENGTH (hook) == 2);
- length_array = lengths = TREE_VEC_ELT (hook, 0);
- item_array = items = TREE_VEC_ELT (hook, 1);
- }
-
- for (i = 0; i < count; ++i)
- {
- ffecom_char_args_ (&citem, &clength,
- ffecom_concat_list_expr_ (catlist, i));
- if ((citem == error_mark_node)
- || (clength == error_mark_node))
- {
- ffecom_concat_list_kill_ (catlist);
- return;
- }
-
- items
- = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
- ffecom_modify (void_type_node,
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
- item_array,
- build_int_2 (i, 0)),
- citem),
- items);
- lengths
- = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
- ffecom_modify (void_type_node,
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
- length_array,
- build_int_2 (i, 0)),
- clength),
- lengths);
- }
-
- expr_tree = build_tree_list (NULL_TREE, dest_tree);
- TREE_CHAIN (expr_tree)
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (items)),
- items));
- TREE_CHAIN (TREE_CHAIN (expr_tree))
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (lengths)),
- lengths));
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
- = build_tree_list
- (NULL_TREE,
- ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
- convert (ffecom_f2c_ftnlen_type_node,
- build_int_2 (count, 0))));
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
- = build_tree_list (NULL_TREE, dest_length);
-
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
-
- expand_expr_stmt (expr_tree);
- }
-
- ffecom_concat_list_kill_ (catlist);
-}
-
-/* ffecom_make_gfrt_ -- Make initial info for run-time routine
-
- ffecomGfrt ix;
- ffecom_make_gfrt_(ix);
-
- Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
- for the indicated run-time routine (ix). */
-
-static void
-ffecom_make_gfrt_ (ffecomGfrt ix)
-{
- tree t;
- tree ttype;
-
- switch (ffecom_gfrt_type_[ix])
- {
- case FFECOM_rttypeVOID_:
- ttype = void_type_node;
- break;
-
- case FFECOM_rttypeVOIDSTAR_:
- ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
- break;
-
- case FFECOM_rttypeFTNINT_:
- ttype = ffecom_f2c_ftnint_type_node;
- break;
-
- case FFECOM_rttypeINTEGER_:
- ttype = ffecom_f2c_integer_type_node;
- break;
-
- case FFECOM_rttypeLONGINT_:
- ttype = ffecom_f2c_longint_type_node;
- break;
-
- case FFECOM_rttypeLOGICAL_:
- ttype = ffecom_f2c_logical_type_node;
- break;
-
- case FFECOM_rttypeREAL_F2C_:
- ttype = double_type_node;
- break;
-
- case FFECOM_rttypeREAL_GNU_:
- ttype = float_type_node;
- break;
-
- case FFECOM_rttypeCOMPLEX_F2C_:
- ttype = void_type_node;
- break;
-
- case FFECOM_rttypeCOMPLEX_GNU_:
- ttype = ffecom_f2c_complex_type_node;
- break;
-
- case FFECOM_rttypeDOUBLE_:
- ttype = double_type_node;
- break;
-
- case FFECOM_rttypeDOUBLEREAL_:
- ttype = ffecom_f2c_doublereal_type_node;
- break;
-
- case FFECOM_rttypeDBLCMPLX_F2C_:
- ttype = void_type_node;
- break;
-
- case FFECOM_rttypeDBLCMPLX_GNU_:
- ttype = ffecom_f2c_doublecomplex_type_node;
- break;
-
- case FFECOM_rttypeCHARACTER_:
- ttype = void_type_node;
- break;
-
- default:
- ttype = NULL;
- assert ("bad rttype" == NULL);
- break;
- }
-
- ttype = build_function_type (ttype, NULL_TREE);
- t = build_decl (FUNCTION_DECL,
- get_identifier (ffecom_gfrt_name_[ix]),
- ttype);
- DECL_EXTERNAL (t) = 1;
- TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
- TREE_PUBLIC (t) = 1;
- TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
-
- /* Sanity check: A function that's const cannot be volatile. */
-
- assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
-
- /* Sanity check: A function that's const cannot return complex. */
-
- assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
-
- t = start_decl (t, TRUE);
-
- finish_decl (t, NULL_TREE, TRUE);
-
- ffecom_gfrt_[ix] = t;
-}
-
-/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
-
-static void
-ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
-{
- ffesymbol s = ffestorag_symbol (st);
-
- if (ffesymbol_namelisted (s))
- ffecom_member_namelisted_ = TRUE;
-}
-
-/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
- the member so debugger will see it. Otherwise nobody should be
- referencing the member. */
-
-static void
-ffecom_member_phase2_ (ffestorag mst, ffestorag st)
-{
- ffesymbol s;
- tree t;
- tree mt;
- tree type;
-
- if ((mst == NULL)
- || ((mt = ffestorag_hook (mst)) == NULL)
- || (mt == error_mark_node))
- return;
-
- if ((st == NULL)
- || ((s = ffestorag_symbol (st)) == NULL))
- return;
-
- type = ffecom_type_localvar_ (s,
- ffesymbol_basictype (s),
- ffesymbol_kindtype (s));
- if (type == error_mark_node)
- return;
-
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- type);
-
- TREE_STATIC (t) = TREE_STATIC (mt);
- DECL_INITIAL (t) = NULL_TREE;
- TREE_ASM_WRITTEN (t) = 1;
- TREE_USED (t) = 1;
-
- SET_DECL_RTL (t,
- gen_rtx (MEM, TYPE_MODE (type),
- plus_constant (XEXP (DECL_RTL (mt), 0),
- ffestorag_modulo (mst)
- + ffestorag_offset (st)
- - ffestorag_offset (mst))));
-
- t = start_decl (t, FALSE);
-
- finish_decl (t, NULL_TREE, FALSE);
-}
-
-/* Prepare source expression for assignment into a destination perhaps known
- to be of a specific size. */
-
-static void
-ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
-{
- ffecomConcatList_ catlist;
- int count;
- int i;
- tree ltmp;
- tree itmp;
- tree tempvar = NULL_TREE;
-
- while (ffebld_op (source) == FFEBLD_opCONVERT)
- source = ffebld_left (source);
-
- catlist = ffecom_concat_list_new_ (source, dest_size);
- count = ffecom_concat_list_count_ (catlist);
-
- if (count >= 2)
- {
- ltmp
- = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
- FFETARGET_charactersizeNONE, count);
- itmp
- = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
- FFETARGET_charactersizeNONE, count);
-
- tempvar = make_tree_vec (2);
- TREE_VEC_ELT (tempvar, 0) = ltmp;
- TREE_VEC_ELT (tempvar, 1) = itmp;
- }
-
- for (i = 0; i < count; ++i)
- ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
-
- ffecom_concat_list_kill_ (catlist);
-
- if (tempvar)
- {
- ffebld_nonter_set_hook (source, tempvar);
- current_binding_level->prep_state = 1;
- }
-}
-
-/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
-
- Ignores STAR (alternate-return) dummies. All other get exec-transitioned
- (which generates their trees) and then their trees get push_parm_decl'd.
-
- The second arg is TRUE if the dummies are for a statement function, in
- which case lengths are not pushed for character arguments (since they are
- always known by both the caller and the callee, though the code allows
- for someday permitting CHAR*(*) stmtfunc dummies). */
-
-static void
-ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
-{
- ffebld dummy;
- ffebld dumlist;
- ffesymbol s;
- tree parm;
-
- ffecom_transform_only_dummies_ = TRUE;
-
- /* First push the parms corresponding to actual dummy "contents". */
-
- for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
- {
- dummy = ffebld_head (dumlist);
- switch (ffebld_op (dummy))
- {
- case FFEBLD_opSTAR:
- case FFEBLD_opANY:
- continue; /* Forget alternate returns. */
-
- default:
- break;
- }
- assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
- s = ffebld_symter (dummy);
- parm = ffesymbol_hook (s).decl_tree;
- if (parm == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- parm = ffesymbol_hook (s).decl_tree;
- assert (parm != NULL_TREE);
- }
- if (parm != error_mark_node)
- push_parm_decl (parm);
- }
-
- /* Then, for CHARACTER dummies, push the parms giving their lengths. */
-
- for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
- {
- dummy = ffebld_head (dumlist);
- switch (ffebld_op (dummy))
- {
- case FFEBLD_opSTAR:
- case FFEBLD_opANY:
- continue; /* Forget alternate returns, they mean
- NOTHING! */
-
- default:
- break;
- }
- s = ffebld_symter (dummy);
- if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
- continue; /* Only looking for CHARACTER arguments. */
- if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
- continue; /* Stmtfunc arg with known size needs no
- length param. */
- if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
- continue; /* Only looking for variables and arrays. */
- parm = ffesymbol_hook (s).length_tree;
- assert (parm != NULL_TREE);
- if (parm != error_mark_node)
- push_parm_decl (parm);
- }
-
- ffecom_transform_only_dummies_ = FALSE;
-}
-
-/* ffecom_start_progunit_ -- Beginning of program unit
-
- Does GNU back end stuff necessary to teach it about the start of its
- equivalent of a Fortran program unit. */
-
-static void
-ffecom_start_progunit_ (void)
-{
- ffesymbol fn = ffecom_primary_entry_;
- ffebld arglist;
- tree id; /* Identifier (name) of function. */
- tree type; /* Type of function. */
- tree result; /* Result of function. */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeglobal g;
- ffeglobalType gt;
- ffeglobalType egt = FFEGLOBAL_type;
- bool charfunc;
- bool cmplxfunc;
- bool altentries = (ffecom_num_entrypoints_ != 0);
- bool multi
- = altentries
- && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
- && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
- bool main_program = FALSE;
- location_t old_loc = input_location;
-
- assert (fn != NULL);
- assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
-
- input_filename = ffesymbol_where_filename (fn);
- input_line = ffesymbol_where_filelinenum (fn);
-
- switch (ffecom_primary_entry_kind_)
- {
- case FFEINFO_kindPROGRAM:
- main_program = TRUE;
- gt = FFEGLOBAL_typeMAIN;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = ffecom_tree_fun_type_void;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
-
- case FFEINFO_kindBLOCKDATA:
- gt = FFEGLOBAL_typeBDATA;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = ffecom_tree_fun_type_void;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
-
- case FFEINFO_kindFUNCTION:
- gt = FFEGLOBAL_typeFUNC;
- egt = FFEGLOBAL_typeEXT;
- bt = ffesymbol_basictype (fn);
- kt = ffesymbol_kindtype (fn);
- if (bt == FFEINFO_basictypeNONE)
- {
- ffeimplic_establish_symbol (fn);
- if (ffesymbol_funcresult (fn) != NULL)
- ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
- bt = ffesymbol_basictype (fn);
- kt = ffesymbol_kindtype (fn);
- }
-
- if (multi)
- charfunc = cmplxfunc = FALSE;
- else if (bt == FFEINFO_basictypeCHARACTER)
- charfunc = TRUE, cmplxfunc = FALSE;
- else if ((bt == FFEINFO_basictypeCOMPLEX)
- && ffesymbol_is_f2c (fn)
- && !altentries)
- charfunc = FALSE, cmplxfunc = TRUE;
- else
- charfunc = cmplxfunc = FALSE;
-
- if (multi || charfunc)
- type = ffecom_tree_fun_type_void;
- else if (ffesymbol_is_f2c (fn) && !altentries)
- type = ffecom_tree_fun_type[bt][kt];
- else
- type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
-
- if ((type == NULL_TREE)
- || (TREE_TYPE (type) == NULL_TREE))
- type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
- break;
-
- case FFEINFO_kindSUBROUTINE:
- gt = FFEGLOBAL_typeSUBR;
- egt = FFEGLOBAL_typeEXT;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- if (ffecom_is_altreturning_)
- type = ffecom_tree_subr_type;
- else
- type = ffecom_tree_fun_type_void;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
-
- default:
- assert ("say what??" == NULL);
- /* Fall through. */
- case FFEINFO_kindANY:
- gt = FFEGLOBAL_typeANY;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = error_mark_node;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
- }
-
- if (altentries)
- {
- id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
- ffesymbol_text (fn));
- }
-#if FFETARGET_isENFORCED_MAIN
- else if (main_program)
- id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
-#endif
- else
- id = ffecom_get_external_identifier_ (fn);
-
- start_function (id,
- type,
- 0, /* nested/inline */
- !altentries); /* TREE_PUBLIC */
-
- TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
-
- if (!altentries
- && ((g = ffesymbol_global (fn)) != NULL)
- && ((ffeglobal_type (g) == gt)
- || (ffeglobal_type (g) == egt)))
- {
- ffeglobal_set_hook (g, current_function_decl);
- }
-
- /* Arg handling needs exec-transitioned ffesymbols to work with. But
- exec-transitioning needs current_function_decl to be filled in. So we
- do these things in two phases. */
-
- if (altentries)
- { /* 1st arg identifies which entrypoint. */
- ffecom_which_entrypoint_decl_
- = build_decl (PARM_DECL,
- ffecom_get_invented_identifier ("__g77_%s",
- "which_entrypoint"),
- integer_type_node);
- push_parm_decl (ffecom_which_entrypoint_decl_);
- }
-
- if (charfunc
- || cmplxfunc
- || multi)
- { /* Arg for result (return value). */
- tree type;
- tree length;
-
- if (charfunc)
- type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
- else if (cmplxfunc)
- type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
- else
- type = ffecom_multi_type_node_;
-
- result = ffecom_get_invented_identifier ("__g77_%s", "result");
-
- /* Make length arg _and_ enhance type info for CHAR arg itself. */
-
- if (charfunc)
- length = ffecom_char_enhance_arg_ (&type, fn);
- else
- length = NULL_TREE; /* Not ref'd if !charfunc. */
-
- type = build_pointer_type (type);
- result = build_decl (PARM_DECL, result, type);
-
- push_parm_decl (result);
- if (multi)
- ffecom_multi_retval_ = result;
- else
- ffecom_func_result_ = result;
-
- if (charfunc)
- {
- push_parm_decl (length);
- ffecom_func_length_ = length;
- }
- }
-
- if (ffecom_primary_entry_is_proc_)
- {
- if (altentries)
- arglist = ffecom_master_arglist_;
- else
- arglist = ffesymbol_dummyargs (fn);
- ffecom_push_dummy_decls_ (arglist, FALSE);
- }
-
- if (TREE_CODE (current_function_decl) != ERROR_MARK)
- store_parm_decls (main_program ? 1 : 0);
-
- ffecom_start_compstmt ();
- /* Disallow temp vars at this level. */
- current_binding_level->prep_state = 2;
-
- input_location = old_loc;
-
- /* This handles any symbols still untransformed, in case -g specified.
- This used to be done in ffecom_finish_progunit, but it turns out to
- be necessary to do it here so that statement functions are
- expanded before code. But don't bother for BLOCK DATA. */
-
- if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
- ffesymbol_drive (ffecom_finish_symbol_transform_);
-}
-
-/* ffecom_sym_transform_ -- Transform FFE sym into backend sym
-
- ffesymbol s;
- ffecom_sym_transform_(s);
-
- The ffesymbol_hook info for s is updated with appropriate backend info
- on the symbol. */
-
-static ffesymbol
-ffecom_sym_transform_ (ffesymbol s)
-{
- tree t; /* Transformed thingy. */
- tree tlen; /* Length if CHAR*(*). */
- bool addr; /* Is t the address of the thingy? */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeglobal g;
- location_t old_loc = input_location;
-
- /* Must ensure special ASSIGN variables are declared at top of outermost
- block, else they'll end up in the innermost block when their first
- ASSIGN is seen, which leaves them out of scope when they're the
- subject of a GOTO or I/O statement.
-
- We make this variable even if -fugly-assign. Just let it go unused,
- in case it turns out there are cases where we really want to use this
- variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
-
- if (! ffecom_transform_only_dummies_
- && ffesymbol_assigned (s)
- && ! ffesymbol_hook (s).assign_tree)
- s = ffecom_sym_transform_assign_ (s);
-
- if (ffesymbol_sfdummyparent (s) == NULL)
- {
- input_filename = ffesymbol_where_filename (s);
- input_line = ffesymbol_where_filelinenum (s);
- }
- else
- {
- ffesymbol sf = ffesymbol_sfdummyparent (s);
-
- input_filename = ffesymbol_where_filename (sf);
- input_line = ffesymbol_where_filelinenum (sf);
- }
-
- bt = ffeinfo_basictype (ffebld_info (s));
- kt = ffeinfo_kindtype (ffebld_info (s));
-
- t = NULL_TREE;
- tlen = NULL_TREE;
- addr = FALSE;
-
- switch (ffesymbol_kind (s))
- {
- case FFEINFO_kindNONE:
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereDUMMY: /* Subroutine or function. */
- assert (ffecom_transform_only_dummies_);
-
- /* Before 0.4, this could be ENTITY/DUMMY, but see
- ffestu_sym_end_transition -- no longer true (in particular, if
- it could be an ENTITY, it _will_ be made one, so that
- possibility won't come through here). So we never make length
- arg for CHARACTER type. */
-
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_ptr_to_subr_type);
- DECL_ARTIFICIAL (t) = 1;
- addr = TRUE;
- break;
-
- case FFEINFO_whereGLOBAL: /* Subroutine or function. */
- assert (!ffecom_transform_only_dummies_);
-
- if (((g = ffesymbol_global (s)) != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
- && (ffeglobal_hook (g) != NULL_TREE)
- && ffe_is_globals ())
- {
- t = ffeglobal_hook (g);
- break;
- }
-
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_subr_type); /* Assume subr. */
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
-
- ffecom_save_tree_forever (t);
-
- break;
-
- default:
- assert ("NONE where unexpected" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- break;
- }
- break;
-
- case FFEINFO_kindENTITY:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
-
- case FFEINFO_whereCONSTANT:
- /* ~~Debugging info needed? */
- assert (!ffecom_transform_only_dummies_);
- t = error_mark_node; /* Shouldn't ever see this in expr. */
- break;
-
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
-
- {
- ffestorag st = ffesymbol_storage (s);
- tree type;
-
- type = ffecom_type_localvar_ (s, bt, kt);
-
- if (type == error_mark_node)
- {
- t = error_mark_node;
- break;
- }
-
- if ((st != NULL)
- && (ffestorag_size (st) == 0))
- {
- t = error_mark_node;
- break;
- }
-
- if ((st != NULL)
- && (ffestorag_parent (st) != NULL))
- { /* Child of EQUIVALENCE parent. */
- ffestorag est;
- tree et;
- ffetargetOffset offset;
-
- est = ffestorag_parent (st);
- ffecom_transform_equiv_ (est);
-
- et = ffestorag_hook (est);
- assert (et != NULL_TREE);
-
- if (! TREE_STATIC (et))
- put_var_into_stack (et, /*rescan=*/true);
-
- offset = ffestorag_modulo (est)
- + ffestorag_offset (ffesymbol_storage (s))
- - ffestorag_offset (est);
-
- ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
-
- /* (t_type *) (((char *) &et) + offset) */
-
- t = convert (string_type_node, /* (char *) */
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (et)),
- et));
- t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
- t,
- build_int_2 (offset, 0));
- t = convert (build_pointer_type (type),
- t);
- TREE_CONSTANT (t) = staticp (et);
-
- addr = TRUE;
- }
- else
- {
- tree initexpr;
- bool init = ffesymbol_is_init (s);
-
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- type);
-
- if (init
- || ffesymbol_namelisted (s)
-#ifdef FFECOM_sizeMAXSTACKITEM
- || ((st != NULL)
- && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
-#endif
- || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
- && (ffecom_primary_entry_kind_
- != FFEINFO_kindBLOCKDATA)
- && (ffesymbol_is_save (s) || ffe_is_saveall ())))
- TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
- else
- TREE_STATIC (t) = 0; /* No need to make static. */
-
- if (init || ffe_is_init_local_zero ())
- DECL_INITIAL (t) = error_mark_node;
-
- /* Keep -Wunused from complaining about var if it
- is used as sfunc arg or DATA implied-DO. */
- if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
- DECL_IN_SYSTEM_HEADER (t) = 1;
-
- t = start_decl (t, FALSE);
-
- if (init)
- {
- if (ffesymbol_init (s) != NULL)
- initexpr = ffecom_expr (ffesymbol_init (s));
- else
- initexpr = ffecom_init_zero_ (t);
- }
- else if (ffe_is_init_local_zero ())
- initexpr = ffecom_init_zero_ (t);
- else
- initexpr = NULL_TREE; /* Not ref'd if !init. */
-
- finish_decl (t, initexpr, FALSE);
-
- if (st != NULL && DECL_SIZE (t) != error_mark_node)
- {
- assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
- assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
- ffestorag_size (st)));
- }
- }
- }
- break;
-
- case FFEINFO_whereRESULT:
- assert (!ffecom_transform_only_dummies_);
-
- if (bt == FFEINFO_basictypeCHARACTER)
- { /* Result is already in list of dummies, use
- it (& length). */
- t = ffecom_func_result_;
- tlen = ffecom_func_length_;
- addr = TRUE;
- break;
- }
- if ((ffecom_num_entrypoints_ == 0)
- && (bt == FFEINFO_basictypeCOMPLEX)
- && (ffesymbol_is_f2c (ffecom_primary_entry_)))
- { /* Result is already in list of dummies, use
- it. */
- t = ffecom_func_result_;
- addr = TRUE;
- break;
- }
- if (ffecom_func_result_ != NULL_TREE)
- {
- t = ffecom_func_result_;
- break;
- }
- if ((ffecom_num_entrypoints_ != 0)
- && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
- {
- assert (ffecom_multi_retval_ != NULL_TREE);
- t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
- ffecom_multi_retval_);
- t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
- t, ffecom_multi_fields_[bt][kt]);
-
- break;
- }
-
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_type[bt][kt]);
- TREE_STATIC (t) = 0; /* Put result on stack. */
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- ffecom_func_result_ = t;
-
- break;
-
- case FFEINFO_whereDUMMY:
- {
- tree type;
- ffebld dl;
- ffebld dim;
- tree low;
- tree high;
- tree old_sizes;
- bool adjustable = FALSE; /* Conditionally adjustable? */
-
- type = ffecom_tree_type[bt][kt];
- if (ffesymbol_sfdummyparent (s) != NULL)
- {
- if (current_function_decl == ffecom_outer_function_decl_)
- { /* Exec transition before sfunc
- context; get it later. */
- break;
- }
- t = ffecom_get_identifier_ (ffesymbol_text
- (ffesymbol_sfdummyparent (s)));
- }
- else
- t = ffecom_get_identifier_ (ffesymbol_text (s));
-
- assert (ffecom_transform_only_dummies_);
-
- old_sizes = get_pending_sizes ();
- put_pending_sizes (old_sizes);
-
- if (bt == FFEINFO_basictypeCHARACTER)
- tlen = ffecom_char_enhance_arg_ (&type, s);
- type = ffecom_check_size_overflow_ (s, type, TRUE);
-
- for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
- {
- if (type == error_mark_node)
- break;
-
- dim = ffebld_head (dl);
- assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
- if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
- low = ffecom_integer_one_node;
- else
- low = ffecom_expr (ffebld_left (dim));
- assert (ffebld_right (dim) != NULL);
- if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
- || ffecom_doing_entry_)
- {
- /* Used to just do high=low. But for ffecom_tree_
- canonize_ref_, it probably is important to correctly
- assess the size. E.g. given COMPLEX C(*),CFUNC and
- C(2)=CFUNC(C), overlap can happen, while it can't
- for, say, C(1)=CFUNC(C(2)). */
- /* Even more recently used to set to INT_MAX, but that
- broke when some overflow checking went into the back
- end. Now we just leave the upper bound unspecified. */
- high = NULL;
- }
- else
- high = ffecom_expr (ffebld_right (dim));
-
- /* Determine whether array is conditionally adjustable,
- to decide whether back-end magic is needed.
-
- Normally the front end uses the back-end function
- variable_size to wrap SAVE_EXPR's around expressions
- affecting the size/shape of an array so that the
- size/shape info doesn't change during execution
- of the compiled code even though variables and
- functions referenced in those expressions might.
-
- variable_size also makes sure those saved expressions
- get evaluated immediately upon entry to the
- compiled procedure -- the front end normally doesn't
- have to worry about that.
-
- However, there is a problem with this that affects
- g77's implementation of entry points, and that is
- that it is _not_ true that each invocation of the
- compiled procedure is permitted to evaluate
- array size/shape info -- because it is possible
- that, for some invocations, that info is invalid (in
- which case it is "promised" -- i.e. a violation of
- the Fortran standard -- that the compiled code
- won't reference the array or its size/shape
- during that particular invocation).
-
- To phrase this in C terms, consider this gcc function:
-
- void foo (int *n, float (*a)[*n])
- {
- // a is "pointer to array ...", fyi.
- }
-
- Suppose that, for some invocations, it is permitted
- for a caller of foo to do this:
-
- foo (NULL, NULL);
-
- Now the _written_ code for foo can take such a call
- into account by either testing explicitly for whether
- (a == NULL) || (n == NULL) -- presumably it is
- not permitted to reference *a in various fashions
- if (n == NULL) I suppose -- or it can avoid it by
- looking at other info (other arguments, static/global
- data, etc.).
-
- However, this won't work in gcc 2.5.8 because it'll
- automatically emit the code to save the "*n"
- expression, which'll yield a NULL dereference for
- the "foo (NULL, NULL)" call, something the code
- for foo cannot prevent.
-
- g77 definitely needs to avoid executing such
- code anytime the pointer to the adjustable array
- is NULL, because even if its bounds expressions
- don't have any references to possible "absent"
- variables like "*n" -- say all variable references
- are to COMMON variables, i.e. global (though in C,
- local static could actually make sense) -- the
- expressions could yield other run-time problems
- for allowably "dead" values in those variables.
-
- For example, let's consider a more complicated
- version of foo:
-
- extern int i;
- extern int j;
-
- void foo (float (*a)[i/j])
- {
- ...
- }
-
- The above is (essentially) quite valid for Fortran
- but, again, for a call like "foo (NULL);", it is
- permitted for i and j to be undefined when the
- call is made. If j happened to be zero, for
- example, emitting the code to evaluate "i/j"
- could result in a run-time error.
-
- Offhand, though I don't have my F77 or F90
- standards handy, it might even be valid for a
- bounds expression to contain a function reference,
- in which case I doubt it is permitted for an
- implementation to invoke that function in the
- Fortran case involved here (invocation of an
- alternate ENTRY point that doesn't have the adjustable
- array as one of its arguments).
-
- So, the code that the compiler would normally emit
- to preevaluate the size/shape info for an
- adjustable array _must not_ be executed at run time
- in certain cases. Specifically, for Fortran,
- the case is when the pointer to the adjustable
- array == NULL. (For gnu-ish C, it might be nice
- for the source code itself to specify an expression
- that, if TRUE, inhibits execution of the code. Or
- reverse the sense for elegance.)
-
- (Note that g77 could use a different test than NULL,
- actually, since it happens to always pass an
- integer to the called function that specifies which
- entry point is being invoked. Hmm, this might
- solve the next problem.)
-
- One way a user could, I suppose, write "foo" so
- it works is to insert COND_EXPR's for the
- size/shape info so the dangerous stuff isn't
- actually done, as in:
-
- void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
- {
- ...
- }
-
- The next problem is that the front end needs to
- be able to tell the back end about the array's
- decl _before_ it tells it about the conditional
- expression to inhibit evaluation of size/shape info,
- as shown above.
-
- To solve this, the front end needs to be able
- to give the back end the expression to inhibit
- generation of the preevaluation code _after_
- it makes the decl for the adjustable array.
-
- Until then, the above example using the COND_EXPR
- doesn't pass muster with gcc because the "(a == NULL)"
- part has a reference to "a", which is still
- undefined at that point.
-
- g77 will therefore use a different mechanism in the
- meantime. */
-
- if (!adjustable
- && ((TREE_CODE (low) != INTEGER_CST)
- || (high && TREE_CODE (high) != INTEGER_CST)))
- adjustable = TRUE;
-
-#if 0 /* Old approach -- see below. */
- if (TREE_CODE (low) != INTEGER_CST)
- low = ffecom_3 (COND_EXPR, integer_type_node,
- ffecom_adjarray_passed_ (s),
- low,
- ffecom_integer_zero_node);
-
- if (high && TREE_CODE (high) != INTEGER_CST)
- high = ffecom_3 (COND_EXPR, integer_type_node,
- ffecom_adjarray_passed_ (s),
- high,
- ffecom_integer_zero_node);
-#endif
-
- /* ~~~gcc/stor-layout.c (layout_type) should do this,
- probably. Fixes 950302-1.f. */
-
- if (TREE_CODE (low) != INTEGER_CST)
- low = variable_size (low);
-
- /* ~~~Similarly, this fixes dumb0.f. The C front end
- does this, which is why dumb0.c would work. */
-
- if (high && TREE_CODE (high) != INTEGER_CST)
- high = variable_size (high);
-
- type
- = build_array_type
- (type,
- build_range_type (ffecom_integer_type_node,
- low, high));
- type = ffecom_check_size_overflow_ (s, type, TRUE);
- }
-
- if (type == error_mark_node)
- {
- t = error_mark_node;
- break;
- }
-
- if ((ffesymbol_sfdummyparent (s) == NULL)
- || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
- {
- type = build_pointer_type (type);
- addr = TRUE;
- }
-
- t = build_decl (PARM_DECL, t, type);
- DECL_ARTIFICIAL (t) = 1;
-
- /* If this arg is present in every entry point's list of
- dummy args, then we're done. */
-
- if (ffesymbol_numentries (s)
- == (ffecom_num_entrypoints_ + 1))
- break;
-
-#if 1
-
- /* If variable_size in stor-layout has been called during
- the above, then get_pending_sizes should have the
- yet-to-be-evaluated saved expressions pending.
- Make the whole lot of them get emitted, conditionally
- on whether the array decl ("t" above) is not NULL. */
-
- {
- tree sizes = get_pending_sizes ();
- tree tem;
-
- for (tem = sizes;
- tem != old_sizes;
- tem = TREE_CHAIN (tem))
- {
- tree temv = TREE_VALUE (tem);
-
- if (sizes == tem)
- sizes = temv;
- else
- sizes
- = ffecom_2 (COMPOUND_EXPR,
- TREE_TYPE (sizes),
- temv,
- sizes);
- }
-
- if (sizes != tem)
- {
- sizes
- = ffecom_3 (COND_EXPR,
- TREE_TYPE (sizes),
- ffecom_2 (NE_EXPR,
- integer_type_node,
- t,
- null_pointer_node),
- sizes,
- convert (TREE_TYPE (sizes),
- integer_zero_node));
- sizes = ffecom_save_tree (sizes);
-
- sizes
- = tree_cons (NULL_TREE, sizes, tem);
- }
-
- if (sizes)
- put_pending_sizes (sizes);
- }
-
-#else
-#if 0
- if (adjustable
- && (ffesymbol_numentries (s)
- != ffecom_num_entrypoints_ + 1))
- DECL_SOMETHING (t)
- = ffecom_2 (NE_EXPR, integer_type_node,
- t,
- null_pointer_node);
-#else
-#if 0
- if (adjustable
- && (ffesymbol_numentries (s)
- != ffecom_num_entrypoints_ + 1))
- {
- ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
- ffebad_here (0, ffesymbol_where_line (s),
- ffesymbol_where_column (s));
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- }
-#endif
-#endif
-#endif
- }
- break;
-
- case FFEINFO_whereCOMMON:
- {
- ffesymbol cs;
- ffeglobal cg;
- tree ct;
- ffestorag st = ffesymbol_storage (s);
- tree type;
-
- cs = ffesymbol_common (s); /* The COMMON area itself. */
- if (st != NULL) /* Else not laid out. */
- {
- ffecom_transform_common_ (cs);
- st = ffesymbol_storage (s);
- }
-
- type = ffecom_type_localvar_ (s, bt, kt);
-
- cg = ffesymbol_global (cs); /* The global COMMON info. */
- if ((cg == NULL)
- || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
- ct = NULL_TREE;
- else
- ct = ffeglobal_hook (cg); /* The common area's tree. */
-
- if ((ct == NULL_TREE)
- || (st == NULL)
- || (type == error_mark_node))
- t = error_mark_node;
- else
- {
- ffetargetOffset offset;
- ffestorag cst;
- tree toffset;
-
- cst = ffestorag_parent (st);
- assert (cst == ffesymbol_storage (cs));
-
- offset = ffestorag_modulo (cst)
- + ffestorag_offset (st)
- - ffestorag_offset (cst);
-
- ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
-
- /* (t_type *) (((char *) &ct) + offset) */
-
- t = convert (string_type_node, /* (char *) */
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ct)),
- ct));
- toffset = build_int_2 (offset, 0);
- TREE_TYPE (toffset) = ssizetype;
- t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
- t, toffset);
- t = convert (build_pointer_type (type),
- t);
- TREE_CONSTANT (t) = 1;
-
- addr = TRUE;
- }
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("ENTITY where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindFUNCTION:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
-
- case FFEINFO_whereGLOBAL:
- assert (!ffecom_transform_only_dummies_);
-
- if (((g = ffesymbol_global (s)) != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
- && (ffeglobal_hook (g) != NULL_TREE)
- && ffe_is_globals ())
- {
- t = ffeglobal_hook (g);
- break;
- }
-
- if (ffesymbol_is_f2c (s)
- && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
- t = ffecom_tree_fun_type[bt][kt];
- else
- t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
-
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- t);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
-
- ffecom_save_tree_forever (t);
-
- break;
-
- case FFEINFO_whereDUMMY:
- assert (ffecom_transform_only_dummies_);
-
- if (ffesymbol_is_f2c (s)
- && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
- t = ffecom_tree_ptr_to_fun_type[bt][kt];
- else
- t = build_pointer_type
- (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
-
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- t);
- DECL_ARTIFICIAL (t) = 1;
- addr = TRUE;
- break;
-
- case FFEINFO_whereCONSTANT: /* Statement function. */
- assert (!ffecom_transform_only_dummies_);
- t = ffecom_gen_sfuncdef_ (s, bt, kt);
- break;
-
- case FFEINFO_whereINTRINSIC:
- assert (!ffecom_transform_only_dummies_);
- break; /* Let actual references generate their
- decls. */
-
- default:
- assert ("FUNCTION where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindSUBROUTINE:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
-
- case FFEINFO_whereGLOBAL:
- assert (!ffecom_transform_only_dummies_);
-
- if (((g = ffesymbol_global (s)) != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
- && (ffeglobal_hook (g) != NULL_TREE)
- && ffe_is_globals ())
- {
- t = ffeglobal_hook (g);
- break;
- }
-
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_subr_type);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
-
- t = start_decl (t, ffe_is_globals ());
- finish_decl (t, NULL_TREE, ffe_is_globals ());
-
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
-
- ffecom_save_tree_forever (t);
-
- break;
-
- case FFEINFO_whereDUMMY:
- assert (ffecom_transform_only_dummies_);
-
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_ptr_to_subr_type);
- DECL_ARTIFICIAL (t) = 1;
- addr = TRUE;
- break;
-
- case FFEINFO_whereINTRINSIC:
- assert (!ffecom_transform_only_dummies_);
- break; /* Let actual references generate their
- decls. */
-
- default:
- assert ("SUBROUTINE where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindPROGRAM:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
-
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("PROGRAM where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindBLOCKDATA:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
-
- case FFEINFO_whereGLOBAL:
- assert (!ffecom_transform_only_dummies_);
-
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_blockdata_type);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- ffecom_save_tree_forever (t);
-
- break;
-
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("BLOCKDATA where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindCOMMON:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- ffecom_transform_common_ (s);
- break;
-
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("COMMON where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindCONSTRUCT:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- break;
-
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("CONSTRUCT where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindNAMELIST:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- t = ffecom_transform_namelist_ (s);
- break;
-
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("NAMELIST where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- default:
- assert ("kind unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_kindANY:
- t = error_mark_node;
- break;
- }
-
- ffesymbol_hook (s).decl_tree = t;
- ffesymbol_hook (s).length_tree = tlen;
- ffesymbol_hook (s).addr = addr;
-
- input_location = old_loc;
-
- return s;
-}
-
-/* Transform into ASSIGNable symbol.
-
- Symbol has already been transformed, but for whatever reason, the
- resulting decl_tree has been deemed not usable for an ASSIGN target.
- (E.g. it isn't wide enough to hold a pointer.) So, here we invent
- another local symbol of type void * and stuff that in the assign_tree
- argument. The F77/F90 standards allow this implementation. */
-
-static ffesymbol
-ffecom_sym_transform_assign_ (ffesymbol s)
-{
- tree t; /* Transformed thingy. */
- location_t old_loc = input_location;
-
- if (ffesymbol_sfdummyparent (s) == NULL)
- {
- input_filename = ffesymbol_where_filename (s);
- input_line = ffesymbol_where_filelinenum (s);
- }
- else
- {
- ffesymbol sf = ffesymbol_sfdummyparent (s);
-
- input_filename = ffesymbol_where_filename (sf);
- input_line = ffesymbol_where_filelinenum (sf);
- }
-
- assert (!ffecom_transform_only_dummies_);
-
- t = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
- ffesymbol_text (s)),
- TREE_TYPE (null_pointer_node));
-
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereLOCAL:
- /* Unlike for regular vars, SAVE status is easy to determine for
- ASSIGNed vars, since there's no initialization, there's no
- effective storage association (so "SAVE J" does not apply to
- K even given "EQUIVALENCE (J,K)"), there's no size issue
- to worry about, etc. */
- if ((ffesymbol_is_save (s) || ffe_is_saveall ())
- && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
- && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
- TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
- else
- TREE_STATIC (t) = 0; /* No need to make static. */
- break;
-
- case FFEINFO_whereCOMMON:
- TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
- break;
-
- case FFEINFO_whereDUMMY:
- /* Note that twinning a DUMMY means the caller won't see
- the ASSIGNed value. But both F77 and F90 allow implementations
- to do this, i.e. disallow Fortran code that would try and
- take advantage of actually putting a label into a variable
- via a dummy argument (or any other storage association, for
- that matter). */
- TREE_STATIC (t) = 0;
- break;
-
- default:
- TREE_STATIC (t) = 0;
- break;
- }
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- ffesymbol_hook (s).assign_tree = t;
-
- input_location = old_loc;
-
- return s;
-}
-
-/* Implement COMMON area in back end.
-
- Because COMMON-based variables can be referenced in the dimension
- expressions of dummy (adjustable) arrays, and because dummies
- (in the gcc back end) need to be put in the outer binding level
- of a function (which has two binding levels, the outer holding
- the dummies and the inner holding the other vars), special care
- must be taken to handle COMMON areas.
-
- The current strategy is basically to always tell the back end about
- the COMMON area as a top-level external reference to just a block
- of storage of the master type of that area (e.g. integer, real,
- character, whatever -- not a structure). As a distinct action,
- if initial values are provided, tell the back end about the area
- as a top-level non-external (initialized) area and remember not to
- allow further initialization or expansion of the area. Meanwhile,
- if no initialization happens at all, tell the back end about
- the largest size we've seen declared so the space does get reserved.
- (This function doesn't handle all that stuff, but it does some
- of the important things.)
-
- Meanwhile, for COMMON variables themselves, just keep creating
- references like *((float *) (&common_area + offset)) each time
- we reference the variable. In other words, don't make a VAR_DECL
- or any kind of component reference (like we used to do before 0.4),
- though we might do that as well just for debugging purposes (and
- stuff the rtl with the appropriate offset expression). */
-
-static void
-ffecom_transform_common_ (ffesymbol s)
-{
- ffestorag st = ffesymbol_storage (s);
- ffeglobal g = ffesymbol_global (s);
- tree cbt;
- tree cbtype;
- tree init;
- tree high;
- bool is_init = ffestorag_is_init (st);
-
- assert (st != NULL);
-
- if ((g == NULL)
- || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
- return;
-
- /* First update the size of the area in global terms. */
-
- ffeglobal_size_common (s, ffestorag_size (st));
-
- if (!ffeglobal_common_init (g))
- is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
-
- cbt = ffeglobal_hook (g);
-
- /* If we already have declared this common block for a previous program
- unit, and either we already initialized it or we don't have new
- initialization for it, just return what we have without changing it. */
-
- if ((cbt != NULL_TREE)
- && (!is_init
- || !DECL_EXTERNAL (cbt)))
- {
- if (st->hook == NULL) ffestorag_set_hook (st, cbt);
- return;
- }
-
- /* Process inits. */
-
- if (is_init)
- {
- if (ffestorag_init (st) != NULL)
- {
- ffebld sexp;
-
- /* Set the padding for the expression, so ffecom_expr
- knows to insert that many zeros. */
- switch (ffebld_op (sexp = ffestorag_init (st)))
- {
- case FFEBLD_opCONTER:
- ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
- break;
-
- case FFEBLD_opARRTER:
- ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
- break;
-
- case FFEBLD_opACCTER:
- ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
- break;
-
- default:
- assert ("bad op for cmn init (pad)" == NULL);
- break;
- }
-
- init = ffecom_expr (sexp);
- if (init == error_mark_node)
- { /* Hopefully the back end complained! */
- init = NULL_TREE;
- if (cbt != NULL_TREE)
- return;
- }
- }
- else
- init = error_mark_node;
- }
- else
- init = NULL_TREE;
-
- /* cbtype must be permanently allocated! */
-
- /* Allocate the MAX of the areas so far, seen filewide. */
- high = build_int_2 ((ffeglobal_common_size (g)
- + ffeglobal_common_pad (g)) - 1, 0);
- TREE_TYPE (high) = ffecom_integer_type_node;
-
- if (init)
- cbtype = build_array_type (char_type_node,
- build_range_type (integer_type_node,
- integer_zero_node,
- high));
- else
- cbtype = build_array_type (char_type_node, NULL_TREE);
-
- if (cbt == NULL_TREE)
- {
- cbt
- = build_decl (VAR_DECL,
- ffecom_get_external_identifier_ (s),
- cbtype);
- TREE_STATIC (cbt) = 1;
- TREE_PUBLIC (cbt) = 1;
- }
- else
- {
- assert (is_init);
- TREE_TYPE (cbt) = cbtype;
- }
- DECL_EXTERNAL (cbt) = init ? 0 : 1;
- DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
-
- cbt = start_decl (cbt, TRUE);
- if (ffeglobal_hook (g) != NULL)
- assert (cbt == ffeglobal_hook (g));
-
- assert (!init || !DECL_EXTERNAL (cbt));
-
- /* Make sure that any type can live in COMMON and be referenced
- without getting a bus error. We could pick the most restrictive
- alignment of all entities actually placed in the COMMON, but
- this seems easy enough. */
-
- DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
- DECL_USER_ALIGN (cbt) = 0;
-
- if (is_init && (ffestorag_init (st) == NULL))
- init = ffecom_init_zero_ (cbt);
-
- finish_decl (cbt, init, TRUE);
-
- if (is_init)
- ffestorag_set_init (st, ffebld_new_any ());
-
- if (init)
- {
- assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
- assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
- assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
- (ffeglobal_common_size (g)
- + ffeglobal_common_pad (g))));
- }
-
- ffeglobal_set_hook (g, cbt);
-
- ffestorag_set_hook (st, cbt);
-
- ffecom_save_tree_forever (cbt);
-}
-
-/* Make master area for local EQUIVALENCE. */
-
-static void
-ffecom_transform_equiv_ (ffestorag eqst)
-{
- tree eqt;
- tree eqtype;
- tree init;
- tree high;
- bool is_init = ffestorag_is_init (eqst);
-
- assert (eqst != NULL);
-
- eqt = ffestorag_hook (eqst);
-
- if (eqt != NULL_TREE)
- return;
-
- /* Process inits. */
-
- if (is_init)
- {
- if (ffestorag_init (eqst) != NULL)
- {
- ffebld sexp;
-
- /* Set the padding for the expression, so ffecom_expr
- knows to insert that many zeros. */
- switch (ffebld_op (sexp = ffestorag_init (eqst)))
- {
- case FFEBLD_opCONTER:
- ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
- break;
-
- case FFEBLD_opARRTER:
- ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
- break;
-
- case FFEBLD_opACCTER:
- ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
- break;
-
- default:
- assert ("bad op for eqv init (pad)" == NULL);
- break;
- }
-
- init = ffecom_expr (sexp);
- if (init == error_mark_node)
- init = NULL_TREE; /* Hopefully the back end complained! */
- }
- else
- init = error_mark_node;
- }
- else if (ffe_is_init_local_zero ())
- init = error_mark_node;
- else
- init = NULL_TREE;
-
- ffecom_member_namelisted_ = FALSE;
- ffestorag_drive (ffestorag_list_equivs (eqst),
- &ffecom_member_phase1_,
- eqst);
-
- high = build_int_2 ((ffestorag_size (eqst)
- + ffestorag_modulo (eqst)) - 1, 0);
- TREE_TYPE (high) = ffecom_integer_type_node;
-
- eqtype = build_array_type (char_type_node,
- build_range_type (ffecom_integer_type_node,
- ffecom_integer_zero_node,
- high));
-
- eqt = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_equiv_%s",
- ffesymbol_text
- (ffestorag_symbol (eqst))),
- eqtype);
- DECL_EXTERNAL (eqt) = 0;
- if (is_init
- || ffecom_member_namelisted_
-#ifdef FFECOM_sizeMAXSTACKITEM
- || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
-#endif
- || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
- && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
- && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
- TREE_STATIC (eqt) = 1;
- else
- TREE_STATIC (eqt) = 0;
- TREE_PUBLIC (eqt) = 0;
- TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
- DECL_CONTEXT (eqt) = current_function_decl;
- if (init)
- DECL_INITIAL (eqt) = error_mark_node;
- else
- DECL_INITIAL (eqt) = NULL_TREE;
-
- eqt = start_decl (eqt, FALSE);
-
- /* Make sure that any type can live in EQUIVALENCE and be referenced
- without getting a bus error. We could pick the most restrictive
- alignment of all entities actually placed in the EQUIVALENCE, but
- this seems easy enough. */
-
- DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
- DECL_USER_ALIGN (eqt) = 0;
-
- if ((!is_init && ffe_is_init_local_zero ())
- || (is_init && (ffestorag_init (eqst) == NULL)))
- init = ffecom_init_zero_ (eqt);
-
- finish_decl (eqt, init, FALSE);
-
- if (is_init)
- ffestorag_set_init (eqst, ffebld_new_any ());
-
- {
- assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
- assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
- (ffestorag_size (eqst)
- + ffestorag_modulo (eqst))));
- }
-
- ffestorag_set_hook (eqst, eqt);
-
- ffestorag_drive (ffestorag_list_equivs (eqst),
- &ffecom_member_phase2_,
- eqst);
-}
-
-/* Implement NAMELIST in back end. See f2c/format.c for more info. */
-
-static tree
-ffecom_transform_namelist_ (ffesymbol s)
-{
- tree nmlt;
- tree nmltype = ffecom_type_namelist_ ();
- tree nmlinits;
- tree nameinit;
- tree varsinit;
- tree nvarsinit;
- tree field;
- tree high;
- int i;
- static int mynumber = 0;
-
- nmlt = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_namelist_%d",
- mynumber++),
- nmltype);
- TREE_STATIC (nmlt) = 1;
- DECL_INITIAL (nmlt) = error_mark_node;
-
- nmlt = start_decl (nmlt, FALSE);
-
- /* Process inits. */
-
- i = strlen (ffesymbol_text (s));
-
- high = build_int_2 (i, 0);
- TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
-
- nameinit = ffecom_build_f2c_string_ (i + 1,
- ffesymbol_text (s));
- TREE_TYPE (nameinit)
- = build_type_variant
- (build_array_type
- (char_type_node,
- build_range_type (ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- high)),
- 1, 0);
- TREE_CONSTANT (nameinit) = 1;
- TREE_STATIC (nameinit) = 1;
- nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
- nameinit);
-
- varsinit = ffecom_vardesc_array_ (s);
- varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
- varsinit);
- TREE_CONSTANT (varsinit) = 1;
- TREE_STATIC (varsinit) = 1;
-
- {
- ffebld b;
-
- for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
- ++i;
- }
- nvarsinit = build_int_2 (i, 0);
- TREE_TYPE (nvarsinit) = integer_type_node;
- TREE_CONSTANT (nvarsinit) = 1;
- TREE_STATIC (nvarsinit) = 1;
-
- nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
- TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
- varsinit);
- TREE_CHAIN (TREE_CHAIN (nmlinits))
- = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
-
- nmlinits = build_constructor (nmltype, nmlinits);
- TREE_CONSTANT (nmlinits) = 1;
- TREE_STATIC (nmlinits) = 1;
-
- finish_decl (nmlt, nmlinits, FALSE);
-
- nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
-
- return nmlt;
-}
-
-/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
- analyzed on the assumption it is calculating a pointer to be
- indirected through. It must return the proper decl and offset,
- taking into account different units of measurements for offsets. */
-
-static void
-ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, tree t)
-{
- switch (TREE_CODE (t))
- {
- case NOP_EXPR:
- case CONVERT_EXPR:
- case NON_LVALUE_EXPR:
- ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
- break;
-
- case PLUS_EXPR:
- ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
- if ((*decl == NULL_TREE)
- || (*decl == error_mark_node))
- break;
-
- if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
- {
- /* An offset into COMMON. */
- *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
- *offset, TREE_OPERAND (t, 1)));
- /* Convert offset (presumably in bytes) into canonical units
- (presumably bits). */
- *offset = size_binop (MULT_EXPR,
- convert (bitsizetype, *offset),
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
- break;
- }
- /* Not a COMMON reference, so an unrecognized pattern. */
- *decl = error_mark_node;
- break;
-
- case PARM_DECL:
- *decl = t;
- *offset = bitsize_zero_node;
- break;
-
- case ADDR_EXPR:
- if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
- {
- /* A reference to COMMON. */
- *decl = TREE_OPERAND (t, 0);
- *offset = bitsize_zero_node;
- break;
- }
- /* Fall through. */
- default:
- /* Not a COMMON reference, so an unrecognized pattern. */
- *decl = error_mark_node;
- break;
- }
-}
-
-/* Given a tree that is possibly intended for use as an lvalue, return
- information representing a canonical view of that tree as a decl, an
- offset into that decl, and a size for the lvalue.
-
- If there's no applicable decl, NULL_TREE is returned for the decl,
- and the other fields are left undefined.
-
- If the tree doesn't fit the recognizable forms, an ERROR_MARK node
- is returned for the decl, and the other fields are left undefined.
-
- Otherwise, the decl returned currently is either a VAR_DECL or a
- PARM_DECL.
-
- The offset returned is always valid, but of course not necessarily
- a constant, and not necessarily converted into the appropriate
- type, leaving that up to the caller (so as to avoid that overhead
- if the decls being looked at are different anyway).
-
- If the size cannot be determined (e.g. an adjustable array),
- an ERROR_MARK node is returned for the size. Otherwise, the
- size returned is valid, not necessarily a constant, and not
- necessarily converted into the appropriate type as with the
- offset.
-
- Note that the offset and size expressions are expressed in the
- base storage units (usually bits) rather than in the units of
- the type of the decl, because two decls with different types
- might overlap but with apparently non-overlapping array offsets,
- whereas converting the array offsets to consistant offsets will
- reveal the overlap. */
-
-static void
-ffecom_tree_canonize_ref_ (tree *decl, tree *offset, tree *size, tree t)
-{
- /* The default path is to report a nonexistant decl. */
- *decl = NULL_TREE;
-
- if (t == NULL_TREE)
- return;
-
- switch (TREE_CODE (t))
- {
- case ERROR_MARK:
- case IDENTIFIER_NODE:
- case INTEGER_CST:
- case REAL_CST:
- case COMPLEX_CST:
- case STRING_CST:
- case CONST_DECL:
- case PLUS_EXPR:
- case MINUS_EXPR:
- case MULT_EXPR:
- case TRUNC_DIV_EXPR:
- case CEIL_DIV_EXPR:
- case FLOOR_DIV_EXPR:
- case ROUND_DIV_EXPR:
- case TRUNC_MOD_EXPR:
- case CEIL_MOD_EXPR:
- case FLOOR_MOD_EXPR:
- case ROUND_MOD_EXPR:
- case RDIV_EXPR:
- case EXACT_DIV_EXPR:
- case FIX_TRUNC_EXPR:
- case FIX_CEIL_EXPR:
- case FIX_FLOOR_EXPR:
- case FIX_ROUND_EXPR:
- case FLOAT_EXPR:
- case NEGATE_EXPR:
- case MIN_EXPR:
- case MAX_EXPR:
- case ABS_EXPR:
- case LSHIFT_EXPR:
- case RSHIFT_EXPR:
- case LROTATE_EXPR:
- case RROTATE_EXPR:
- case BIT_IOR_EXPR:
- case BIT_XOR_EXPR:
- case BIT_AND_EXPR:
- case BIT_NOT_EXPR:
- case TRUTH_ANDIF_EXPR:
- case TRUTH_ORIF_EXPR:
- case TRUTH_AND_EXPR:
- case TRUTH_OR_EXPR:
- case TRUTH_XOR_EXPR:
- case TRUTH_NOT_EXPR:
- case LT_EXPR:
- case LE_EXPR:
- case GT_EXPR:
- case GE_EXPR:
- case EQ_EXPR:
- case NE_EXPR:
- case COMPLEX_EXPR:
- case CONJ_EXPR:
- case REALPART_EXPR:
- case IMAGPART_EXPR:
- case LABEL_EXPR:
- case COMPONENT_REF:
- case COMPOUND_EXPR:
- case ADDR_EXPR:
- return;
-
- case VAR_DECL:
- case PARM_DECL:
- *decl = t;
- *offset = bitsize_zero_node;
- *size = TYPE_SIZE (TREE_TYPE (t));
- return;
-
- case ARRAY_REF:
- {
- tree array = TREE_OPERAND (t, 0);
- tree element = TREE_OPERAND (t, 1);
- tree init_offset;
-
- if ((array == NULL_TREE)
- || (element == NULL_TREE))
- {
- *decl = error_mark_node;
- return;
- }
-
- ffecom_tree_canonize_ref_ (decl, &init_offset, size,
- array);
- if ((*decl == NULL_TREE)
- || (*decl == error_mark_node))
- return;
-
- /* Calculate ((element - base) * NBBY) + init_offset. */
- *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
- element,
- TYPE_MIN_VALUE (TYPE_DOMAIN
- (TREE_TYPE (array)))));
-
- *offset = size_binop (MULT_EXPR,
- convert (bitsizetype, *offset),
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
-
- *offset = size_binop (PLUS_EXPR, init_offset, *offset);
-
- *size = TYPE_SIZE (TREE_TYPE (t));
- return;
- }
-
- case INDIRECT_REF:
-
- /* Most of this code is to handle references to COMMON. And so
- far that is useful only for calling library functions, since
- external (user) functions might reference common areas. But
- even calling an external function, it's worthwhile to decode
- COMMON references because if not storing into COMMON, we don't
- want COMMON-based arguments to gratuitously force use of a
- temporary. */
-
- *size = TYPE_SIZE (TREE_TYPE (t));
-
- ffecom_tree_canonize_ptr_ (decl, offset,
- TREE_OPERAND (t, 0));
-
- return;
-
- case CONVERT_EXPR:
- case NOP_EXPR:
- case MODIFY_EXPR:
- case NON_LVALUE_EXPR:
- case RESULT_DECL:
- case FIELD_DECL:
- case COND_EXPR: /* More cases than we can handle. */
- case SAVE_EXPR:
- case REFERENCE_EXPR:
- case PREDECREMENT_EXPR:
- case PREINCREMENT_EXPR:
- case POSTDECREMENT_EXPR:
- case POSTINCREMENT_EXPR:
- case CALL_EXPR:
- default:
- *decl = error_mark_node;
- return;
- }
-}
-
-/* Do divide operation appropriate to type of operands. */
-
-static tree
-ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree dest_tree,
- ffebld dest, bool *dest_used, tree hook)
-{
- if ((left == error_mark_node)
- || (right == error_mark_node))
- return error_mark_node;
-
- switch (TREE_CODE (tree_type))
- {
- case INTEGER_TYPE:
- return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
- left,
- right);
-
- case COMPLEX_TYPE:
- if (! optimize_size)
- return ffecom_2 (RDIV_EXPR, tree_type,
- left,
- right);
- {
- ffecomGfrt ix;
-
- if (TREE_TYPE (tree_type)
- == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
- ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
- else
- ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
-
- left = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (left)),
- left);
- left = build_tree_list (NULL_TREE, left);
- right = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (right)),
- right);
- right = build_tree_list (NULL_TREE, right);
- TREE_CHAIN (left) = right;
-
- return ffecom_call_ (ffecom_gfrt_tree_ (ix),
- ffecom_gfrt_kindtype (ix),
- ffe_is_f2c_library (),
- tree_type,
- left,
- dest_tree, dest, dest_used,
- NULL_TREE, TRUE, hook);
- }
- break;
-
- case RECORD_TYPE:
- {
- ffecomGfrt ix;
-
- if (TREE_TYPE (TYPE_FIELDS (tree_type))
- == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
- ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
- else
- ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
-
- left = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (left)),
- left);
- left = build_tree_list (NULL_TREE, left);
- right = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (right)),
- right);
- right = build_tree_list (NULL_TREE, right);
- TREE_CHAIN (left) = right;
-
- return ffecom_call_ (ffecom_gfrt_tree_ (ix),
- ffecom_gfrt_kindtype (ix),
- ffe_is_f2c_library (),
- tree_type,
- left,
- dest_tree, dest, dest_used,
- NULL_TREE, TRUE, hook);
- }
- break;
-
- default:
- return ffecom_2 (RDIV_EXPR, tree_type,
- left,
- right);
- }
-}
-
-/* Build type info for non-dummy variable. */
-
-static tree
-ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
-{
- tree type;
- ffebld dl;
- ffebld dim;
- tree lowt;
- tree hight;
-
- type = ffecom_tree_type[bt][kt];
- if (bt == FFEINFO_basictypeCHARACTER)
- {
- hight = build_int_2 (ffesymbol_size (s), 0);
- TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
-
- type
- = build_array_type
- (type,
- build_range_type (ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- hight));
- type = ffecom_check_size_overflow_ (s, type, FALSE);
- }
-
- for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
- {
- if (type == error_mark_node)
- break;
-
- dim = ffebld_head (dl);
- assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
-
- if (ffebld_left (dim) == NULL)
- lowt = integer_one_node;
- else
- lowt = ffecom_expr (ffebld_left (dim));
-
- if (TREE_CODE (lowt) != INTEGER_CST)
- lowt = variable_size (lowt);
-
- assert (ffebld_right (dim) != NULL);
- hight = ffecom_expr (ffebld_right (dim));
-
- if (TREE_CODE (hight) != INTEGER_CST)
- hight = variable_size (hight);
-
- type = build_array_type (type,
- build_range_type (ffecom_integer_type_node,
- lowt, hight));
- type = ffecom_check_size_overflow_ (s, type, FALSE);
- }
-
- return type;
-}
-
-/* Build Namelist type. */
-
-static GTY(()) tree ffecom_type_namelist_var;
-static tree
-ffecom_type_namelist_ (void)
-{
- if (ffecom_type_namelist_var == NULL_TREE)
- {
- tree namefield, varsfield, nvarsfield, vardesctype, type;
-
- vardesctype = ffecom_type_vardesc_ ();
-
- type = make_node (RECORD_TYPE);
-
- vardesctype = build_pointer_type (build_pointer_type (vardesctype));
-
- namefield = ffecom_decl_field (type, NULL_TREE, "name",
- string_type_node);
- varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
- nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
- integer_type_node);
-
- TYPE_FIELDS (type) = namefield;
- layout_type (type);
-
- ffecom_type_namelist_var = type;
- }
-
- return ffecom_type_namelist_var;
-}
-
-/* Build Vardesc type. */
-
-static GTY(()) tree ffecom_type_vardesc_var;
-static tree
-ffecom_type_vardesc_ (void)
-{
- if (ffecom_type_vardesc_var == NULL_TREE)
- {
- tree namefield, addrfield, dimsfield, typefield, type;
- type = make_node (RECORD_TYPE);
-
- namefield = ffecom_decl_field (type, NULL_TREE, "name",
- string_type_node);
- addrfield = ffecom_decl_field (type, namefield, "addr",
- string_type_node);
- dimsfield = ffecom_decl_field (type, addrfield, "dims",
- ffecom_f2c_ptr_to_ftnlen_type_node);
- typefield = ffecom_decl_field (type, dimsfield, "type",
- integer_type_node);
-
- TYPE_FIELDS (type) = namefield;
- layout_type (type);
-
- ffecom_type_vardesc_var = type;
- }
-
- return ffecom_type_vardesc_var;
-}
-
-static tree
-ffecom_vardesc_ (ffebld expr)
-{
- ffesymbol s;
-
- assert (ffebld_op (expr) == FFEBLD_opSYMTER);
- s = ffebld_symter (expr);
-
- if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
- {
- int i;
- tree vardesctype = ffecom_type_vardesc_ ();
- tree var;
- tree nameinit;
- tree dimsinit;
- tree addrinit;
- tree typeinit;
- tree field;
- tree varinits;
- static int mynumber = 0;
-
- var = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_vardesc_%d",
- mynumber++),
- vardesctype);
- TREE_STATIC (var) = 1;
- DECL_INITIAL (var) = error_mark_node;
-
- var = start_decl (var, FALSE);
-
- /* Process inits. */
-
- nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
- + 1,
- ffesymbol_text (s));
- TREE_TYPE (nameinit)
- = build_type_variant
- (build_array_type
- (char_type_node,
- build_range_type (integer_type_node,
- integer_one_node,
- build_int_2 (i, 0))),
- 1, 0);
- TREE_CONSTANT (nameinit) = 1;
- TREE_STATIC (nameinit) = 1;
- nameinit = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (nameinit)),
- nameinit);
-
- addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
-
- dimsinit = ffecom_vardesc_dims_ (s);
-
- if (typeinit == NULL_TREE)
- {
- ffeinfoBasictype bt = ffesymbol_basictype (s);
- ffeinfoKindtype kt = ffesymbol_kindtype (s);
- int tc = ffecom_f2c_typecode (bt, kt);
-
- assert (tc != -1);
- typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
- }
- else
- typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
-
- varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
- nameinit);
- TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
- addrinit);
- TREE_CHAIN (TREE_CHAIN (varinits))
- = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
- = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
-
- varinits = build_constructor (vardesctype, varinits);
- TREE_CONSTANT (varinits) = 1;
- TREE_STATIC (varinits) = 1;
-
- finish_decl (var, varinits, FALSE);
-
- var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
-
- ffesymbol_hook (s).vardesc_tree = var;
- }
-
- return ffesymbol_hook (s).vardesc_tree;
-}
-
-static tree
-ffecom_vardesc_array_ (ffesymbol s)
-{
- ffebld b;
- tree list;
- tree item = NULL_TREE;
- tree var;
- int i;
- static int mynumber = 0;
-
- for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
- b != NULL;
- b = ffebld_trail (b), ++i)
- {
- tree t;
-
- t = ffecom_vardesc_ (ffebld_head (b));
-
- if (list == NULL_TREE)
- list = item = build_tree_list (NULL_TREE, t);
- else
- {
- TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
- item = TREE_CHAIN (item);
- }
- }
-
- item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
- build_range_type (integer_type_node,
- integer_one_node,
- build_int_2 (i, 0)));
- list = build_constructor (item, list);
- TREE_CONSTANT (list) = 1;
- TREE_STATIC (list) = 1;
-
- var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
- var = build_decl (VAR_DECL, var, item);
- TREE_STATIC (var) = 1;
- DECL_INITIAL (var) = error_mark_node;
- var = start_decl (var, FALSE);
- finish_decl (var, list, FALSE);
-
- return var;
-}
-
-static tree
-ffecom_vardesc_dims_ (ffesymbol s)
-{
- if (ffesymbol_dims (s) == NULL)
- return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
- integer_zero_node);
-
- {
- ffebld b;
- ffebld e;
- tree list;
- tree backlist;
- tree item = NULL_TREE;
- tree var;
- tree numdim;
- tree numelem;
- tree baseoff = NULL_TREE;
- static int mynumber = 0;
-
- numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
- TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
-
- numelem = ffecom_expr (ffesymbol_arraysize (s));
- TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
-
- list = NULL_TREE;
- backlist = NULL_TREE;
- for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
- b != NULL;
- b = ffebld_trail (b), e = ffebld_trail (e))
- {
- tree t;
- tree low;
- tree back;
-
- if (ffebld_trail (b) == NULL)
- t = NULL_TREE;
- else
- {
- t = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (ffebld_head (e)));
-
- if (list == NULL_TREE)
- list = item = build_tree_list (NULL_TREE, t);
- else
- {
- TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
- item = TREE_CHAIN (item);
- }
- }
-
- if (ffebld_left (ffebld_head (b)) == NULL)
- low = ffecom_integer_one_node;
- else
- low = ffecom_expr (ffebld_left (ffebld_head (b)));
- low = convert (ffecom_f2c_ftnlen_type_node, low);
-
- back = build_tree_list (low, t);
- TREE_CHAIN (back) = backlist;
- backlist = back;
- }
-
- for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
- {
- if (TREE_VALUE (item) == NULL_TREE)
- baseoff = TREE_PURPOSE (item);
- else
- baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- TREE_PURPOSE (item),
- ffecom_2 (MULT_EXPR,
- ffecom_f2c_ftnlen_type_node,
- TREE_VALUE (item),
- baseoff));
- }
-
- /* backlist now dead, along with all TREE_PURPOSEs on it. */
-
- baseoff = build_tree_list (NULL_TREE, baseoff);
- TREE_CHAIN (baseoff) = list;
-
- numelem = build_tree_list (NULL_TREE, numelem);
- TREE_CHAIN (numelem) = baseoff;
-
- numdim = build_tree_list (NULL_TREE, numdim);
- TREE_CHAIN (numdim) = numelem;
-
- item = build_array_type (ffecom_f2c_ftnlen_type_node,
- build_range_type (integer_type_node,
- integer_zero_node,
- build_int_2
- ((int) ffesymbol_rank (s)
- + 2, 0)));
- list = build_constructor (item, numdim);
- TREE_CONSTANT (list) = 1;
- TREE_STATIC (list) = 1;
-
- var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
- var = build_decl (VAR_DECL, var, item);
- TREE_STATIC (var) = 1;
- DECL_INITIAL (var) = error_mark_node;
- var = start_decl (var, FALSE);
- finish_decl (var, list, FALSE);
-
- var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
-
- return var;
- }
-}
-
-/* Essentially does a "fold (build1 (code, type, node))" while checking
- for certain housekeeping things.
-
- NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
- ffecom_1_fn instead. */
-
-tree
-ffecom_1 (enum tree_code code, tree type, tree node)
-{
- tree item;
-
- if ((node == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
-
- if (code == ADDR_EXPR)
- {
- if (!ffe_mark_addressable (node))
- assert ("can't mark_addressable this node!" == NULL);
- }
-
- switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
- {
- tree realtype;
-
- case REALPART_EXPR:
- item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
- break;
-
- case IMAGPART_EXPR:
- item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
- break;
-
-
- case NEGATE_EXPR:
- if (TREE_CODE (type) != RECORD_TYPE)
- {
- item = build1 (code, type, node);
- break;
- }
- node = ffecom_stabilize_aggregate_ (node);
- realtype = TREE_TYPE (TYPE_FIELDS (type));
- item =
- ffecom_2 (COMPLEX_EXPR, type,
- ffecom_1 (NEGATE_EXPR, realtype,
- ffecom_1 (REALPART_EXPR, realtype,
- node)),
- ffecom_1 (NEGATE_EXPR, realtype,
- ffecom_1 (IMAGPART_EXPR, realtype,
- node)));
- break;
-
- default:
- item = build1 (code, type, node);
- break;
- }
-
- if (TREE_SIDE_EFFECTS (node))
- TREE_SIDE_EFFECTS (item) = 1;
- if (code == ADDR_EXPR && staticp (node))
- TREE_CONSTANT (item) = 1;
- else if (code == INDIRECT_REF)
- TREE_READONLY (item) = TYPE_READONLY (type);
- return fold (item);
-}
-
-/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
- handles TREE_CODE (node) == FUNCTION_DECL. In particular,
- does not set TREE_ADDRESSABLE (because calling an inline
- function does not mean the function needs to be separately
- compiled). */
-
-tree
-ffecom_1_fn (tree node)
-{
- tree item;
- tree type;
-
- if (node == error_mark_node)
- return error_mark_node;
-
- type = build_type_variant (TREE_TYPE (node),
- TREE_READONLY (node),
- TREE_THIS_VOLATILE (node));
- item = build1 (ADDR_EXPR,
- build_pointer_type (type), node);
- if (TREE_SIDE_EFFECTS (node))
- TREE_SIDE_EFFECTS (item) = 1;
- if (staticp (node))
- TREE_CONSTANT (item) = 1;
- return fold (item);
-}
-
-/* Essentially does a "fold (build (code, type, node1, node2))" while
- checking for certain housekeeping things. */
-
-tree
-ffecom_2 (enum tree_code code, tree type, tree node1, tree node2)
-{
- tree item;
-
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
-
- switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
- {
- tree a, b, c, d, realtype;
-
- case CONJ_EXPR:
- assert ("no CONJ_EXPR support yet" == NULL);
- return error_mark_node;
-
- case COMPLEX_EXPR:
- item = build_tree_list (TYPE_FIELDS (type), node1);
- TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
- item = build_constructor (type, item);
- break;
-
- case PLUS_EXPR:
- if (TREE_CODE (type) != RECORD_TYPE)
- {
- item = build (code, type, node1, node2);
- break;
- }
- node1 = ffecom_stabilize_aggregate_ (node1);
- node2 = ffecom_stabilize_aggregate_ (node2);
- realtype = TREE_TYPE (TYPE_FIELDS (type));
- item =
- ffecom_2 (COMPLEX_EXPR, type,
- ffecom_2 (PLUS_EXPR, realtype,
- ffecom_1 (REALPART_EXPR, realtype,
- node1),
- ffecom_1 (REALPART_EXPR, realtype,
- node2)),
- ffecom_2 (PLUS_EXPR, realtype,
- ffecom_1 (IMAGPART_EXPR, realtype,
- node1),
- ffecom_1 (IMAGPART_EXPR, realtype,
- node2)));
- break;
-
- case MINUS_EXPR:
- if (TREE_CODE (type) != RECORD_TYPE)
- {
- item = build (code, type, node1, node2);
- break;
- }
- node1 = ffecom_stabilize_aggregate_ (node1);
- node2 = ffecom_stabilize_aggregate_ (node2);
- realtype = TREE_TYPE (TYPE_FIELDS (type));
- item =
- ffecom_2 (COMPLEX_EXPR, type,
- ffecom_2 (MINUS_EXPR, realtype,
- ffecom_1 (REALPART_EXPR, realtype,
- node1),
- ffecom_1 (REALPART_EXPR, realtype,
- node2)),
- ffecom_2 (MINUS_EXPR, realtype,
- ffecom_1 (IMAGPART_EXPR, realtype,
- node1),
- ffecom_1 (IMAGPART_EXPR, realtype,
- node2)));
- break;
-
- case MULT_EXPR:
- if (TREE_CODE (type) != RECORD_TYPE)
- {
- item = build (code, type, node1, node2);
- break;
- }
- node1 = ffecom_stabilize_aggregate_ (node1);
- node2 = ffecom_stabilize_aggregate_ (node2);
- realtype = TREE_TYPE (TYPE_FIELDS (type));
- a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
- node1));
- b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
- node1));
- c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
- node2));
- d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
- node2));
- item =
- ffecom_2 (COMPLEX_EXPR, type,
- ffecom_2 (MINUS_EXPR, realtype,
- ffecom_2 (MULT_EXPR, realtype,
- a,
- c),
- ffecom_2 (MULT_EXPR, realtype,
- b,
- d)),
- ffecom_2 (PLUS_EXPR, realtype,
- ffecom_2 (MULT_EXPR, realtype,
- a,
- d),
- ffecom_2 (MULT_EXPR, realtype,
- c,
- b)));
- break;
-
- case EQ_EXPR:
- if ((TREE_CODE (node1) != RECORD_TYPE)
- && (TREE_CODE (node2) != RECORD_TYPE))
- {
- item = build (code, type, node1, node2);
- break;
- }
- assert (TREE_CODE (node1) == RECORD_TYPE);
- assert (TREE_CODE (node2) == RECORD_TYPE);
- node1 = ffecom_stabilize_aggregate_ (node1);
- node2 = ffecom_stabilize_aggregate_ (node2);
- realtype = TREE_TYPE (TYPE_FIELDS (type));
- item =
- ffecom_2 (TRUTH_ANDIF_EXPR, type,
- ffecom_2 (code, type,
- ffecom_1 (REALPART_EXPR, realtype,
- node1),
- ffecom_1 (REALPART_EXPR, realtype,
- node2)),
- ffecom_2 (code, type,
- ffecom_1 (IMAGPART_EXPR, realtype,
- node1),
- ffecom_1 (IMAGPART_EXPR, realtype,
- node2)));
- break;
-
- case NE_EXPR:
- if ((TREE_CODE (node1) != RECORD_TYPE)
- && (TREE_CODE (node2) != RECORD_TYPE))
- {
- item = build (code, type, node1, node2);
- break;
- }
- assert (TREE_CODE (node1) == RECORD_TYPE);
- assert (TREE_CODE (node2) == RECORD_TYPE);
- node1 = ffecom_stabilize_aggregate_ (node1);
- node2 = ffecom_stabilize_aggregate_ (node2);
- realtype = TREE_TYPE (TYPE_FIELDS (type));
- item =
- ffecom_2 (TRUTH_ORIF_EXPR, type,
- ffecom_2 (code, type,
- ffecom_1 (REALPART_EXPR, realtype,
- node1),
- ffecom_1 (REALPART_EXPR, realtype,
- node2)),
- ffecom_2 (code, type,
- ffecom_1 (IMAGPART_EXPR, realtype,
- node1),
- ffecom_1 (IMAGPART_EXPR, realtype,
- node2)));
- break;
-
- default:
- item = build (code, type, node1, node2);
- break;
- }
-
- if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
-}
-
-/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
-
- ffesymbol s; // the ENTRY point itself
- if (ffecom_2pass_advise_entrypoint(s))
- // the ENTRY point has been accepted
-
- Does whatever compiler needs to do when it learns about the entrypoint,
- like determine the return type of the master function, count the
- number of entrypoints, etc. Returns FALSE if the return type is
- not compatible with the return type(s) of other entrypoint(s).
-
- NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
- later (after _finish_progunit) be called with the same entrypoint(s)
- as passed to this fn for which TRUE was returned.
-
- 03-Jan-92 JCB 2.0
- Return FALSE if the return type conflicts with previous entrypoints. */
-
-bool
-ffecom_2pass_advise_entrypoint (ffesymbol entry)
-{
- ffebld list; /* opITEM. */
- ffebld mlist; /* opITEM. */
- ffebld plist; /* opITEM. */
- ffebld arg; /* ffebld_head(opITEM). */
- ffebld item; /* opITEM. */
- ffesymbol s; /* ffebld_symter(arg). */
- ffeinfoBasictype bt = ffesymbol_basictype (entry);
- ffeinfoKindtype kt = ffesymbol_kindtype (entry);
- ffetargetCharacterSize size = ffesymbol_size (entry);
- bool ok;
-
- if (ffecom_num_entrypoints_ == 0)
- { /* First entrypoint, make list of main
- arglist's dummies. */
- assert (ffecom_primary_entry_ != NULL);
-
- ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
- ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
- ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
-
- for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) != FFEBLD_opSYMTER)
- continue; /* Alternate return or some such thing. */
- item = ffebld_new_item (arg, NULL);
- if (plist == NULL)
- ffecom_master_arglist_ = item;
- else
- ffebld_set_trail (plist, item);
- plist = item;
- }
- }
-
- /* If necessary, scan entry arglist for alternate returns. Do this scan
- apparently redundantly (it's done below to UNIONize the arglists) so
- that we don't complain about RETURN 1 if an offending ENTRY is the only
- one with an alternate return. */
-
- if (!ffecom_is_altreturning_)
- {
- for (list = ffesymbol_dummyargs (entry);
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) == FFEBLD_opSTAR)
- {
- ffecom_is_altreturning_ = TRUE;
- break;
- }
- }
- }
-
- /* Now check type compatibility. */
-
- switch (ffecom_master_bt_)
- {
- case FFEINFO_basictypeNONE:
- ok = (bt != FFEINFO_basictypeCHARACTER);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- ok
- = (bt == FFEINFO_basictypeCHARACTER)
- && (kt == ffecom_master_kt_)
- && (size == ffecom_master_size_);
- break;
-
- case FFEINFO_basictypeANY:
- return FALSE; /* Just don't bother. */
-
- default:
- if (bt == FFEINFO_basictypeCHARACTER)
- {
- ok = FALSE;
- break;
- }
- ok = TRUE;
- if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
- {
- ffecom_master_bt_ = FFEINFO_basictypeNONE;
- ffecom_master_kt_ = FFEINFO_kindtypeNONE;
- }
- break;
- }
-
- if (!ok)
- {
- ffebad_start (FFEBAD_ENTRY_CONFLICTS);
- ffest_ffebad_here_current_stmt (0);
- ffebad_finish ();
- return FALSE; /* Can't handle entrypoint. */
- }
-
- /* Entrypoint type compatible with previous types. */
-
- ++ffecom_num_entrypoints_;
-
- /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
-
- for (list = ffesymbol_dummyargs (entry);
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) != FFEBLD_opSYMTER)
- continue; /* Alternate return or some such thing. */
- s = ffebld_symter (arg);
- for (plist = NULL, mlist = ffecom_master_arglist_;
- mlist != NULL;
- plist = mlist, mlist = ffebld_trail (mlist))
- { /* plist points to previous item for easy
- appending of arg. */
- if (ffebld_symter (ffebld_head (mlist)) == s)
- break; /* Already have this arg in the master list. */
- }
- if (mlist != NULL)
- continue; /* Already have this arg in the master list. */
-
- /* Append this arg to the master list. */
-
- item = ffebld_new_item (arg, NULL);
- if (plist == NULL)
- ffecom_master_arglist_ = item;
- else
- ffebld_set_trail (plist, item);
- }
-
- return TRUE;
-}
-
-/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
-
- ffesymbol s; // the ENTRY point itself
- ffecom_2pass_do_entrypoint(s);
-
- Does whatever compiler needs to do to make the entrypoint actually
- happen. Must be called for each entrypoint after
- ffecom_finish_progunit is called. */
-
-void
-ffecom_2pass_do_entrypoint (ffesymbol entry)
-{
- static int mfn_num = 0;
- static int ent_num;
-
- if (mfn_num != ffecom_num_fns_)
- { /* First entrypoint for this program unit. */
- ent_num = 1;
- mfn_num = ffecom_num_fns_;
- ffecom_do_entry_ (ffecom_primary_entry_, 0);
- }
- else
- ++ent_num;
-
- --ffecom_num_entrypoints_;
-
- ffecom_do_entry_ (entry, ent_num);
-}
-
-/* Essentially does a "fold (build (code, type, node1, node2))" while
- checking for certain housekeeping things. Always sets
- TREE_SIDE_EFFECTS. */
-
-tree
-ffecom_2s (enum tree_code code, tree type, tree node1, tree node2)
-{
- tree item;
-
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
-
- item = build (code, type, node1, node2);
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
-}
-
-/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
- checking for certain housekeeping things. */
-
-tree
-ffecom_3 (enum tree_code code, tree type, tree node1, tree node2, tree node3)
-{
- tree item;
-
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (node3 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
-
- item = build (code, type, node1, node2, node3);
- if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
- || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
-}
-
-/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
- checking for certain housekeeping things. Always sets
- TREE_SIDE_EFFECTS. */
-
-tree
-ffecom_3s (enum tree_code code, tree type, tree node1, tree node2, tree node3)
-{
- tree item;
-
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (node3 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
-
- item = build (code, type, node1, node2, node3);
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
-}
-
-/* ffecom_arg_expr -- Transform argument expr into gcc tree
-
- See use by ffecom_list_expr.
-
- If expression is NULL, returns an integer zero tree. If it is not
- a CHARACTER expression, returns whatever ffecom_expr
- returns and sets the length return value to NULL_TREE. Otherwise
- generates code to evaluate the character expression, returns the proper
- pointer to the result, but does NOT set the length return value to a tree
- that specifies the length of the result. (In other words, the length
- variable is always set to NULL_TREE, because a length is never passed.)
-
- 21-Dec-91 JCB 1.1
- Don't set returned length, since nobody needs it (yet; someday if
- we allow CHARACTER*(*) dummies to statement functions, we'll need
- it). */
-
-tree
-ffecom_arg_expr (ffebld expr, tree *length)
-{
- tree ign;
-
- *length = NULL_TREE;
-
- if (expr == NULL)
- return integer_zero_node;
-
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_expr (expr);
-
- return ffecom_arg_ptr_to_expr (expr, &ign);
-}
-
-/* Transform expression into constant argument-pointer-to-expression tree.
-
- If the expression can be transformed into a argument-pointer-to-expression
- tree that is constant, that is done, and the tree returned. Else
- NULL_TREE is returned.
-
- That way, a caller can attempt to provide compile-time initialization
- of a variable and, if that fails, *then* choose to start a new block
- and resort to using temporaries, as appropriate. */
-
-tree
-ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
-{
- if (! expr)
- return integer_zero_node;
-
- if (ffebld_op (expr) == FFEBLD_opANY)
- {
- if (length)
- *length = error_mark_node;
- return error_mark_node;
- }
-
- if (ffebld_arity (expr) == 0
- && (ffebld_op (expr) != FFEBLD_opSYMTER
- || ffebld_where (expr) == FFEINFO_whereCOMMON
- || ffebld_where (expr) == FFEINFO_whereGLOBAL
- || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
- {
- tree t;
-
- t = ffecom_arg_ptr_to_expr (expr, length);
- assert (TREE_CONSTANT (t));
- assert (! length || TREE_CONSTANT (*length));
- return t;
- }
-
- if (length
- && ffebld_size (expr) != FFETARGET_charactersizeNONE)
- *length = build_int_2 (ffebld_size (expr), 0);
- else if (length)
- *length = NULL_TREE;
- return NULL_TREE;
-}
-
-/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
-
- See use by ffecom_list_ptr_to_expr.
-
- If expression is NULL, returns an integer zero tree. If it is not
- a CHARACTER expression, returns whatever ffecom_ptr_to_expr
- returns and sets the length return value to NULL_TREE. Otherwise
- generates code to evaluate the character expression, returns the proper
- pointer to the result, AND sets the length return value to a tree that
- specifies the length of the result.
-
- If the length argument is NULL, this is a slightly special
- case of building a FORMAT expression, that is, an expression that
- will be used at run time without regard to length. For the current
- implementation, which uses the libf2c library, this means it is nice
- to append a null byte to the end of the expression, where feasible,
- to make sure any diagnostic about the FORMAT string terminates at
- some useful point.
-
- For now, treat %REF(char-expr) as the same as char-expr with a NULL
- length argument. This might even be seen as a feature, if a null
- byte can always be appended. */
-
-tree
-ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
-{
- tree item;
- tree ign_length;
- ffecomConcatList_ catlist;
-
- if (length != NULL)
- *length = NULL_TREE;
-
- if (expr == NULL)
- return integer_zero_node;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opPERCENT_VAL:
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_expr (ffebld_left (expr));
- {
- tree temp_exp;
- tree temp_length;
-
- temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
- if (temp_exp == error_mark_node)
- return error_mark_node;
-
- return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
- temp_exp);
- }
-
- case FFEBLD_opPERCENT_REF:
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_ptr_to_expr (ffebld_left (expr));
- if (length != NULL)
- {
- ign_length = NULL_TREE;
- length = &ign_length;
- }
- expr = ffebld_left (expr);
- break;
-
- case FFEBLD_opPERCENT_DESCR:
- switch (ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeCHARACTER:
- break; /* Passed by descriptor anyway. */
-
- default:
- item = ffecom_ptr_to_expr (expr);
- if (item != error_mark_node)
- *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
- break;
- }
- break;
-
- default:
- break;
- }
-
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_ptr_to_expr (expr);
-
- assert (ffeinfo_kindtype (ffebld_info (expr))
- == FFEINFO_kindtypeCHARACTER1);
-
- while (ffebld_op (expr) == FFEBLD_opPAREN)
- expr = ffebld_left (expr);
-
- catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
- switch (ffecom_concat_list_count_ (catlist))
- {
- case 0: /* Shouldn't happen, but in case it does... */
- if (length != NULL)
- {
- *length = ffecom_f2c_ftnlen_zero_node;
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- }
- ffecom_concat_list_kill_ (catlist);
- return null_pointer_node;
-
- case 1: /* The (fairly) easy case. */
- if (length == NULL)
- ffecom_char_args_with_null_ (&item, &ign_length,
- ffecom_concat_list_expr_ (catlist, 0));
- else
- ffecom_char_args_ (&item, length,
- ffecom_concat_list_expr_ (catlist, 0));
- ffecom_concat_list_kill_ (catlist);
- assert (item != NULL_TREE);
- return item;
-
- default: /* Must actually concatenate things. */
- break;
- }
-
- {
- int count = ffecom_concat_list_count_ (catlist);
- int i;
- tree lengths;
- tree items;
- tree length_array;
- tree item_array;
- tree citem;
- tree clength;
- tree temporary;
- tree num;
- tree known_length;
- ffetargetCharacterSize sz;
-
- sz = ffecom_concat_list_maxlen_ (catlist);
- /* ~~Kludge! */
- assert (sz != FFETARGET_charactersizeNONE);
-
- {
- tree hook;
-
- hook = ffebld_nonter_hook (expr);
- assert (hook);
- assert (TREE_CODE (hook) == TREE_VEC);
- assert (TREE_VEC_LENGTH (hook) == 3);
- length_array = lengths = TREE_VEC_ELT (hook, 0);
- item_array = items = TREE_VEC_ELT (hook, 1);
- temporary = TREE_VEC_ELT (hook, 2);
- }
-
- known_length = ffecom_f2c_ftnlen_zero_node;
-
- for (i = 0; i < count; ++i)
- {
- if ((i == count)
- && (length == NULL))
- ffecom_char_args_with_null_ (&citem, &clength,
- ffecom_concat_list_expr_ (catlist, i));
- else
- ffecom_char_args_ (&citem, &clength,
- ffecom_concat_list_expr_ (catlist, i));
- if ((citem == error_mark_node)
- || (clength == error_mark_node))
- {
- ffecom_concat_list_kill_ (catlist);
- *length = error_mark_node;
- return error_mark_node;
- }
-
- items
- = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
- ffecom_modify (void_type_node,
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
- item_array,
- build_int_2 (i, 0)),
- citem),
- items);
- clength = ffecom_save_tree (clength);
- if (length != NULL)
- known_length
- = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- known_length,
- clength);
- lengths
- = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
- ffecom_modify (void_type_node,
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
- length_array,
- build_int_2 (i, 0)),
- clength),
- lengths);
- }
-
- temporary = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (temporary)),
- temporary);
-
- item = build_tree_list (NULL_TREE, temporary);
- TREE_CHAIN (item)
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (items)),
- items));
- TREE_CHAIN (TREE_CHAIN (item))
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (lengths)),
- lengths));
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
- = build_tree_list
- (NULL_TREE,
- ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
- convert (ffecom_f2c_ftnlen_type_node,
- build_int_2 (count, 0))));
- num = build_int_2 (sz, 0);
- TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
- = build_tree_list (NULL_TREE, num);
-
- item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
- TREE_SIDE_EFFECTS (item) = 1;
- item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
- item,
- temporary);
-
- if (length != NULL)
- *length = known_length;
- }
-
- ffecom_concat_list_kill_ (catlist);
- assert (item != NULL_TREE);
- return item;
-}
-
-/* Generate call to run-time function.
-
- The first arg is the GNU Fortran Run-Time function index, the second
- arg is the list of arguments to pass to it. Returned is the expression
- (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
- result (which may be void). */
-
-tree
-ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
-{
- return ffecom_call_ (ffecom_gfrt_tree_ (ix),
- ffecom_gfrt_kindtype (ix),
- ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
- NULL_TREE, args, NULL_TREE, NULL,
- NULL, NULL_TREE, TRUE, hook);
-}
-
-/* Transform constant-union to tree. */
-
-tree
-ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
- ffeinfoKindtype kt, tree tree_type)
-{
- tree item;
-
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- {
- HOST_WIDE_INT hi, lo;
-
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- lo = ffebld_cu_val_integer1 (*cu);
- hi = (lo < 0) ? -1 : 0;
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- lo = ffebld_cu_val_integer2 (*cu);
- hi = (lo < 0) ? -1 : 0;
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- lo = ffebld_cu_val_integer3 (*cu);
- hi = (lo < 0) ? -1 : 0;
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
-#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
- {
- long long int big = ffebld_cu_val_integer4 (*cu);
- hi = (HOST_WIDE_INT) (big >> HOST_BITS_PER_WIDE_INT);
- lo = (HOST_WIDE_INT) big;
- }
-#else
- lo = ffebld_cu_val_integer4 (*cu);
- hi = (lo < 0) ? -1 : 0;
-#endif
- break;
-#endif
-
- default:
- assert ("bad INTEGER constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_int_2 (lo, hi);
- TREE_TYPE (item) = tree_type;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- {
- int val;
-
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- val = ffebld_cu_val_logical1 (*cu);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- val = ffebld_cu_val_logical2 (*cu);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- val = ffebld_cu_val_logical3 (*cu);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- val = ffebld_cu_val_logical4 (*cu);
- break;
-#endif
-
- default:
- assert ("bad LOGICAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- TREE_TYPE (item) = tree_type;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- {
- REAL_VALUE_TYPE val;
-
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
- break;
-#endif
-
- default:
- assert ("bad REAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_real (tree_type, val);
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- {
- REAL_VALUE_TYPE real;
- REAL_VALUE_TYPE imag;
- tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
-
- switch (kt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
- imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
- imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
- imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
- break;
-#endif
-
- default:
- assert ("bad REAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = ffecom_build_complex_constant_ (tree_type,
- build_real (el_type, real),
- build_real (el_type, imag));
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- { /* Happens only in DATA and similar contexts. */
- ffetargetCharacter1 val;
-
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeLOGICAL1:
- val = ffebld_cu_val_character1 (*cu);
- break;
-#endif
-
- default:
- assert ("bad CHARACTER constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_string (ffetarget_length_character1 (val),
- ffetarget_text_character1 (val));
- TREE_TYPE (item)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2
- (ffetarget_length_character1
- (val), 0))),
- 1, 0);
- }
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- {
- ffetargetHollerith h;
-
- h = ffebld_cu_val_hollerith (*cu);
-
- /* If not at least as wide as default INTEGER, widen it. */
- if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
- item = build_string (h.length, h.text);
- else
- {
- char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
-
- memcpy (str, h.text, h.length);
- memset (&str[h.length], ' ',
- FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
- - h.length);
- item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
- str);
- }
- TREE_TYPE (item)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2
- (h.length, 0))),
- 1, 0);
- }
- break;
-
- case FFEINFO_basictypeTYPELESS:
- {
- ffetargetInteger1 ival;
- ffetargetTypeless tless;
- ffebad error;
-
- tless = ffebld_cu_val_typeless (*cu);
- error = ffetarget_convert_integer1_typeless (&ival, tless);
- assert (error == FFEBAD);
-
- item = build_int_2 ((int) ival, 0);
- }
- break;
-
- default:
- assert ("not yet on constant type" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
-
- TREE_CONSTANT (item) = 1;
-
- return item;
-}
-
-/* Transform constant-union to tree, with the type known. */
-
-tree
-ffecom_constantunion_with_type (ffebldConstantUnion *cu, tree tree_type,
- ffebldConst ct)
-{
- tree item;
-
- int val;
-
- switch (ct)
- {
-#if FFETARGET_okINTEGER1
- case FFEBLD_constINTEGER1:
- val = ffebld_cu_val_integer1 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- break;
-#endif
-#if FFETARGET_okINTEGER2
- case FFEBLD_constINTEGER2:
- val = ffebld_cu_val_integer2 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- break;
-#endif
-#if FFETARGET_okINTEGER3
- case FFEBLD_constINTEGER3:
- val = ffebld_cu_val_integer3 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- break;
-#endif
-#if FFETARGET_okINTEGER4
- case FFEBLD_constINTEGER4:
-#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
- {
- long long int big = ffebld_cu_val_integer4 (*cu);
- item = build_int_2 ((HOST_WIDE_INT) big,
- (HOST_WIDE_INT)
- (big >> HOST_BITS_PER_WIDE_INT));
- }
-#else
- val = ffebld_cu_val_integer4 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
-#endif
- break;
-#endif
-#if FFETARGET_okLOGICAL1
- case FFEBLD_constLOGICAL1:
- val = ffebld_cu_val_logical1 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- break;
-#endif
-#if FFETARGET_okLOGICAL2
- case FFEBLD_constLOGICAL2:
- val = ffebld_cu_val_logical2 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- break;
-#endif
-#if FFETARGET_okLOGICAL3
- case FFEBLD_constLOGICAL3:
- val = ffebld_cu_val_logical3 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- break;
-#endif
-#if FFETARGET_okLOGICAL4
- case FFEBLD_constLOGICAL4:
- val = ffebld_cu_val_logical4 (*cu);
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- break;
-#endif
- default:
- assert ("constant type not supported"==NULL);
- return error_mark_node;
- break;
- }
-
- TREE_TYPE (item) = tree_type;
-
- TREE_CONSTANT (item) = 1;
-
- return item;
-}
-/* Transform expression into constant tree.
-
- If the expression can be transformed into a tree that is constant,
- that is done, and the tree returned. Else NULL_TREE is returned.
-
- That way, a caller can attempt to provide compile-time initialization
- of a variable and, if that fails, *then* choose to start a new block
- and resort to using temporaries, as appropriate. */
-
-tree
-ffecom_const_expr (ffebld expr)
-{
- if (! expr)
- return integer_zero_node;
-
- if (ffebld_op (expr) == FFEBLD_opANY)
- return error_mark_node;
-
- if (ffebld_arity (expr) == 0
- && (ffebld_op (expr) != FFEBLD_opSYMTER
- || ffebld_where (expr) == FFEINFO_whereGLOBAL
- || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
- {
- tree t;
-
- t = ffecom_expr (expr);
- assert (TREE_CONSTANT (t));
- return t;
- }
-
- return NULL_TREE;
-}
-
-/* Handy way to make a field in a struct/union. */
-
-tree
-ffecom_decl_field (tree context, tree prevfield, const char *name, tree type)
-{
- tree field;
-
- field = build_decl (FIELD_DECL, get_identifier (name), type);
- DECL_CONTEXT (field) = context;
- DECL_ALIGN (field) = 0;
- DECL_USER_ALIGN (field) = 0;
- if (prevfield != NULL_TREE)
- TREE_CHAIN (prevfield) = field;
-
- return field;
-}
-
-void
-ffecom_close_include (FILE *f)
-{
- ffecom_close_include_ (f);
-}
-
-/* End a compound statement (block). */
-
-tree
-ffecom_end_compstmt (void)
-{
- return bison_rule_compstmt_ ();
-}
-
-/* ffecom_end_transition -- Perform end transition on all symbols
-
- ffecom_end_transition();
-
- Calls ffecom_sym_end_transition for each global and local symbol. */
-
-void
-ffecom_end_transition (void)
-{
- ffebld item;
-
- if (ffe_is_ffedebug ())
- fprintf (dmpout, "; end_stmt_transition\n");
-
- ffecom_list_blockdata_ = NULL;
- ffecom_list_common_ = NULL;
-
- ffesymbol_drive (ffecom_sym_end_transition);
- if (ffe_is_ffedebug ())
- {
- ffestorag_report ();
- }
-
- ffecom_start_progunit_ ();
-
- for (item = ffecom_list_blockdata_;
- item != NULL;
- item = ffebld_trail (item))
- {
- ffebld callee;
- ffesymbol s;
- tree dt;
- tree t;
- tree var;
- static int number = 0;
-
- callee = ffebld_head (item);
- s = ffebld_symter (callee);
- t = ffesymbol_hook (s).decl_tree;
- if (t == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- t = ffesymbol_hook (s).decl_tree;
- }
-
- dt = build_pointer_type (TREE_TYPE (t));
-
- var = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_forceload_%d",
- number++),
- dt);
- DECL_EXTERNAL (var) = 0;
- TREE_STATIC (var) = 1;
- TREE_PUBLIC (var) = 0;
- DECL_INITIAL (var) = error_mark_node;
- TREE_USED (var) = 1;
-
- var = start_decl (var, FALSE);
-
- t = ffecom_1 (ADDR_EXPR, dt, t);
-
- finish_decl (var, t, FALSE);
- }
-
- /* This handles any COMMON areas that weren't referenced but have, for
- example, important initial data. */
-
- for (item = ffecom_list_common_;
- item != NULL;
- item = ffebld_trail (item))
- ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
-
- ffecom_list_common_ = NULL;
-}
-
-/* ffecom_exec_transition -- Perform exec transition on all symbols
-
- ffecom_exec_transition();
-
- Calls ffecom_sym_exec_transition for each global and local symbol.
- Make sure error updating not inhibited. */
-
-void
-ffecom_exec_transition (void)
-{
- bool inhibited;
-
- if (ffe_is_ffedebug ())
- fprintf (dmpout, "; exec_stmt_transition\n");
-
- inhibited = ffebad_inhibit ();
- ffebad_set_inhibit (FALSE);
-
- ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
- ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
- if (ffe_is_ffedebug ())
- {
- ffestorag_report ();
- }
-
- if (inhibited)
- ffebad_set_inhibit (TRUE);
-}
-
-/* Handle assignment statement.
-
- Convert dest and source using ffecom_expr, then join them
- with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
-
-void
-ffecom_expand_let_stmt (ffebld dest, ffebld source)
-{
- tree dest_tree;
- tree dest_length;
- tree source_tree;
- tree expr_tree;
-
- if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
- {
- bool dest_used;
- tree assign_temp;
-
- /* This attempts to replicate the test below, but must not be
- true when the test below is false. (Always err on the side
- of creating unused temporaries, to avoid ICEs.) */
- if (ffebld_op (dest) != FFEBLD_opSYMTER
- || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
- && (TREE_CODE (dest_tree) != VAR_DECL
- || TREE_ADDRESSABLE (dest_tree))))
- {
- ffecom_prepare_expr_ (source, dest);
- dest_used = TRUE;
- }
- else
- {
- ffecom_prepare_expr_ (source, NULL);
- dest_used = FALSE;
- }
-
- ffecom_prepare_expr_w (NULL_TREE, dest);
-
- /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
- create a temporary through which the assignment is to take place,
- since MODIFY_EXPR doesn't handle partial overlap properly. */
- if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
- && ffecom_possible_partial_overlap_ (dest, source))
- {
- assign_temp = ffecom_make_tempvar ("complex_let",
- ffecom_tree_type
- [ffebld_basictype (dest)]
- [ffebld_kindtype (dest)],
- FFETARGET_charactersizeNONE,
- -1);
- }
- else
- assign_temp = NULL_TREE;
-
- ffecom_prepare_end ();
-
- dest_tree = ffecom_expr_w (NULL_TREE, dest);
- if (dest_tree == error_mark_node)
- return;
-
- if ((TREE_CODE (dest_tree) != VAR_DECL)
- || TREE_ADDRESSABLE (dest_tree))
- source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
- FALSE, FALSE);
- else
- {
- assert (! dest_used);
- dest_used = FALSE;
- source_tree = ffecom_expr (source);
- }
- if (source_tree == error_mark_node)
- return;
-
- if (dest_used)
- expr_tree = source_tree;
- else if (assign_temp)
- {
- expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
- assign_temp,
- source_tree);
- expand_expr_stmt (expr_tree);
- expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
- dest_tree,
- assign_temp);
- }
- else
- expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
- dest_tree,
- source_tree);
-
- expand_expr_stmt (expr_tree);
- return;
- }
-
- ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
- ffecom_prepare_expr_w (NULL_TREE, dest);
-
- ffecom_prepare_end ();
-
- ffecom_char_args_ (&dest_tree, &dest_length, dest);
- ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
- source);
-}
-
-/* ffecom_expr -- Transform expr into gcc tree
-
- tree t;
- ffebld expr; // FFE expression.
- tree = ffecom_expr(expr);
-
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. */
-
-tree
-ffecom_expr (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
-}
-
-/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
-
-tree
-ffecom_expr_assign (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
-}
-
-/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
-
-tree
-ffecom_expr_assign_w (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
-}
-
-/* Transform expr for use as into read/write tree and stabilize the
- reference. Not for use on CHARACTER expressions.
-
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. */
-
-tree
-ffecom_expr_rw (tree type, ffebld expr)
-{
- assert (expr != NULL);
- /* Different target types not yet supported. */
- assert (type == NULL_TREE || type == ffecom_type_expr (expr));
-
- return stabilize_reference (ffecom_expr (expr));
-}
-
-/* Transform expr for use as into write tree and stabilize the
- reference. Not for use on CHARACTER expressions.
-
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. */
-
-tree
-ffecom_expr_w (tree type, ffebld expr)
-{
- assert (expr != NULL);
- /* Different target types not yet supported. */
- assert (type == NULL_TREE || type == ffecom_type_expr (expr));
-
- return stabilize_reference (ffecom_expr (expr));
-}
-
-/* Do global stuff. */
-
-void
-ffecom_finish_compile (void)
-{
- assert (ffecom_outer_function_decl_ == NULL_TREE);
- assert (current_function_decl == NULL_TREE);
-
- ffeglobal_drive (ffecom_finish_global_);
-}
-
-/* Public entry point for front end to access finish_decl. */
-
-void
-ffecom_finish_decl (tree decl, tree init, bool is_top_level)
-{
- assert (!is_top_level);
- finish_decl (decl, init, FALSE);
-}
-
-/* Finish a program unit. */
-
-void
-ffecom_finish_progunit (void)
-{
- ffecom_end_compstmt ();
-
- ffecom_previous_function_decl_ = current_function_decl;
- ffecom_which_entrypoint_decl_ = NULL_TREE;
-
- finish_function (0);
-}
-
-/* Wrapper for get_identifier. pattern is sprintf-like. */
-
-tree
-ffecom_get_invented_identifier (const char *pattern, ...)
-{
- tree decl;
- char *nam;
- va_list ap;
-
- va_start (ap, pattern);
- if (vasprintf (&nam, pattern, ap) == 0)
- abort ();
- va_end (ap);
- decl = get_identifier (nam);
- free (nam);
- IDENTIFIER_INVENTED (decl) = 1;
- return decl;
-}
-
-ffeinfoBasictype
-ffecom_gfrt_basictype (ffecomGfrt gfrt)
-{
- assert (gfrt < FFECOM_gfrt);
-
- switch (ffecom_gfrt_type_[gfrt])
- {
- case FFECOM_rttypeVOID_:
- case FFECOM_rttypeVOIDSTAR_:
- return FFEINFO_basictypeNONE;
-
- case FFECOM_rttypeFTNINT_:
- return FFEINFO_basictypeINTEGER;
-
- case FFECOM_rttypeINTEGER_:
- return FFEINFO_basictypeINTEGER;
-
- case FFECOM_rttypeLONGINT_:
- return FFEINFO_basictypeINTEGER;
-
- case FFECOM_rttypeLOGICAL_:
- return FFEINFO_basictypeLOGICAL;
-
- case FFECOM_rttypeREAL_F2C_:
- case FFECOM_rttypeREAL_GNU_:
- return FFEINFO_basictypeREAL;
-
- case FFECOM_rttypeCOMPLEX_F2C_:
- case FFECOM_rttypeCOMPLEX_GNU_:
- return FFEINFO_basictypeCOMPLEX;
-
- case FFECOM_rttypeDOUBLE_:
- case FFECOM_rttypeDOUBLEREAL_:
- return FFEINFO_basictypeREAL;
-
- case FFECOM_rttypeDBLCMPLX_F2C_:
- case FFECOM_rttypeDBLCMPLX_GNU_:
- return FFEINFO_basictypeCOMPLEX;
-
- case FFECOM_rttypeCHARACTER_:
- return FFEINFO_basictypeCHARACTER;
-
- default:
- return FFEINFO_basictypeANY;
- }
-}
-
-ffeinfoKindtype
-ffecom_gfrt_kindtype (ffecomGfrt gfrt)
-{
- assert (gfrt < FFECOM_gfrt);
-
- switch (ffecom_gfrt_type_[gfrt])
- {
- case FFECOM_rttypeVOID_:
- case FFECOM_rttypeVOIDSTAR_:
- return FFEINFO_kindtypeNONE;
-
- case FFECOM_rttypeFTNINT_:
- return FFEINFO_kindtypeINTEGER1;
-
- case FFECOM_rttypeINTEGER_:
- return FFEINFO_kindtypeINTEGER1;
-
- case FFECOM_rttypeLONGINT_:
- return FFEINFO_kindtypeINTEGER4;
-
- case FFECOM_rttypeLOGICAL_:
- return FFEINFO_kindtypeLOGICAL1;
-
- case FFECOM_rttypeREAL_F2C_:
- case FFECOM_rttypeREAL_GNU_:
- return FFEINFO_kindtypeREAL1;
-
- case FFECOM_rttypeCOMPLEX_F2C_:
- case FFECOM_rttypeCOMPLEX_GNU_:
- return FFEINFO_kindtypeREAL1;
-
- case FFECOM_rttypeDOUBLE_:
- case FFECOM_rttypeDOUBLEREAL_:
- return FFEINFO_kindtypeREAL2;
-
- case FFECOM_rttypeDBLCMPLX_F2C_:
- case FFECOM_rttypeDBLCMPLX_GNU_:
- return FFEINFO_kindtypeREAL2;
-
- case FFECOM_rttypeCHARACTER_:
- return FFEINFO_kindtypeCHARACTER1;
-
- default:
- return FFEINFO_kindtypeANY;
- }
-}
-
-void
-ffecom_init_0 (void)
-{
- tree endlink;
- int i;
- int j;
- tree t;
- tree field;
- ffetype type;
- ffetype base_type;
- tree double_ftype_double, double_ftype_double_double;
- tree float_ftype_float, float_ftype_float_float;
- tree ldouble_ftype_ldouble, ldouble_ftype_ldouble_ldouble;
- tree ffecom_tree_ptr_to_fun_type_void;
-
- /* This block of code comes from the now-obsolete cktyps.c. It checks
- whether the compiler environment is buggy in known ways, some of which
- would, if not explicitly checked here, result in subtle bugs in g77. */
-
- if (ffe_is_do_internal_checks ())
- {
- static const char names[][12]
- =
- {"bar", "bletch", "foo", "foobar"};
- const char *name;
- unsigned long ul;
- double fl;
-
- name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
- (int (*)(const void *, const void *)) strcmp);
- if (name != &names[2][0])
- {
- assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
- == NULL);
- abort ();
- }
-
- ul = strtoul ("123456789", NULL, 10);
- if (ul != 123456789L)
- {
- assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
- in proj.h" == NULL);
- abort ();
- }
-
- fl = atof ("56.789");
- if ((fl < 56.788) || (fl > 56.79))
- {
- assert ("atof not type double, fix your #include <stdio.h>"
- == NULL);
- abort ();
- }
- }
-
- ffecom_outer_function_decl_ = NULL_TREE;
- current_function_decl = NULL_TREE;
- named_labels = NULL_TREE;
- current_binding_level = NULL_BINDING_LEVEL;
- free_binding_level = NULL_BINDING_LEVEL;
- /* Make the binding_level structure for global names. */
- pushlevel (0);
- global_binding_level = current_binding_level;
- current_binding_level->prep_state = 2;
-
- build_common_tree_nodes (1);
-
- /* Define `int' and `char' first so that dbx will output them first. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
- integer_type_node));
- /* CHARACTER*1 is unsigned in ICHAR contexts. */
- char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
- char_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
- long_integer_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
- unsigned_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
- long_unsigned_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
- long_long_integer_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
- long_long_unsigned_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
- short_integer_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
- short_unsigned_type_node));
-
- /* Set the sizetype before we make other types. This *should* be the
- first type we create. */
-
- set_sizetype
- (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
- ffecom_typesize_pointer_
- = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
-
- build_common_tree_nodes_2 (0);
-
- /* Define both `signed char' and `unsigned char'. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
- signed_char_type_node));
-
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
- unsigned_char_type_node));
-
- pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
- float_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
- double_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
- long_double_type_node));
-
- /* For now, override what build_common_tree_nodes has done. */
- complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
- complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
- complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
- complex_long_double_type_node
- = ffecom_make_complex_type_ (long_double_type_node);
-
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
- complex_integer_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
- complex_float_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
- complex_double_type_node));
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
- complex_long_double_type_node));
-
- pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
- void_type_node));
- /* We are not going to have real types in C with less than byte alignment,
- so we might as well not have any types that claim to have it. */
- TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
- TYPE_USER_ALIGN (void_type_node) = 0;
-
- string_type_node = build_pointer_type (char_type_node);
-
- ffecom_tree_fun_type_void
- = build_function_type (void_type_node, NULL_TREE);
-
- ffecom_tree_ptr_to_fun_type_void
- = build_pointer_type (ffecom_tree_fun_type_void);
-
- endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
-
- t = tree_cons (NULL_TREE, float_type_node, endlink);
- float_ftype_float = build_function_type (float_type_node, t);
- t = tree_cons (NULL_TREE, float_type_node, t);
- float_ftype_float_float = build_function_type (float_type_node, t);
-
- t = tree_cons (NULL_TREE, double_type_node, endlink);
- double_ftype_double = build_function_type (double_type_node, t);
- t = tree_cons (NULL_TREE, double_type_node, t);
- double_ftype_double_double = build_function_type (double_type_node, t);
-
- t = tree_cons (NULL_TREE, long_double_type_node, endlink);
- ldouble_ftype_ldouble = build_function_type (long_double_type_node, t);
- t = tree_cons (NULL_TREE, long_double_type_node, t);
- ldouble_ftype_ldouble_ldouble = build_function_type (long_double_type_node,
- t);
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- ffecom_tree_type[i][j] = NULL_TREE;
- ffecom_tree_fun_type[i][j] = NULL_TREE;
- ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
- ffecom_f2c_typecode_[i][j] = -1;
- }
-
- /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
- to size FLOAT_TYPE_SIZE because they have to be the same size as
- REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
- Compiler options and other such stuff that change the ways these
- types are set should not affect this particular setup. */
-
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
- = t = make_signed_type (FLOAT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
- t));
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- ffecom_typesize_integer1_ = ffetype_size (type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger1));
-
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
- = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
- t));
-
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
- = t = make_signed_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 3, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger2));
-
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
- = t = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
- t));
-
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
- = t = make_signed_type (CHAR_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 6, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger3));
-
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
- = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
- t));
-
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
- = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger4));
-
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
- = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
- t));
-
-#if 0
- if (ffe_is_do_internal_checks ()
- && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
- && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
- && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
- && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
- {
- fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
- LONG_TYPE_SIZE);
- }
-#endif
-
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
- = t = make_signed_type (FLOAT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
- t));
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical1));
-
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
- = t = make_signed_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 3, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical2));
-
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
- = t = make_signed_type (CHAR_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 6, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical3));
-
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
- = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical4));
-
- ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
- = t = make_node (REAL_TYPE);
- TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
- pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
- t));
- layout_type (t);
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
- = FFETARGET_f2cTYREAL;
- assert (ffetype_size (type) == sizeof (ffetargetReal1));
-
- ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
- = t = make_node (REAL_TYPE);
- TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
- t));
- layout_type (t);
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2, type);
- ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
- = FFETARGET_f2cTYDREAL;
- assert (ffetype_size (type) == sizeof (ffetargetReal2));
-
- ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
- = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
- t));
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
- = FFETARGET_f2cTYCOMPLEX;
- assert (ffetype_size (type) == sizeof (ffetargetComplex1));
-
- ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
- = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2,
- type);
- ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
- = FFETARGET_f2cTYDCOMPLEX;
- assert (ffetype_size (type) == sizeof (ffetargetComplex2));
-
- /* Make function and ptr-to-function types for non-CHARACTER types. */
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
- {
- if (i == FFEINFO_basictypeINTEGER)
- {
- /* Figure out the smallest INTEGER type that can hold
- a pointer on this machine. */
- if (GET_MODE_SIZE (TYPE_MODE (t))
- >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
- {
- if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
- || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
- > GET_MODE_SIZE (TYPE_MODE (t))))
- ffecom_pointer_kind_ = j;
- }
- }
- else if (i == FFEINFO_basictypeCOMPLEX)
- t = void_type_node;
- /* For f2c compatibility, REAL functions are really
- implemented as DOUBLE PRECISION. */
- else if ((i == FFEINFO_basictypeREAL)
- && (j == FFEINFO_kindtypeREAL1))
- t = ffecom_tree_type
- [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
-
- t = ffecom_tree_fun_type[i][j] = build_function_type (t,
- NULL_TREE);
- ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
- }
- }
-
- /* Set up pointer types. */
-
- if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
- fatal_error ("no INTEGER type can hold a pointer on this configuration");
- else if (0 && ffe_is_do_internal_checks ())
- fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
- ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT),
- 7,
- ffeinfo_type (FFEINFO_basictypeINTEGER,
- ffecom_pointer_kind_));
-
- if (ffe_is_ugly_assign ())
- ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
- else
- ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
- if (0 && ffe_is_do_internal_checks ())
- fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
-
- ffecom_integer_type_node
- = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
- ffecom_integer_zero_node = convert (ffecom_integer_type_node,
- integer_zero_node);
- ffecom_integer_one_node = convert (ffecom_integer_type_node,
- integer_one_node);
-
- /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
- Turns out that by TYLONG, runtime/libI77/lio.h really means
- "whatever size an ftnint is". For consistency and sanity,
- com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
- all are INTEGER, which we also make out of whatever back-end
- integer type is FLOAT_TYPE_SIZE bits wide. This change, from
- LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
- accommodate machines like the Alpha. Note that this suggests
- f2c and libf2c are missing a distinction perhaps needed on
- some machines between "int" and "long int". -- burley 0.5.5 950215 */
-
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
- FFETARGET_f2cTYLONG);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
- FFETARGET_f2cTYSHORT);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
- FFETARGET_f2cTYINT1);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
- FFETARGET_f2cTYQUAD);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
- FFETARGET_f2cTYLOGICAL);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
- FFETARGET_f2cTYLOGICAL2);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
- FFETARGET_f2cTYLOGICAL1);
- /* ~~~Not really such a type in libf2c, e.g. I/O support? */
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
- FFETARGET_f2cTYQUAD);
-
- /* CHARACTER stuff is all special-cased, so it is not handled in the above
- loop. CHARACTER items are built as arrays of unsigned char. */
-
- ffecom_tree_type[FFEINFO_basictypeCHARACTER]
- [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_kind (base_type, 1, type);
- assert (ffetype_size (type)
- == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
-
- ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
- [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
- ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
- [FFEINFO_kindtypeCHARACTER1]
- = ffecom_tree_ptr_to_fun_type_void;
- ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
- = FFETARGET_f2cTYCHAR;
-
- ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
- = 0;
-
- /* Make multi-return-value type and fields. */
-
- ffecom_multi_type_node_ = make_node (UNION_TYPE);
-
- field = NULL_TREE;
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- char name[30];
-
- if (ffecom_tree_type[i][j] == NULL_TREE)
- continue; /* Not supported. */
- sprintf (&name[0], "bt_%s_kt_%s",
- ffeinfo_basictype_string ((ffeinfoBasictype) i),
- ffeinfo_kindtype_string ((ffeinfoKindtype) j));
- ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
- get_identifier (name),
- ffecom_tree_type[i][j]);
- DECL_CONTEXT (ffecom_multi_fields_[i][j])
- = ffecom_multi_type_node_;
- DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
- DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
- TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
- field = ffecom_multi_fields_[i][j];
- }
-
- TYPE_FIELDS (ffecom_multi_type_node_) = field;
- layout_type (ffecom_multi_type_node_);
-
- /* Subroutines usually return integer because they might have alternate
- returns. */
-
- ffecom_tree_subr_type
- = build_function_type (integer_type_node, NULL_TREE);
- ffecom_tree_ptr_to_subr_type
- = build_pointer_type (ffecom_tree_subr_type);
- ffecom_tree_blockdata_type
- = build_function_type (void_type_node, NULL_TREE);
-
- builtin_function ("__builtin_atanf", float_ftype_float,
- BUILT_IN_ATANF, BUILT_IN_NORMAL, "atanf", NULL_TREE);
- builtin_function ("__builtin_atan", double_ftype_double,
- BUILT_IN_ATAN, BUILT_IN_NORMAL, "atan", NULL_TREE);
- builtin_function ("__builtin_atanl", ldouble_ftype_ldouble,
- BUILT_IN_ATANL, BUILT_IN_NORMAL, "atanl", NULL_TREE);
-
- builtin_function ("__builtin_atan2f", float_ftype_float_float,
- BUILT_IN_ATAN2F, BUILT_IN_NORMAL, "atan2f", NULL_TREE);
- builtin_function ("__builtin_atan2", double_ftype_double_double,
- BUILT_IN_ATAN2, BUILT_IN_NORMAL, "atan2", NULL_TREE);
- builtin_function ("__builtin_atan2l", ldouble_ftype_ldouble_ldouble,
- BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL_TREE);
-
- builtin_function ("__builtin_cosf", float_ftype_float,
- BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE);
- builtin_function ("__builtin_cos", double_ftype_double,
- BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE);
- builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
- BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE);
-
- builtin_function ("__builtin_expf", float_ftype_float,
- BUILT_IN_EXPF, BUILT_IN_NORMAL, "expf", NULL_TREE);
- builtin_function ("__builtin_exp", double_ftype_double,
- BUILT_IN_EXP, BUILT_IN_NORMAL, "exp", NULL_TREE);
- builtin_function ("__builtin_expl", ldouble_ftype_ldouble,
- BUILT_IN_EXPL, BUILT_IN_NORMAL, "expl", NULL_TREE);
-
- builtin_function ("__builtin_floorf", float_ftype_float,
- BUILT_IN_FLOORF, BUILT_IN_NORMAL, "floorf", NULL_TREE);
- builtin_function ("__builtin_floor", double_ftype_double,
- BUILT_IN_FLOOR, BUILT_IN_NORMAL, "floor", NULL_TREE);
- builtin_function ("__builtin_floorl", ldouble_ftype_ldouble,
- BUILT_IN_FLOORL, BUILT_IN_NORMAL, "floorl", NULL_TREE);
-
- builtin_function ("__builtin_fmodf", float_ftype_float_float,
- BUILT_IN_FMODF, BUILT_IN_NORMAL, "fmodf", NULL_TREE);
- builtin_function ("__builtin_fmod", double_ftype_double_double,
- BUILT_IN_FMOD, BUILT_IN_NORMAL, "fmod", NULL_TREE);
- builtin_function ("__builtin_fmodl", ldouble_ftype_ldouble_ldouble,
- BUILT_IN_FMODL, BUILT_IN_NORMAL, "fmodl", NULL_TREE);
-
- builtin_function ("__builtin_logf", float_ftype_float,
- BUILT_IN_LOGF, BUILT_IN_NORMAL, "logf", NULL_TREE);
- builtin_function ("__builtin_log", double_ftype_double,
- BUILT_IN_LOG, BUILT_IN_NORMAL, "log", NULL_TREE);
- builtin_function ("__builtin_logl", ldouble_ftype_ldouble,
- BUILT_IN_LOGL, BUILT_IN_NORMAL, "logl", NULL_TREE);
-
- builtin_function ("__builtin_powf", float_ftype_float_float,
- BUILT_IN_POWF, BUILT_IN_NORMAL, "powf", NULL_TREE);
- builtin_function ("__builtin_pow", double_ftype_double_double,
- BUILT_IN_POW, BUILT_IN_NORMAL, "pow", NULL_TREE);
- builtin_function ("__builtin_powl", ldouble_ftype_ldouble_ldouble,
- BUILT_IN_POWL, BUILT_IN_NORMAL, "powl", NULL_TREE);
-
- builtin_function ("__builtin_sinf", float_ftype_float,
- BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE);
- builtin_function ("__builtin_sin", double_ftype_double,
- BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE);
- builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
- BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE);
-
- builtin_function ("__builtin_sqrtf", float_ftype_float,
- BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE);
- builtin_function ("__builtin_sqrt", double_ftype_double,
- BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE);
- builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
- BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE);
-
- builtin_function ("__builtin_tanf", float_ftype_float,
- BUILT_IN_TANF, BUILT_IN_NORMAL, "tanf", NULL_TREE);
- builtin_function ("__builtin_tan", double_ftype_double,
- BUILT_IN_TAN, BUILT_IN_NORMAL, "tan", NULL_TREE);
- builtin_function ("__builtin_tanl", ldouble_ftype_ldouble,
- BUILT_IN_TANL, BUILT_IN_NORMAL, "tanl", NULL_TREE);
-
- pedantic_lvalues = FALSE;
-
- ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
- FFECOM_f2cINTEGER,
- "integer");
- ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
- FFECOM_f2cADDRESS,
- "address");
- ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
- FFECOM_f2cREAL,
- "real");
- ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
- FFECOM_f2cDOUBLEREAL,
- "doublereal");
- ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
- FFECOM_f2cCOMPLEX,
- "complex");
- ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
- FFECOM_f2cDOUBLECOMPLEX,
- "doublecomplex");
- ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
- FFECOM_f2cLONGINT,
- "longint");
- ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
- FFECOM_f2cLOGICAL,
- "logical");
- ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
- FFECOM_f2cFLAG,
- "flag");
- ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
- FFECOM_f2cFTNLEN,
- "ftnlen");
- ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
- FFECOM_f2cFTNINT,
- "ftnint");
-
- ffecom_f2c_ftnlen_zero_node
- = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
-
- ffecom_f2c_ftnlen_one_node
- = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
-
- ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
- TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
-
- ffecom_f2c_ptr_to_ftnlen_type_node
- = build_pointer_type (ffecom_f2c_ftnlen_type_node);
-
- ffecom_f2c_ptr_to_ftnint_type_node
- = build_pointer_type (ffecom_f2c_ftnint_type_node);
-
- ffecom_f2c_ptr_to_integer_type_node
- = build_pointer_type (ffecom_f2c_integer_type_node);
-
- ffecom_f2c_ptr_to_real_type_node
- = build_pointer_type (ffecom_f2c_real_type_node);
-
- ffecom_float_zero_ = build_real (float_type_node, dconst0);
- ffecom_double_zero_ = build_real (double_type_node, dconst0);
- ffecom_float_half_ = build_real (float_type_node, dconsthalf);
- ffecom_double_half_ = build_real (double_type_node, dconsthalf);
-
- /* Do "extern int xargc;". */
-
- ffecom_tree_xargc_ = build_decl (VAR_DECL,
- get_identifier ("f__xargc"),
- integer_type_node);
- DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
- TREE_STATIC (ffecom_tree_xargc_) = 1;
- TREE_PUBLIC (ffecom_tree_xargc_) = 1;
- ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
- finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
-
-#if 0 /* This is being fixed, and seems to be working now. */
- if ((FLOAT_TYPE_SIZE != 32)
- || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
- {
- warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
- (int) FLOAT_TYPE_SIZE);
- warning ("and pointers are %d bits wide, but g77 doesn't yet work",
- (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
- warning ("properly unless they all are 32 bits wide");
- warning ("Please keep this in mind before you report bugs.");
- }
-#endif
-
-#if 0 /* Code in ste.c that would crash has been commented out. */
- if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
- < TYPE_PRECISION (string_type_node))
- /* I/O will probably crash. */
- warning ("configuration: char * holds %d bits, but ftnlen only %d",
- TYPE_PRECISION (string_type_node),
- TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
-#endif
-
-#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
- if (TYPE_PRECISION (ffecom_integer_type_node)
- < TYPE_PRECISION (string_type_node))
- /* ASSIGN 10 TO I will crash. */
- warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
- ASSIGN statement might fail",
- TYPE_PRECISION (string_type_node),
- TYPE_PRECISION (ffecom_integer_type_node));
-#endif
-}
-
-/* ffecom_init_2 -- Initialize
-
- ffecom_init_2(); */
-
-void
-ffecom_init_2 (void)
-{
- assert (ffecom_outer_function_decl_ == NULL_TREE);
- assert (current_function_decl == NULL_TREE);
- assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
-
- ffecom_master_arglist_ = NULL;
- ++ffecom_num_fns_;
- ffecom_primary_entry_ = NULL;
- ffecom_is_altreturning_ = FALSE;
- ffecom_func_result_ = NULL_TREE;
- ffecom_multi_retval_ = NULL_TREE;
-}
-
-/* ffecom_list_expr -- Transform list of exprs into gcc tree
-
- tree t;
- ffebld expr; // FFE opITEM list.
- tree = ffecom_list_expr(expr);
-
- List of actual args is transformed into corresponding gcc backend list. */
-
-tree
-ffecom_list_expr (ffebld expr)
-{
- tree list;
- tree *plist = &list;
- tree trail = NULL_TREE; /* Append char length args here. */
- tree *ptrail = &trail;
- tree length;
-
- while (expr != NULL)
- {
- tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
-
- if (texpr == error_mark_node)
- return error_mark_node;
-
- *plist = build_tree_list (NULL_TREE, texpr);
- plist = &TREE_CHAIN (*plist);
- expr = ffebld_trail (expr);
- if (length != NULL_TREE)
- {
- *ptrail = build_tree_list (NULL_TREE, length);
- ptrail = &TREE_CHAIN (*ptrail);
- }
- }
-
- *plist = trail;
-
- return list;
-}
-
-/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
-
- tree t;
- ffebld expr; // FFE opITEM list.
- tree = ffecom_list_ptr_to_expr(expr);
-
- List of actual args is transformed into corresponding gcc backend list for
- use in calling an external procedure (vs. a statement function). */
-
-tree
-ffecom_list_ptr_to_expr (ffebld expr)
-{
- tree list;
- tree *plist = &list;
- tree trail = NULL_TREE; /* Append char length args here. */
- tree *ptrail = &trail;
- tree length;
-
- while (expr != NULL)
- {
- tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
-
- if (texpr == error_mark_node)
- return error_mark_node;
-
- *plist = build_tree_list (NULL_TREE, texpr);
- plist = &TREE_CHAIN (*plist);
- expr = ffebld_trail (expr);
- if (length != NULL_TREE)
- {
- *ptrail = build_tree_list (NULL_TREE, length);
- ptrail = &TREE_CHAIN (*ptrail);
- }
- }
-
- *plist = trail;
-
- return list;
-}
-
-/* Obtain gcc's LABEL_DECL tree for label. */
-
-tree
-ffecom_lookup_label (ffelab label)
-{
- tree glabel;
-
- if (ffelab_hook (label) == NULL_TREE)
- {
- char labelname[16];
-
- switch (ffelab_type (label))
- {
- case FFELAB_typeLOOPEND:
- case FFELAB_typeNOTLOOP:
- case FFELAB_typeENDIF:
- sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
- glabel = build_decl (LABEL_DECL, get_identifier (labelname),
- void_type_node);
- DECL_CONTEXT (glabel) = current_function_decl;
- DECL_MODE (glabel) = VOIDmode;
- break;
-
- case FFELAB_typeFORMAT:
- glabel = build_decl (VAR_DECL,
- ffecom_get_invented_identifier
- ("__g77_format_%d", (int) ffelab_value (label)),
- build_type_variant (build_array_type
- (char_type_node,
- NULL_TREE),
- 1, 0));
- TREE_CONSTANT (glabel) = 1;
- TREE_STATIC (glabel) = 1;
- DECL_CONTEXT (glabel) = current_function_decl;
- DECL_INITIAL (glabel) = NULL;
- make_decl_rtl (glabel, NULL);
- expand_decl (glabel);
-
- ffecom_save_tree_forever (glabel);
-
- break;
-
- case FFELAB_typeANY:
- glabel = error_mark_node;
- break;
-
- default:
- assert ("bad label type" == NULL);
- glabel = NULL;
- break;
- }
- ffelab_set_hook (label, glabel);
- }
- else
- {
- glabel = ffelab_hook (label);
- }
-
- return glabel;
-}
-
-/* Stabilizes the arguments. Don't use this if the lhs and rhs come from
- a single source specification (as in the fourth argument of MVBITS).
- If the type is NULL_TREE, the type of lhs is used to make the type of
- the MODIFY_EXPR. */
-
-tree
-ffecom_modify (tree newtype, tree lhs, tree rhs)
-{
- if (lhs == error_mark_node || rhs == error_mark_node)
- return error_mark_node;
-
- if (newtype == NULL_TREE)
- newtype = TREE_TYPE (lhs);
-
- if (TREE_SIDE_EFFECTS (lhs))
- lhs = stabilize_reference (lhs);
-
- return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
-}
-
-/* Register source file name. */
-
-void
-ffecom_file (const char *name)
-{
- ffecom_file_ (name);
-}
-
-/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
-
- ffestorag st;
- ffecom_notify_init_storage(st);
-
- Gets called when all possible units in an aggregate storage area (a LOCAL
- with equivalences or a COMMON) have been initialized. The initialization
- info either is in ffestorag_init or, if that is NULL,
- ffestorag_accretion:
-
- ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
- even for an array if the array is one element in length!
-
- ffestorag_accretion will contain an opACCTER. It is much like an
- opARRTER except it has an ffebit object in it instead of just a size.
- The back end can use the info in the ffebit object, if it wants, to
- reduce the amount of actual initialization, but in any case it should
- kill the ffebit object when done. Also, set accretion to NULL but
- init to a non-NULL value.
-
- After performing initialization, DO NOT set init to NULL, because that'll
- tell the front end it is ok for more initialization to happen. Instead,
- set init to an opANY expression or some such thing that you can use to
- tell that you've already initialized the object.
-
- 27-Oct-91 JCB 1.1
- Support two-pass FFE. */
-
-void
-ffecom_notify_init_storage (ffestorag st)
-{
- ffebld init; /* The initialization expression. */
-
- if (ffestorag_init (st) == NULL)
- {
- init = ffestorag_accretion (st);
- assert (init != NULL);
- ffestorag_set_accretion (st, NULL);
- ffestorag_set_accretes (st, 0);
- ffestorag_set_init (st, init);
- }
-}
-
-/* ffecom_notify_init_symbol -- A symbol is now fully init'ed
-
- ffesymbol s;
- ffecom_notify_init_symbol(s);
-
- Gets called when all possible units in a symbol (not placed in COMMON
- or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
- have been initialized. The initialization info either is in
- ffesymbol_init or, if that is NULL, ffesymbol_accretion:
-
- ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
- even for an array if the array is one element in length!
-
- ffesymbol_accretion will contain an opACCTER. It is much like an
- opARRTER except it has an ffebit object in it instead of just a size.
- The back end can use the info in the ffebit object, if it wants, to
- reduce the amount of actual initialization, but in any case it should
- kill the ffebit object when done. Also, set accretion to NULL but
- init to a non-NULL value.
-
- After performing initialization, DO NOT set init to NULL, because that'll
- tell the front end it is ok for more initialization to happen. Instead,
- set init to an opANY expression or some such thing that you can use to
- tell that you've already initialized the object.
-
- 27-Oct-91 JCB 1.1
- Support two-pass FFE. */
-
-void
-ffecom_notify_init_symbol (ffesymbol s)
-{
- ffebld init; /* The initialization expression. */
-
- if (ffesymbol_storage (s) == NULL)
- return; /* Do nothing until COMMON/EQUIVALENCE
- possibilities checked. */
-
- if ((ffesymbol_init (s) == NULL)
- && ((init = ffesymbol_accretion (s)) != NULL))
- {
- ffesymbol_set_accretion (s, NULL);
- ffesymbol_set_accretes (s, 0);
- ffesymbol_set_init (s, init);
- }
-}
-
-/* ffecom_notify_primary_entry -- Learn which is the primary entry point
-
- ffesymbol s;
- ffecom_notify_primary_entry(s);
-
- Gets called when implicit or explicit PROGRAM statement seen or when
- FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
- global symbol that serves as the entry point. */
-
-void
-ffecom_notify_primary_entry (ffesymbol s)
-{
- ffecom_primary_entry_ = s;
- ffecom_primary_entry_kind_ = ffesymbol_kind (s);
-
- if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
- || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
- ffecom_primary_entry_is_proc_ = TRUE;
- else
- ffecom_primary_entry_is_proc_ = FALSE;
-
- if (!ffe_is_silent ())
- {
- if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
- fprintf (stderr, "%s:\n", ffesymbol_text (s));
- else
- fprintf (stderr, " %s:\n", ffesymbol_text (s));
- }
-
- if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
- {
- ffebld list;
- ffebld arg;
-
- for (list = ffesymbol_dummyargs (s);
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) == FFEBLD_opSTAR)
- {
- ffecom_is_altreturning_ = TRUE;
- break;
- }
- }
- }
-}
-
-FILE *
-ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
-{
- return ffecom_open_include_ (name, l, c);
-}
-
-/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
-
- tree t;
- ffebld expr; // FFE expression.
- tree = ffecom_ptr_to_expr(expr);
-
- Like ffecom_expr, but sticks address-of in front of most things. */
-
-tree
-ffecom_ptr_to_expr (ffebld expr)
-{
- tree item;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffesymbol s;
-
- assert (expr != NULL);
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- s = ffebld_symter (expr);
- if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
- {
- ffecomGfrt ix;
-
- ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
- assert (ix != FFECOM_gfrt);
- if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
- {
- ffecom_make_gfrt_ (ix);
- item = ffecom_gfrt_[ix];
- }
- }
- else
- {
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
- }
- assert (item != NULL);
- if (item == error_mark_node)
- return item;
- if (!ffesymbol_hook (s).addr)
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
-
- case FFEBLD_opARRAYREF:
- return ffecom_arrayref_ (NULL_TREE, expr, 1);
-
- case FFEBLD_opCONTER:
-
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
-
- item = ffecom_constantunion (&ffebld_constant_union
- (ffebld_conter (expr)), bt, kt,
- ffecom_tree_type[bt][kt]);
- if (item == error_mark_node)
- return error_mark_node;
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
-
- case FFEBLD_opANY:
- return error_mark_node;
-
- default:
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
-
- item = ffecom_expr (expr);
- if (item == error_mark_node)
- return error_mark_node;
-
- /* The back end currently optimizes a bit too zealously for us, in that
- we fail JCB001 if the following block of code is omitted. It checks
- to see if the transformed expression is a symbol or array reference,
- and encloses it in a SAVE_EXPR if that is the case. */
-
- STRIP_NOPS (item);
- if ((TREE_CODE (item) == VAR_DECL)
- || (TREE_CODE (item) == PARM_DECL)
- || (TREE_CODE (item) == RESULT_DECL)
- || (TREE_CODE (item) == INDIRECT_REF)
- || (TREE_CODE (item) == ARRAY_REF)
- || (TREE_CODE (item) == COMPONENT_REF)
-#ifdef OFFSET_REF
- || (TREE_CODE (item) == OFFSET_REF)
-#endif
- || (TREE_CODE (item) == BUFFER_REF)
- || (TREE_CODE (item) == REALPART_EXPR)
- || (TREE_CODE (item) == IMAGPART_EXPR))
- {
- item = ffecom_save_tree (item);
- }
-
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
- }
-
- assert ("fall-through error" == NULL);
- return error_mark_node;
-}
-
-/* Obtain a temp var with given data type.
-
- size is FFETARGET_charactersizeNONE for a non-CHARACTER type
- or >= 0 for a CHARACTER type.
-
- elements is -1 for a scalar or > 0 for an array of type. */
-
-tree
-ffecom_make_tempvar (const char *commentary, tree type,
- ffetargetCharacterSize size, int elements)
-{
- tree t;
- static int mynumber;
-
- assert (current_binding_level->prep_state < 2);
-
- if (type == error_mark_node)
- return error_mark_node;
-
- if (size != FFETARGET_charactersizeNONE)
- type = build_array_type (type,
- build_range_type (ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- build_int_2 (size, 0)));
- if (elements != -1)
- type = build_array_type (type,
- build_range_type (integer_type_node,
- integer_zero_node,
- build_int_2 (elements - 1,
- 0)));
- t = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_%s_%d",
- commentary,
- mynumber++),
- type);
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- return t;
-}
-
-/* Prepare argument pointer to expression.
-
- Like ffecom_prepare_expr, except for expressions to be evaluated
- via ffecom_arg_ptr_to_expr. */
-
-void
-ffecom_prepare_arg_ptr_to_expr (ffebld expr)
-{
- /* ~~For now, it seems to be the same thing. */
- ffecom_prepare_expr (expr);
- return;
-}
-
-/* End of preparations. */
-
-bool
-ffecom_prepare_end (void)
-{
- int prep_state = current_binding_level->prep_state;
-
- assert (prep_state < 2);
- current_binding_level->prep_state = 2;
-
- return (prep_state == 1) ? TRUE : FALSE;
-}
-
-/* Prepare expression.
-
- This is called before any code is generated for the current block.
- It scans the expression, declares any temporaries that might be needed
- during evaluation of the expression, and stores those temporaries in
- the appropriate "hook" fields of the expression. `dest', if not NULL,
- specifies the destination that ffecom_expr_ will see, in case that
- helps avoid generating unused temporaries.
-
- ~~Improve to avoid allocating unused temporaries by taking `dest'
- into account vis-a-vis aliasing requirements of complex/character
- functions. */
-
-void
-ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
-{
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize sz;
- tree tempvar = NULL_TREE;
-
- assert (current_binding_level->prep_state < 2);
-
- if (! expr)
- return;
-
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
- sz = ffeinfo_size (ffebld_info (expr));
-
- /* Generate whatever temporaries are needed to represent the result
- of the expression. */
-
- if (bt == FFEINFO_basictypeCHARACTER)
- {
- while (ffebld_op (expr) == FFEBLD_opPAREN)
- expr = ffebld_left (expr);
- }
-
- switch (ffebld_op (expr))
- {
- default:
- /* Don't make temps for SYMTER, CONTER, etc. */
- if (ffebld_arity (expr) == 0)
- break;
-
- switch (bt)
- {
- case FFEINFO_basictypeCOMPLEX:
- if (ffebld_op (expr) == FFEBLD_opFUNCREF)
- {
- ffesymbol s;
-
- if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
- break;
-
- s = ffebld_symter (ffebld_left (expr));
- if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
- || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
- && ! ffesymbol_is_f2c (s))
- || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
- && ! ffe_is_f2c_library ()))
- break;
- }
- else if (ffebld_op (expr) == FFEBLD_opPOWER)
- {
- /* Requires special treatment. There's no POW_CC function
- in libg2c, so POW_ZZ is used, which means we always
- need a double-complex temp, not a single-complex. */
- kt = FFEINFO_kindtypeREAL2;
- }
- else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
- /* The other ops don't need temps for complex operands. */
- break;
-
- /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
- REAL(C). See 19990325-0.f, routine `check', for cases. */
- tempvar = ffecom_make_tempvar ("complex",
- ffecom_tree_type
- [FFEINFO_basictypeCOMPLEX][kt],
- FFETARGET_charactersizeNONE,
- -1);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- if (ffebld_op (expr) != FFEBLD_opFUNCREF)
- break;
-
- if (sz == FFETARGET_charactersizeNONE)
- /* ~~Kludge alert! This should someday be fixed. */
- sz = 24;
-
- tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
- break;
-
- default:
- break;
- }
- break;
-
- case FFEBLD_opCONCATENATE:
- {
- /* This gets special handling, because only one set of temps
- is needed for a tree of these -- the tree is treated as
- a flattened list of concatenations when generating code. */
-
- ffecomConcatList_ catlist;
- tree ltmp, itmp, result;
- int count;
- int i;
-
- catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
- count = ffecom_concat_list_count_ (catlist);
-
- if (count >= 2)
- {
- ltmp
- = ffecom_make_tempvar ("concat_len",
- ffecom_f2c_ftnlen_type_node,
- FFETARGET_charactersizeNONE, count);
- itmp
- = ffecom_make_tempvar ("concat_item",
- ffecom_f2c_address_type_node,
- FFETARGET_charactersizeNONE, count);
- result
- = ffecom_make_tempvar ("concat_res",
- char_type_node,
- ffecom_concat_list_maxlen_ (catlist),
- -1);
-
- tempvar = make_tree_vec (3);
- TREE_VEC_ELT (tempvar, 0) = ltmp;
- TREE_VEC_ELT (tempvar, 1) = itmp;
- TREE_VEC_ELT (tempvar, 2) = result;
- }
-
- for (i = 0; i < count; ++i)
- ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
- i));
-
- ffecom_concat_list_kill_ (catlist);
-
- if (tempvar)
- {
- ffebld_nonter_set_hook (expr, tempvar);
- current_binding_level->prep_state = 1;
- }
- }
- return;
-
- case FFEBLD_opCONVERT:
- if (bt == FFEINFO_basictypeCHARACTER
- && ((ffebld_size_known (ffebld_left (expr))
- == FFETARGET_charactersizeNONE)
- || (ffebld_size_known (ffebld_left (expr)) >= sz)))
- tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
- break;
- }
-
- if (tempvar)
- {
- ffebld_nonter_set_hook (expr, tempvar);
- current_binding_level->prep_state = 1;
- }
-
- /* Prepare subexpressions for this expr. */
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opPERCENT_LOC:
- ffecom_prepare_ptr_to_expr (ffebld_left (expr));
- break;
-
- case FFEBLD_opPERCENT_VAL:
- case FFEBLD_opPERCENT_REF:
- ffecom_prepare_expr (ffebld_left (expr));
- break;
-
- case FFEBLD_opPERCENT_DESCR:
- ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
- break;
-
- case FFEBLD_opITEM:
- {
- ffebld item;
-
- for (item = expr;
- item != NULL;
- item = ffebld_trail (item))
- if (ffebld_head (item) != NULL)
- ffecom_prepare_expr (ffebld_head (item));
- }
- break;
-
- default:
- /* Need to handle character conversion specially. */
- switch (ffebld_arity (expr))
- {
- case 2:
- ffecom_prepare_expr (ffebld_left (expr));
- ffecom_prepare_expr (ffebld_right (expr));
- break;
-
- case 1:
- ffecom_prepare_expr (ffebld_left (expr));
- break;
-
- default:
- break;
- }
- }
-
- return;
-}
-
-/* Prepare expression for reading and writing.
-
- Like ffecom_prepare_expr, except for expressions to be evaluated
- via ffecom_expr_rw. */
-
-void
-ffecom_prepare_expr_rw (tree type, ffebld expr)
-{
- /* This is all we support for now. */
- assert (type == NULL_TREE || type == ffecom_type_expr (expr));
-
- /* ~~For now, it seems to be the same thing. */
- ffecom_prepare_expr (expr);
- return;
-}
-
-/* Prepare expression for writing.
-
- Like ffecom_prepare_expr, except for expressions to be evaluated
- via ffecom_expr_w. */
-
-void
-ffecom_prepare_expr_w (tree type, ffebld expr)
-{
- /* This is all we support for now. */
- assert (type == NULL_TREE || type == ffecom_type_expr (expr));
-
- /* ~~For now, it seems to be the same thing. */
- ffecom_prepare_expr (expr);
- return;
-}
-
-/* Prepare expression for returning.
-
- Like ffecom_prepare_expr, except for expressions to be evaluated
- via ffecom_return_expr. */
-
-void
-ffecom_prepare_return_expr (ffebld expr)
-{
- assert (current_binding_level->prep_state < 2);
-
- if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
- && ffecom_is_altreturning_
- && expr != NULL)
- ffecom_prepare_expr (expr);
-}
-
-/* Prepare pointer to expression.
-
- Like ffecom_prepare_expr, except for expressions to be evaluated
- via ffecom_ptr_to_expr. */
-
-void
-ffecom_prepare_ptr_to_expr (ffebld expr)
-{
- /* ~~For now, it seems to be the same thing. */
- ffecom_prepare_expr (expr);
- return;
-}
-
-/* Transform expression into constant pointer-to-expression tree.
-
- If the expression can be transformed into a pointer-to-expression tree
- that is constant, that is done, and the tree returned. Else NULL_TREE
- is returned.
-
- That way, a caller can attempt to provide compile-time initialization
- of a variable and, if that fails, *then* choose to start a new block
- and resort to using temporaries, as appropriate. */
-
-tree
-ffecom_ptr_to_const_expr (ffebld expr)
-{
- if (! expr)
- return integer_zero_node;
-
- if (ffebld_op (expr) == FFEBLD_opANY)
- return error_mark_node;
-
- if (ffebld_arity (expr) == 0
- && (ffebld_op (expr) != FFEBLD_opSYMTER
- || ffebld_where (expr) == FFEINFO_whereCOMMON
- || ffebld_where (expr) == FFEINFO_whereGLOBAL
- || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
- {
- tree t;
-
- t = ffecom_ptr_to_expr (expr);
- assert (TREE_CONSTANT (t));
- return t;
- }
-
- return NULL_TREE;
-}
-
-/* ffecom_return_expr -- Returns return-value expr given alt return expr
-
- tree rtn; // NULL_TREE means use expand_null_return()
- ffebld expr; // NULL if no alt return expr to RETURN stmt
- rtn = ffecom_return_expr(expr);
-
- Based on the program unit type and other info (like return function
- type, return master function type when alternate ENTRY points,
- whether subroutine has any alternate RETURN points, etc), returns the
- appropriate expression to be returned to the caller, or NULL_TREE
- meaning no return value or the caller expects it to be returned somewhere
- else (which is handled by other parts of this module). */
-
-tree
-ffecom_return_expr (ffebld expr)
-{
- tree rtn;
-
- switch (ffecom_primary_entry_kind_)
- {
- case FFEINFO_kindPROGRAM:
- case FFEINFO_kindBLOCKDATA:
- rtn = NULL_TREE;
- break;
-
- case FFEINFO_kindSUBROUTINE:
- if (!ffecom_is_altreturning_)
- rtn = NULL_TREE; /* No alt returns, never an expr. */
- else if (expr == NULL)
- rtn = integer_zero_node;
- else
- rtn = ffecom_expr (expr);
- break;
-
- case FFEINFO_kindFUNCTION:
- if ((ffecom_multi_retval_ != NULL_TREE)
- || (ffesymbol_basictype (ffecom_primary_entry_)
- == FFEINFO_basictypeCHARACTER)
- || ((ffesymbol_basictype (ffecom_primary_entry_)
- == FFEINFO_basictypeCOMPLEX)
- && (ffecom_num_entrypoints_ == 0)
- && ffesymbol_is_f2c (ffecom_primary_entry_)))
- { /* Value is returned by direct assignment
- into (implicit) dummy. */
- rtn = NULL_TREE;
- break;
- }
- rtn = ffecom_func_result_;
-#if 0
- /* Spurious error if RETURN happens before first reference! So elide
- this code. In particular, for debugging registry, rtn should always
- be non-null after all, but TREE_USED won't be set until we encounter
- a reference in the code. Perfectly okay (but weird) code that,
- e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
- this diagnostic for no reason. Have people use -O -Wuninitialized
- and leave it to the back end to find obviously weird cases. */
-
- /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
- situation; if the return value has never been referenced, it won't
- have a tree under 2pass mode. */
- if ((rtn == NULL_TREE)
- || !TREE_USED (rtn))
- {
- ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
- ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
- ffesymbol_where_column (ffecom_primary_entry_));
- ffebad_string (ffesymbol_text (ffesymbol_funcresult
- (ffecom_primary_entry_)));
- ffebad_finish ();
- }
-#endif
- break;
-
- default:
- assert ("bad unit kind" == NULL);
- case FFEINFO_kindANY:
- rtn = error_mark_node;
- break;
- }
-
- return rtn;
-}
-
-/* Do save_expr only if tree is not error_mark_node. */
-
-tree
-ffecom_save_tree (tree t)
-{
- return save_expr (t);
-}
-
-/* Start a compound statement (block). */
-
-void
-ffecom_start_compstmt (void)
-{
- bison_rule_pushlevel_ ();
-}
-
-/* Public entry point for front end to access start_decl. */
-
-tree
-ffecom_start_decl (tree decl, bool is_initialized)
-{
- DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
- return start_decl (decl, FALSE);
-}
-
-/* ffecom_sym_commit -- Symbol's state being committed to reality
-
- ffesymbol s;
- ffecom_sym_commit(s);
-
- Does whatever the backend needs when a symbol is committed after having
- been backtrackable for a period of time. */
-
-void
-ffecom_sym_commit (ffesymbol s UNUSED)
-{
- assert (!ffesymbol_retractable ());
-}
-
-/* ffecom_sym_end_transition -- Perform end transition on all symbols
-
- ffecom_sym_end_transition();
-
- Does backend-specific stuff and also calls ffest_sym_end_transition
- to do the necessary FFE stuff.
-
- Backtracking is never enabled when this fn is called, so don't worry
- about it. */
-
-ffesymbol
-ffecom_sym_end_transition (ffesymbol s)
-{
- ffestorag st;
-
- assert (!ffesymbol_retractable ());
-
- s = ffest_sym_end_transition (s);
-
- if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
- && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
- {
- ffecom_list_blockdata_
- = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE),
- ffecom_list_blockdata_);
- }
-
- /* This is where we finally notice that a symbol has partial initialization
- and finalize it. */
-
- if (ffesymbol_accretion (s) != NULL)
- {
- assert (ffesymbol_init (s) == NULL);
- ffecom_notify_init_symbol (s);
- }
- else if (((st = ffesymbol_storage (s)) != NULL)
- && ((st = ffestorag_parent (st)) != NULL)
- && (ffestorag_accretion (st) != NULL))
- {
- assert (ffestorag_init (st) == NULL);
- ffecom_notify_init_storage (st);
- }
-
- if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
- && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
- && (ffesymbol_storage (s) != NULL))
- {
- ffecom_list_common_
- = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE),
- ffecom_list_common_);
- }
-
- return s;
-}
-
-/* ffecom_sym_exec_transition -- Perform exec transition on all symbols
-
- ffecom_sym_exec_transition();
-
- Does backend-specific stuff and also calls ffest_sym_exec_transition
- to do the necessary FFE stuff.
-
- See the long-winded description in ffecom_sym_learned for info
- on handling the situation where backtracking is inhibited. */
-
-ffesymbol
-ffecom_sym_exec_transition (ffesymbol s)
-{
- s = ffest_sym_exec_transition (s);
-
- return s;
-}
-
-/* ffecom_sym_learned -- Initial or more info gained on symbol after exec
-
- ffesymbol s;
- s = ffecom_sym_learned(s);
-
- Called when a new symbol is seen after the exec transition or when more
- info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
- it arrives here is that all its latest info is updated already, so its
- state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
- field filled in if its gone through here or exec_transition first, and
- so on.
-
- The backend probably wants to check ffesymbol_retractable() to see if
- backtracking is in effect. If so, the FFE's changes to the symbol may
- be retracted (undone) or committed (ratified), at which time the
- appropriate ffecom_sym_retract or _commit function will be called
- for that function.
-
- If the backend has its own backtracking mechanism, great, use it so that
- committal is a simple operation. Though it doesn't make much difference,
- I suppose: the reason for tentative symbol evolution in the FFE is to
- enable error detection in weird incorrect statements early and to disable
- incorrect error detection on a correct statement. The backend is not
- likely to introduce any information that'll get involved in these
- considerations, so it is probably just fine that the implementation
- model for this fn and for _exec_transition is to not do anything
- (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
- and instead wait until ffecom_sym_commit is called (which it never
- will be as long as we're using ambiguity-detecting statement analysis in
- the FFE, which we are initially to shake out the code, but don't depend
- on this), otherwise go ahead and do whatever is needed.
-
- In essence, then, when this fn and _exec_transition get called while
- backtracking is enabled, a general mechanism would be to flag which (or
- both) of these were called (and in what order? neat question as to what
- might happen that I'm too lame to think through right now) and then when
- _commit is called reproduce the original calling sequence, if any, for
- the two fns (at which point backtracking will, of course, be disabled). */
-
-ffesymbol
-ffecom_sym_learned (ffesymbol s)
-{
- ffestorag_exec_layout (s);
-
- return s;
-}
-
-/* ffecom_sym_retract -- Symbol's state being retracted from reality
-
- ffesymbol s;
- ffecom_sym_retract(s);
-
- Does whatever the backend needs when a symbol is retracted after having
- been backtrackable for a period of time. */
-
-void
-ffecom_sym_retract (ffesymbol s UNUSED)
-{
- assert (!ffesymbol_retractable ());
-
-#if 0 /* GCC doesn't commit any backtrackable sins,
- so nothing needed here. */
- switch (ffesymbol_hook (s).state)
- {
- case 0: /* nothing happened yet. */
- break;
-
- case 1: /* exec transition happened. */
- break;
-
- case 2: /* learned happened. */
- break;
-
- case 3: /* learned then exec. */
- break;
-
- case 4: /* exec then learned. */
- break;
-
- default:
- assert ("bad hook state" == NULL);
- break;
- }
-#endif
-}
-
-/* Create temporary gcc label. */
-
-tree
-ffecom_temp_label (void)
-{
- tree glabel;
- static int mynumber = 0;
-
- glabel = build_decl (LABEL_DECL,
- ffecom_get_invented_identifier ("__g77_label_%d",
- mynumber++),
- void_type_node);
- DECL_CONTEXT (glabel) = current_function_decl;
- DECL_MODE (glabel) = VOIDmode;
-
- return glabel;
-}
-
-/* Return an expression that is usable as an arg in a conditional context
- (IF, DO WHILE, .NOT., and so on).
-
- Use the one provided for the back end as of >2.6.0. */
-
-tree
-ffecom_truth_value (tree expr)
-{
- return ffe_truthvalue_conversion (expr);
-}
-
-/* Return the inversion of a truth value (the inversion of what
- ffecom_truth_value builds).
-
- Apparently invert_truthvalue, which is properly in the back end, is
- enough for now, so just use it. */
-
-tree
-ffecom_truth_value_invert (tree expr)
-{
- return invert_truthvalue (ffecom_truth_value (expr));
-}
-
-/* Return the tree that is the type of the expression, as would be
- returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
- transforming the expression, generating temporaries, etc. */
-
-tree
-ffecom_type_expr (ffebld expr)
-{
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- tree tree_type;
-
- assert (expr != NULL);
-
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
- tree_type = ffecom_tree_type[bt][kt];
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opCONTER:
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opUPLUS:
- case FFEBLD_opPAREN:
- case FFEBLD_opUMINUS:
- case FFEBLD_opADD:
- case FFEBLD_opSUBTRACT:
- case FFEBLD_opMULTIPLY:
- case FFEBLD_opDIVIDE:
- case FFEBLD_opPOWER:
- case FFEBLD_opNOT:
- case FFEBLD_opFUNCREF:
- case FFEBLD_opSUBRREF:
- case FFEBLD_opAND:
- case FFEBLD_opOR:
- case FFEBLD_opXOR:
- case FFEBLD_opNEQV:
- case FFEBLD_opEQV:
- case FFEBLD_opCONVERT:
- case FFEBLD_opLT:
- case FFEBLD_opLE:
- case FFEBLD_opEQ:
- case FFEBLD_opNE:
- case FFEBLD_opGT:
- case FFEBLD_opGE:
- case FFEBLD_opPERCENT_LOC:
- return tree_type;
-
- case FFEBLD_opACCTER:
- case FFEBLD_opARRTER:
- case FFEBLD_opITEM:
- case FFEBLD_opSTAR:
- case FFEBLD_opBOUNDS:
- case FFEBLD_opREPEAT:
- case FFEBLD_opLABTER:
- case FFEBLD_opLABTOK:
- case FFEBLD_opIMPDO:
- case FFEBLD_opCONCATENATE:
- case FFEBLD_opSUBSTR:
- default:
- assert ("bad op for ffecom_type_expr" == NULL);
- /* Fall through. */
- case FFEBLD_opANY:
- return error_mark_node;
- }
-}
-
-/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
-
- If the PARM_DECL already exists, return it, else create it. It's an
- integer_type_node argument for the master function that implements a
- subroutine or function with more than one entrypoint and is bound at
- run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
- first ENTRY statement, and so on). */
-
-tree
-ffecom_which_entrypoint_decl (void)
-{
- assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
-
- return ffecom_which_entrypoint_decl_;
-}
-\f
-/* The following sections consists of private and public functions
- that have the same names and perform roughly the same functions
- as counterparts in the C front end. Changes in the C front end
- might affect how things should be done here. Only functions
- needed by the back end should be public here; the rest should
- be private (static in the C sense). Functions needed by other
- g77 front-end modules should be accessed by them via public
- ffecom_* names, which should themselves call private versions
- in this section so the private versions are easy to recognize
- when upgrading to a new gcc and finding interesting changes
- in the front end.
-
- Functions named after rule "foo:" in c-parse.y are named
- "bison_rule_foo_" so they are easy to find. */
-
-static void
-bison_rule_pushlevel_ (void)
-{
- emit_line_note (input_location);
- pushlevel (0);
- clear_last_expr ();
- expand_start_bindings (0);
-}
-
-static tree
-bison_rule_compstmt_ (void)
-{
- tree t;
- int keep = kept_level_p ();
-
- /* Make the temps go away. */
- if (! keep)
- current_binding_level->names = NULL_TREE;
-
- emit_line_note (input_location);
- expand_end_bindings (getdecls (), keep, 0);
- t = poplevel (keep, 1, 0);
-
- return t;
-}
-
-/* Return a definition for a builtin function named NAME and whose data type
- is TYPE. TYPE should be a function type with argument types.
- FUNCTION_CODE tells later passes how to compile calls to this function.
- See tree.h for its possible values.
-
- If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
- the name to be called if we can't opencode the function. If
- ATTRS is nonzero, use that for the function's attribute list. */
-
-tree
-builtin_function (const char *name, tree type, int function_code,
- enum built_in_class class, const char *library_name,
- tree attrs ATTRIBUTE_UNUSED)
-{
- tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
- DECL_EXTERNAL (decl) = 1;
- TREE_PUBLIC (decl) = 1;
- if (library_name)
- SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
- make_decl_rtl (decl, NULL);
- pushdecl (decl);
- DECL_BUILT_IN_CLASS (decl) = class;
- DECL_FUNCTION_CODE (decl) = function_code;
-
- return decl;
-}
-
-/* Handle when a new declaration NEWDECL
- has the same name as an old one OLDDECL
- in the same binding contour.
- Prints an error message if appropriate.
-
- If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
- Otherwise, return 0. */
-
-static int
-duplicate_decls (tree newdecl, tree olddecl)
-{
- int types_match = 1;
- int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
- && DECL_INITIAL (newdecl) != 0);
- tree oldtype = TREE_TYPE (olddecl);
- tree newtype = TREE_TYPE (newdecl);
-
- if (olddecl == newdecl)
- return 1;
-
- if (TREE_CODE (newtype) == ERROR_MARK
- || TREE_CODE (oldtype) == ERROR_MARK)
- types_match = 0;
-
- /* New decl is completely inconsistent with the old one =>
- tell caller to replace the old one.
- This is always an error except in the case of shadowing a builtin. */
- if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
- return 0;
-
- /* For real parm decl following a forward decl,
- return 1 so old decl will be reused. */
- if (types_match && TREE_CODE (newdecl) == PARM_DECL
- && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
- return 1;
-
- /* The new declaration is the same kind of object as the old one.
- The declarations may partially match. Print warnings if they don't
- match enough. Ultimately, copy most of the information from the new
- decl to the old one, and keep using the old one. */
-
- if (TREE_CODE (olddecl) == FUNCTION_DECL
- && DECL_BUILT_IN (olddecl))
- {
- /* A function declaration for a built-in function. */
- if (!TREE_PUBLIC (newdecl))
- return 0;
- else if (!types_match)
- {
- /* Accept the return type of the new declaration if same modes. */
- tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
- tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
-
- if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
- {
- /* Function types may be shared, so we can't just modify
- the return type of olddecl's function type. */
- tree newtype
- = build_function_type (newreturntype,
- TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
-
- types_match = 1;
- if (types_match)
- TREE_TYPE (olddecl) = newtype;
- }
- }
- if (!types_match)
- return 0;
- }
- else if (TREE_CODE (olddecl) == FUNCTION_DECL
- && DECL_SOURCE_LINE (olddecl) == 0)
- {
- /* A function declaration for a predeclared function
- that isn't actually built in. */
- if (!TREE_PUBLIC (newdecl))
- return 0;
- else if (!types_match)
- {
- /* If the types don't match, preserve volatility indication.
- Later on, we will discard everything else about the
- default declaration. */
- TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
- }
- }
-
- /* Copy all the DECL_... slots specified in the new decl
- except for any that we copy here from the old type.
-
- Past this point, we don't change OLDTYPE and NEWTYPE
- even if we change the types of NEWDECL and OLDDECL. */
-
- if (types_match)
- {
- /* Merge the data types specified in the two decls. */
- if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
- TREE_TYPE (newdecl)
- = TREE_TYPE (olddecl)
- = TREE_TYPE (newdecl);
-
- /* Lay the type out, unless already done. */
- if (oldtype != TREE_TYPE (newdecl))
- {
- if (TREE_TYPE (newdecl) != error_mark_node)
- layout_type (TREE_TYPE (newdecl));
- if (TREE_CODE (newdecl) != FUNCTION_DECL
- && TREE_CODE (newdecl) != TYPE_DECL
- && TREE_CODE (newdecl) != CONST_DECL)
- layout_decl (newdecl, 0);
- }
- else
- {
- /* Since the type is OLDDECL's, make OLDDECL's size go with. */
- DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
- DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
- if (TREE_CODE (olddecl) != FUNCTION_DECL)
- if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
- {
- DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
- DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
- }
- }
-
- /* Keep the old rtl since we can safely use it. */
- COPY_DECL_RTL (olddecl, newdecl);
-
- /* Merge the type qualifiers. */
- if (TREE_READONLY (newdecl))
- TREE_READONLY (olddecl) = 1;
- if (TREE_THIS_VOLATILE (newdecl))
- {
- TREE_THIS_VOLATILE (olddecl) = 1;
- if (TREE_CODE (newdecl) == VAR_DECL)
- make_var_volatile (newdecl);
- }
-
- /* Keep source location of definition rather than declaration.
- Likewise, keep decl at outer scope. */
- if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
- || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
- {
- DECL_SOURCE_LOCATION (newdecl) = DECL_SOURCE_LOCATION (olddecl);
-
- if (DECL_CONTEXT (olddecl) == 0
- && TREE_CODE (newdecl) != FUNCTION_DECL)
- DECL_CONTEXT (newdecl) = 0;
- }
-
- /* Merge the unused-warning information. */
- if (DECL_IN_SYSTEM_HEADER (olddecl))
- DECL_IN_SYSTEM_HEADER (newdecl) = 1;
- else if (DECL_IN_SYSTEM_HEADER (newdecl))
- DECL_IN_SYSTEM_HEADER (olddecl) = 1;
-
- /* Merge the initialization information. */
- if (DECL_INITIAL (newdecl) == 0)
- DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
-
- /* Merge the section attribute.
- We want to issue an error if the sections conflict but that must be
- done later in decl_attributes since we are called before attributes
- are assigned. */
- if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
- DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
-
- /* Copy the assembler name. */
- COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl);
-
- if (TREE_CODE (newdecl) == FUNCTION_DECL)
- {
- DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
- DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
- TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
- TREE_READONLY (newdecl) |= TREE_READONLY (olddecl);
- DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl);
- DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl);
- }
- }
- /* If cannot merge, then use the new type and qualifiers,
- and don't preserve the old rtl. */
- else
- {
- TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
- TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
- TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
- TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
- }
-
- /* Merge the storage class information. */
- /* For functions, static overrides non-static. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL)
- {
- TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
- /* This is since we don't automatically
- copy the attributes of NEWDECL into OLDDECL. */
- TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
- /* If this clears `static', clear it in the identifier too. */
- if (! TREE_PUBLIC (olddecl))
- TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
- }
- if (DECL_EXTERNAL (newdecl))
- {
- TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
- DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
- /* An extern decl does not override previous storage class. */
- TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
- }
- else
- {
- TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
- TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
- }
-
- /* If either decl says `inline', this fn is inline,
- unless its definition was passed already. */
- if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
- DECL_INLINE (olddecl) = 1;
- DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
-
- /* Get rid of any built-in function if new arg types don't match it
- or if we have a function definition. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL
- && DECL_BUILT_IN (olddecl)
- && (!types_match || new_is_definition))
- {
- TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
- DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
- }
-
- /* If redeclaring a builtin function, and not a definition,
- it stays built in.
- Also preserve various other info from the definition. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
- {
- if (DECL_BUILT_IN (olddecl))
- {
- DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
- DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
- }
-
- DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
- DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
- DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
- DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
- }
-
- /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
- But preserve olddecl's DECL_UID. */
- {
- register unsigned olddecl_uid = DECL_UID (olddecl);
-
- memcpy ((char *) olddecl + sizeof (struct tree_common),
- (char *) newdecl + sizeof (struct tree_common),
- sizeof (struct tree_decl) - sizeof (struct tree_common));
- DECL_UID (olddecl) = olddecl_uid;
- }
-
- return 1;
-}
-
-/* Finish processing of a declaration;
- install its initial value.
- If the length of an array type is not known before,
- it must be determined now, from the initial value, or it is an error. */
-
-static void
-finish_decl (tree decl, tree init, bool is_top_level)
-{
- register tree type = TREE_TYPE (decl);
- int was_incomplete = (DECL_SIZE (decl) == 0);
- bool at_top_level = (current_binding_level == global_binding_level);
- bool top_level = is_top_level || at_top_level;
-
- /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
- level anyway. */
- assert (!is_top_level || !at_top_level);
-
- if (TREE_CODE (decl) == PARM_DECL)
- assert (init == NULL_TREE);
- /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
- overlaps DECL_ARG_TYPE. */
- else if (init == NULL_TREE)
- assert (DECL_INITIAL (decl) == NULL_TREE);
- else
- assert (DECL_INITIAL (decl) == error_mark_node);
-
- if (init != NULL_TREE)
- {
- if (TREE_CODE (decl) != TYPE_DECL)
- DECL_INITIAL (decl) = init;
- else
- {
- /* typedef foo = bar; store the type of bar as the type of foo. */
- TREE_TYPE (decl) = TREE_TYPE (init);
- DECL_INITIAL (decl) = init = 0;
- }
- }
-
- /* Deduce size of array from initialization, if not already known */
-
- if (TREE_CODE (type) == ARRAY_TYPE
- && TYPE_DOMAIN (type) == 0
- && TREE_CODE (decl) != TYPE_DECL)
- {
- assert (top_level);
- assert (was_incomplete);
-
- layout_decl (decl, 0);
- }
-
- if (TREE_CODE (decl) == VAR_DECL)
- {
- if (DECL_SIZE (decl) == NULL_TREE
- && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
- layout_decl (decl, 0);
-
- if (DECL_SIZE (decl) == NULL_TREE
- && (TREE_STATIC (decl)
- ?
- /* A static variable with an incomplete type is an error if it is
- initialized. Also if it is not file scope. Otherwise, let it
- through, but if it is not `extern' then it may cause an error
- message later. */
- (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
- :
- /* An automatic variable with an incomplete type is an error. */
- !DECL_EXTERNAL (decl)))
- {
- assert ("storage size not known" == NULL);
- abort ();
- }
-
- if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
- && (DECL_SIZE (decl) != 0)
- && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
- {
- assert ("storage size not constant" == NULL);
- abort ();
- }
- }
-
- /* Output the assembler code and/or RTL code for variables and functions,
- unless the type is an undefined structure or union. If not, it will get
- done when the type is completed. */
-
- if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
- {
- rest_of_decl_compilation (decl, NULL,
- DECL_CONTEXT (decl) == 0,
- 0);
-
- if (DECL_CONTEXT (decl) != 0)
- {
- /* Recompute the RTL of a local array now if it used to be an
- incomplete type. */
- if (was_incomplete
- && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
- {
- /* If we used it already as memory, it must stay in memory. */
- TREE_ADDRESSABLE (decl) = TREE_USED (decl);
- /* If it's still incomplete now, no init will save it. */
- if (DECL_SIZE (decl) == 0)
- DECL_INITIAL (decl) = 0;
- expand_decl (decl);
- }
- /* Compute and store the initial value. */
- if (TREE_CODE (decl) != FUNCTION_DECL)
- expand_decl_init (decl);
- }
- }
- else if (TREE_CODE (decl) == TYPE_DECL)
- {
- rest_of_decl_compilation (decl, NULL,
- DECL_CONTEXT (decl) == 0,
- 0);
- }
-
- /* At the end of a declaration, throw away any variable type sizes of types
- defined inside that declaration. There is no use computing them in the
- following function definition. */
- if (current_binding_level == global_binding_level)
- get_pending_sizes ();
-}
-
-/* Finish up a function declaration and compile that function
- all the way to assembler language output. The free the storage
- for the function definition.
-
- This is called after parsing the body of the function definition.
-
- NESTED is nonzero if the function being finished is nested in another. */
-
-static void
-finish_function (int nested)
-{
- register tree fndecl = current_function_decl;
-
- assert (fndecl != NULL_TREE);
- if (TREE_CODE (fndecl) != ERROR_MARK)
- {
- if (nested)
- assert (DECL_CONTEXT (fndecl) != NULL_TREE);
- else
- assert (DECL_CONTEXT (fndecl) == NULL_TREE);
- }
-
-/* TREE_READONLY (fndecl) = 1;
- This caused &foo to be of type ptr-to-const-function
- which then got a warning when stored in a ptr-to-function variable. */
-
- poplevel (1, 0, 1);
-
- if (TREE_CODE (fndecl) != ERROR_MARK)
- {
- BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
-
- /* Must mark the RESULT_DECL as being in this function. */
-
- DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
-
- /* Obey `register' declarations if `setjmp' is called in this fn. */
- /* Generate rtl for function exit. */
- expand_function_end ();
-
- /* If this is a nested function, protect the local variables in the stack
- above us from being collected while we're compiling this function. */
- if (nested)
- ggc_push_context ();
-
- /* Run the optimizers and output the assembler code for this function. */
- rest_of_compilation (fndecl);
-
- /* Undo the GC context switch. */
- if (nested)
- ggc_pop_context ();
- }
-
- if (TREE_CODE (fndecl) != ERROR_MARK
- && !nested
- && DECL_SAVED_INSNS (fndecl) == 0)
- {
- /* Stop pointing to the local nodes about to be freed. */
- /* But DECL_INITIAL must remain nonzero so we know this was an actual
- function definition. */
- /* For a nested function, this is done in pop_f_function_context. */
- /* If rest_of_compilation set this to 0, leave it 0. */
- if (DECL_INITIAL (fndecl) != 0)
- DECL_INITIAL (fndecl) = error_mark_node;
- DECL_ARGUMENTS (fndecl) = 0;
- }
-
- if (!nested)
- {
- /* Let the error reporting routines know that we're outside a function.
- For a nested function, this value is used in pop_c_function_context
- and then reset via pop_function_context. */
- ffecom_outer_function_decl_ = current_function_decl = NULL;
- }
-}
-
-/* Plug-in replacement for identifying the name of a decl and, for a
- function, what we call it in diagnostics. For now, "program unit"
- should suffice, since it's a bit of a hassle to figure out which
- of several kinds of things it is. Note that it could conceivably
- be a statement function, which probably isn't really a program unit
- per se, but if that comes up, it should be easy to check (being a
- nested function and all). */
-
-static const char *
-ffe_printable_name (tree decl, int v)
-{
- /* Just to keep GCC quiet about the unused variable.
- In theory, differing values of V should produce different
- output. */
- switch (v)
- {
- default:
- if (TREE_CODE (decl) == ERROR_MARK)
- return "erroneous code";
- return IDENTIFIER_POINTER (DECL_NAME (decl));
- }
-}
-
-/* g77's function to print out name of current function that caused
- an error. */
-
-static void
-ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
- const char *file)
-{
- static ffeglobal last_g = NULL;
- static ffesymbol last_s = NULL;
- ffeglobal g;
- ffesymbol s;
- const char *kind;
-
- if ((ffecom_primary_entry_ == NULL)
- || (ffesymbol_global (ffecom_primary_entry_) == NULL))
- {
- g = NULL;
- s = NULL;
- kind = NULL;
- }
- else
- {
- g = ffesymbol_global (ffecom_primary_entry_);
- if (ffecom_nested_entry_ == NULL)
- {
- s = ffecom_primary_entry_;
- kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
- }
- else
- {
- s = ffecom_nested_entry_;
- kind = _("In statement function");
- }
- }
-
- if ((last_g != g) || (last_s != s))
- {
- if (file)
- fprintf (stderr, "%s: ", file);
-
- if (s == NULL)
- fprintf (stderr, _("Outside of any program unit:\n"));
- else
- {
- const char *name = ffesymbol_text (s);
-
- fprintf (stderr, "%s `%s':\n", kind, name);
- }
-
- last_g = g;
- last_s = s;
- }
-}
-
-/* Similar to `lookup_name' but look only at current binding level. */
-
-static tree
-lookup_name_current_level (tree name)
-{
- register tree t;
-
- if (current_binding_level == global_binding_level)
- return IDENTIFIER_GLOBAL_VALUE (name);
-
- if (IDENTIFIER_LOCAL_VALUE (name) == 0)
- return 0;
-
- for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
- if (DECL_NAME (t) == name)
- break;
-
- return t;
-}
-
-/* Create a new `struct f_binding_level'. */
-
-static struct f_binding_level *
-make_binding_level (void)
-{
- /* NOSTRICT */
- return ggc_alloc (sizeof (struct f_binding_level));
-}
-
-/* Save and restore the variables in this file and elsewhere
- that keep track of the progress of compilation of the current function.
- Used for nested functions. */
-
-struct f_function
-{
- struct f_function *next;
- tree named_labels;
- tree shadowed_labels;
- struct f_binding_level *binding_level;
-};
-
-struct f_function *f_function_chain;
-
-/* Restore the variables used during compilation of a C function. */
-
-static void
-pop_f_function_context (void)
-{
- struct f_function *p = f_function_chain;
- tree link;
-
- /* Bring back all the labels that were shadowed. */
- for (link = shadowed_labels; link; link = TREE_CHAIN (link))
- if (DECL_NAME (TREE_VALUE (link)) != 0)
- IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
- = TREE_VALUE (link);
-
- if (current_function_decl != error_mark_node
- && DECL_SAVED_INSNS (current_function_decl) == 0)
- {
- /* Stop pointing to the local nodes about to be freed. */
- /* But DECL_INITIAL must remain nonzero so we know this was an actual
- function definition. */
- DECL_INITIAL (current_function_decl) = error_mark_node;
- DECL_ARGUMENTS (current_function_decl) = 0;
- }
-
- pop_function_context ();
-
- f_function_chain = p->next;
-
- named_labels = p->named_labels;
- shadowed_labels = p->shadowed_labels;
- current_binding_level = p->binding_level;
-
- free (p);
-}
-
-/* Save and reinitialize the variables
- used during compilation of a C function. */
-
-static void
-push_f_function_context (void)
-{
- struct f_function *p = xmalloc (sizeof (struct f_function));
-
- push_function_context ();
-
- p->next = f_function_chain;
- f_function_chain = p;
-
- p->named_labels = named_labels;
- p->shadowed_labels = shadowed_labels;
- p->binding_level = current_binding_level;
-}
-
-static void
-push_parm_decl (tree parm)
-{
- int old_immediate_size_expand = immediate_size_expand;
-
- /* Don't try computing parm sizes now -- wait till fn is called. */
-
- immediate_size_expand = 0;
-
- /* Fill in arg stuff. */
-
- DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
- DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
- TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
-
- parm = pushdecl (parm);
-
- immediate_size_expand = old_immediate_size_expand;
-
- finish_decl (parm, NULL_TREE, FALSE);
-}
-
-/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
-
-static tree
-pushdecl_top_level (tree x)
-{
- register tree t;
- register struct f_binding_level *b = current_binding_level;
- register tree f = current_function_decl;
-
- current_binding_level = global_binding_level;
- current_function_decl = NULL_TREE;
- t = pushdecl (x);
- current_binding_level = b;
- current_function_decl = f;
- return t;
-}
-
-/* Store the list of declarations of the current level.
- This is done for the parameter declarations of a function being defined,
- after they are modified in the light of any missing parameters. */
-
-static tree
-storedecls (tree decls)
-{
- return current_binding_level->names = decls;
-}
-
-/* Store the parameter declarations into the current function declaration.
- This is called after parsing the parameter declarations, before
- digesting the body of the function.
-
- For an old-style definition, modify the function's type
- to specify at least the number of arguments. */
-
-static void
-store_parm_decls (int is_main_program UNUSED)
-{
- register tree fndecl = current_function_decl;
-
- if (fndecl == error_mark_node)
- return;
-
- /* This is a chain of PARM_DECLs from old-style parm declarations. */
- DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
-
- /* Initialize the RTL code for the function. */
- init_function_start (fndecl);
-
- /* Set up parameters and prepare for return, for the function. */
- expand_function_start (fndecl, 0);
-}
-
-static tree
-start_decl (tree decl, bool is_top_level)
-{
- register tree tem;
- bool at_top_level = (current_binding_level == global_binding_level);
- bool top_level = is_top_level || at_top_level;
-
- /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
- level anyway. */
- assert (!is_top_level || !at_top_level);
-
- if (DECL_INITIAL (decl) != NULL_TREE)
- {
- assert (DECL_INITIAL (decl) == error_mark_node);
- assert (!DECL_EXTERNAL (decl));
- }
- else if (top_level)
- assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
-
- /* For Fortran, we by default put things in .common when possible. */
- DECL_COMMON (decl) = 1;
-
- /* Add this decl to the current binding level. TEM may equal DECL or it may
- be a previous decl of the same name. */
- if (is_top_level)
- tem = pushdecl_top_level (decl);
- else
- tem = pushdecl (decl);
-
- /* For a local variable, define the RTL now. */
- if (!top_level
- /* But not if this is a duplicate decl and we preserved the rtl from the
- previous one (which may or may not happen). */
- && !DECL_RTL_SET_P (tem))
- {
- if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
- expand_decl (tem);
- else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
- && DECL_INITIAL (tem) != 0)
- expand_decl (tem);
- }
-
- return tem;
-}
-
-/* Create the FUNCTION_DECL for a function definition.
- DECLSPECS and DECLARATOR are the parts of the declaration;
- they describe the function's name and the type it returns,
- but twisted together in a fashion that parallels the syntax of C.
-
- This function creates a binding context for the function body
- as well as setting up the FUNCTION_DECL in current_function_decl.
-
- Returns 1 on success. If the DECLARATOR is not suitable for a function
- (it defines a datum instead), we return 0, which tells
- ffe_parse_file to report a parse error.
-
- NESTED is nonzero for a function nested within another function. */
-
-static void
-start_function (tree name, tree type, int nested, int public)
-{
- tree decl1;
- tree restype;
- int old_immediate_size_expand = immediate_size_expand;
-
- named_labels = 0;
- shadowed_labels = 0;
-
- /* Don't expand any sizes in the return type of the function. */
- immediate_size_expand = 0;
-
- if (nested)
- {
- assert (!public);
- assert (current_function_decl != NULL_TREE);
- assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
- }
- else
- {
- assert (current_function_decl == NULL_TREE);
- }
-
- if (TREE_CODE (type) == ERROR_MARK)
- decl1 = current_function_decl = error_mark_node;
- else
- {
- decl1 = build_decl (FUNCTION_DECL,
- name,
- type);
- TREE_PUBLIC (decl1) = public ? 1 : 0;
- if (nested)
- DECL_INLINE (decl1) = 1;
- TREE_STATIC (decl1) = 1;
- DECL_EXTERNAL (decl1) = 0;
-
- announce_function (decl1);
-
- /* Make the init_value nonzero so pushdecl knows this is not tentative.
- error_mark_node is replaced below (in poplevel) with the BLOCK. */
- DECL_INITIAL (decl1) = error_mark_node;
-
- /* Record the decl so that the function name is defined. If we already have
- a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
-
- current_function_decl = pushdecl (decl1);
- }
-
- if (!nested)
- ffecom_outer_function_decl_ = current_function_decl;
-
- pushlevel (0);
- current_binding_level->prep_state = 2;
-
- if (TREE_CODE (current_function_decl) != ERROR_MARK)
- {
- make_decl_rtl (current_function_decl, NULL);
-
- restype = TREE_TYPE (TREE_TYPE (current_function_decl));
- DECL_RESULT (current_function_decl)
- = build_decl (RESULT_DECL, NULL_TREE, restype);
- }
-
- if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
- TREE_ADDRESSABLE (current_function_decl) = 1;
-
- immediate_size_expand = old_immediate_size_expand;
-}
-\f
-/* Here are the public functions the GNU back end needs. */
-
-tree
-convert (tree type, tree expr)
-{
- register tree e = expr;
- register enum tree_code code = TREE_CODE (type);
-
- if (type == TREE_TYPE (e)
- || TREE_CODE (e) == ERROR_MARK)
- return e;
- if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
- return fold (build1 (NOP_EXPR, type, e));
- if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
- || code == ERROR_MARK)
- return error_mark_node;
- if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
- {
- assert ("void value not ignored as it ought to be" == NULL);
- return error_mark_node;
- }
- if (code == VOID_TYPE)
- return build1 (CONVERT_EXPR, type, e);
- if ((code != RECORD_TYPE)
- && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
- e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
- e);
- if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
- return fold (convert_to_integer (type, e));
- if (code == POINTER_TYPE)
- return fold (convert_to_pointer (type, e));
- if (code == REAL_TYPE)
- return fold (convert_to_real (type, e));
- if (code == COMPLEX_TYPE)
- return fold (convert_to_complex (type, e));
- if (code == RECORD_TYPE)
- return fold (ffecom_convert_to_complex_ (type, e));
-
- assert ("conversion to non-scalar type requested" == NULL);
- return error_mark_node;
-}
-
-/* Return the list of declarations of the current level.
- Note that this list is in reverse order unless/until
- you nreverse it; and when you do nreverse it, you must
- store the result back using `storedecls' or you will lose. */
-
-tree
-getdecls (void)
-{
- return current_binding_level->names;
-}
-
-/* Nonzero if we are currently in the global binding level. */
-
-int
-global_bindings_p (void)
-{
- return current_binding_level == global_binding_level;
-}
-
-static void
-ffecom_init_decl_processing (void)
-{
- malloc_init ();
-
- ffe_init_0 ();
-}
-
-/* Delete the node BLOCK from the current binding level.
- This is used for the block inside a stmt expr ({...})
- so that the block can be reinserted where appropriate. */
-
-static void
-delete_block (tree block)
-{
- tree t;
- if (current_binding_level->blocks == block)
- current_binding_level->blocks = TREE_CHAIN (block);
- for (t = current_binding_level->blocks; t;)
- {
- if (TREE_CHAIN (t) == block)
- TREE_CHAIN (t) = TREE_CHAIN (block);
- else
- t = TREE_CHAIN (t);
- }
- TREE_CHAIN (block) = NULL;
- /* Clear TREE_USED which is always set by poplevel.
- The flag is set again if insert_block is called. */
- TREE_USED (block) = 0;
-}
-
-void
-insert_block (tree block)
-{
- TREE_USED (block) = 1;
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, block);
-}
-
-/* Each front end provides its own. */
-static bool ffe_init (void);
-static void ffe_finish (void);
-static bool ffe_post_options (const char **);
-static void ffe_print_identifier (FILE *, tree, int);
-
-struct language_function GTY(())
-{
- int unused;
-};
-
-#undef LANG_HOOKS_NAME
-#define LANG_HOOKS_NAME "GNU F77"
-#undef LANG_HOOKS_INIT
-#define LANG_HOOKS_INIT ffe_init
-#undef LANG_HOOKS_FINISH
-#define LANG_HOOKS_FINISH ffe_finish
-#undef LANG_HOOKS_INIT_OPTIONS
-#define LANG_HOOKS_INIT_OPTIONS ffe_init_options
-#undef LANG_HOOKS_HANDLE_OPTION
-#define LANG_HOOKS_HANDLE_OPTION ffe_handle_option
-#undef LANG_HOOKS_POST_OPTIONS
-#define LANG_HOOKS_POST_OPTIONS ffe_post_options
-#undef LANG_HOOKS_PARSE_FILE
-#define LANG_HOOKS_PARSE_FILE ffe_parse_file
-#undef LANG_HOOKS_MARK_ADDRESSABLE
-#define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
-#undef LANG_HOOKS_PRINT_IDENTIFIER
-#define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
-#undef LANG_HOOKS_DECL_PRINTABLE_NAME
-#define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
-#undef LANG_HOOKS_PRINT_ERROR_FUNCTION
-#define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
-#undef LANG_HOOKS_TRUTHVALUE_CONVERSION
-#define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
-
-#undef LANG_HOOKS_TYPE_FOR_MODE
-#define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
-#undef LANG_HOOKS_TYPE_FOR_SIZE
-#define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
-#undef LANG_HOOKS_SIGNED_TYPE
-#define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
-#undef LANG_HOOKS_UNSIGNED_TYPE
-#define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
-#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
-#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
-
-/* We do not wish to use alias-set based aliasing at all. Used in the
- extreme (every object with its own set, with equivalences recorded) it
- might be helpful, but there are problems when it comes to inlining. We
- get on ok with flag_argument_noalias, and alias-set aliasing does
- currently limit how stack slots can be reused, which is a lose. */
-#undef LANG_HOOKS_GET_ALIAS_SET
-#define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
-
-const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
-
-/* Table indexed by tree code giving a string containing a character
- classifying the tree code. Possibilities are
- t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
-
-#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
-
-const char tree_code_type[] = {
-#include "tree.def"
-};
-#undef DEFTREECODE
-
-/* Table indexed by tree code giving number of expression
- operands beyond the fixed part of the node structure.
- Not used for types or decls. */
-
-#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
-
-const unsigned char tree_code_length[] = {
-#include "tree.def"
-};
-#undef DEFTREECODE
-
-/* Names of tree components.
- Used for printing out the tree and error messages. */
-#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
-
-const char *const tree_code_name[] = {
-#include "tree.def"
-};
-#undef DEFTREECODE
-
-static bool
-ffe_post_options (const char **pfilename)
-{
- const char *filename = *pfilename;
-
- /* Open input file. */
- if (filename == 0 || !strcmp (filename, "-"))
- {
- finput = stdin;
- filename = "stdin";
- }
- else
- finput = fopen (filename, "r");
-
- if (finput == 0)
- fatal_error ("can't open %s: %m", filename);
-
- return false;
-}
-
-
-static bool
-ffe_init (void)
-{
-#ifdef IO_BUFFER_SIZE
- setvbuf (finput, xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
-#endif
-
- ffecom_init_decl_processing ();
-
- /* If the file is output from cpp, it should contain a first line
- `# 1 "real-filename"', and the current design of gcc (toplev.c
- in particular and the way it sets up information relied on by
- INCLUDE) requires that we read this now, and store the
- "real-filename" info in master_input_filename. Ask the lexer
- to try doing this. */
- ffelex_hash_kludge (finput);
-
- push_srcloc (input_filename, 0);
-
- /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
- set the new file name. Maybe in ffe_post_options. */
- return true;
-}
-
-static void
-ffe_finish (void)
-{
- ffe_terminate_0 ();
-
- if (ffe_is_ffedebug ())
- malloc_pool_display (malloc_pool_image ());
-
- fclose (finput);
-}
-
-static bool
-ffe_mark_addressable (tree exp)
-{
- register tree x = exp;
- while (1)
- switch (TREE_CODE (x))
- {
- case ADDR_EXPR:
- case COMPONENT_REF:
- case ARRAY_REF:
- x = TREE_OPERAND (x, 0);
- break;
-
- case CONSTRUCTOR:
- TREE_ADDRESSABLE (x) = 1;
- return true;
-
- case VAR_DECL:
- case CONST_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
- && DECL_NONLOCAL (x))
- {
- if (TREE_PUBLIC (x))
- {
- assert ("address of global register var requested" == NULL);
- return false;
- }
- assert ("address of register variable requested" == NULL);
- }
- else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
- {
- if (TREE_PUBLIC (x))
- {
- assert ("address of global register var requested" == NULL);
- return false;
- }
- assert ("address of register var requested" == NULL);
- }
- put_var_into_stack (x, /*rescan=*/true);
-
- /* drops in */
- case FUNCTION_DECL:
- TREE_ADDRESSABLE (x) = 1;
-#if 0 /* poplevel deals with this now. */
- if (DECL_CONTEXT (x) == 0)
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
-#endif
-
- default:
- return true;
- }
-}
-
-/* Exit a binding level.
- Pop the level off, and restore the state of the identifier-decl mappings
- that were in effect when this level was entered.
-
- If KEEP is nonzero, this level had explicit declarations, so
- and create a "block" (a BLOCK node) for the level
- to record its declarations and subblocks for symbol table output.
-
- If FUNCTIONBODY is nonzero, this level is the body of a function,
- so create a block as if KEEP were set and also clear out all
- label names.
-
- If REVERSE is nonzero, reverse the order of decls before putting
- them into the BLOCK. */
-
-tree
-poplevel (int keep, int reverse, int functionbody)
-{
- register tree link;
- /* The chain of decls was accumulated in reverse order.
- Put it into forward order, just for cleanliness. */
- tree decls;
- tree subblocks = current_binding_level->blocks;
- tree block = 0;
- tree decl;
- int block_previously_created;
-
- /* Get the decls in the order they were written.
- Usually current_binding_level->names is in reverse order.
- But parameter decls were previously put in forward order. */
-
- if (reverse)
- current_binding_level->names
- = decls = nreverse (current_binding_level->names);
- else
- decls = current_binding_level->names;
-
- /* Output any nested inline functions within this block
- if they weren't already output. */
-
- for (decl = decls; decl; decl = TREE_CHAIN (decl))
- if (TREE_CODE (decl) == FUNCTION_DECL
- && ! TREE_ASM_WRITTEN (decl)
- && DECL_INITIAL (decl) != 0
- && TREE_ADDRESSABLE (decl))
- {
- /* If this decl was copied from a file-scope decl
- on account of a block-scope extern decl,
- propagate TREE_ADDRESSABLE to the file-scope decl.
-
- DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
- true, since then the decl goes through save_for_inline_copying. */
- if (DECL_ABSTRACT_ORIGIN (decl) != 0
- && DECL_ABSTRACT_ORIGIN (decl) != decl)
- TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
- else if (DECL_SAVED_INSNS (decl) != 0)
- {
- push_function_context ();
- output_inline_function (decl);
- pop_function_context ();
- }
- }
-
- /* If there were any declarations or structure tags in that level,
- or if this level is a function body,
- create a BLOCK to record them for the life of this function. */
-
- block = 0;
- block_previously_created = (current_binding_level->this_block != 0);
- if (block_previously_created)
- block = current_binding_level->this_block;
- else if (keep || functionbody)
- block = make_node (BLOCK);
- if (block != 0)
- {
- BLOCK_VARS (block) = decls;
- BLOCK_SUBBLOCKS (block) = subblocks;
- }
-
- /* In each subblock, record that this is its superior. */
-
- for (link = subblocks; link; link = TREE_CHAIN (link))
- BLOCK_SUPERCONTEXT (link) = block;
-
- /* Clear out the meanings of the local variables of this level. */
-
- for (link = decls; link; link = TREE_CHAIN (link))
- {
- if (DECL_NAME (link) != 0)
- {
- /* If the ident. was used or addressed via a local extern decl,
- don't forget that fact. */
- if (DECL_EXTERNAL (link))
- {
- if (TREE_USED (link))
- TREE_USED (DECL_NAME (link)) = 1;
- if (TREE_ADDRESSABLE (link))
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
- }
- IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
- }
- }
-
- /* If the level being exited is the top level of a function,
- check over all the labels, and clear out the current
- (function local) meanings of their names. */
-
- if (functionbody)
- {
- /* If this is the top level block of a function,
- the vars are the function's parameters.
- Don't leave them in the BLOCK because they are
- found in the FUNCTION_DECL instead. */
-
- BLOCK_VARS (block) = 0;
- }
-
- /* Pop the current level, and free the structure for reuse. */
-
- {
- register struct f_binding_level *level = current_binding_level;
- current_binding_level = current_binding_level->level_chain;
-
- level->level_chain = free_binding_level;
- free_binding_level = level;
- }
-
- /* Dispose of the block that we just made inside some higher level. */
- if (functionbody
- && current_function_decl != error_mark_node)
- DECL_INITIAL (current_function_decl) = block;
- else if (block)
- {
- if (!block_previously_created)
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, block);
- }
- /* If we did not make a block for the level just exited,
- any blocks made for inner levels
- (since they cannot be recorded as subblocks in that level)
- must be carried forward so they will later become subblocks
- of something else. */
- else if (subblocks)
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, subblocks);
-
- if (block)
- TREE_USED (block) = 1;
- return block;
-}
-
-static void
-ffe_print_identifier (FILE *file, tree node, int indent)
-{
- print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
- print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
-}
-
-/* Record a decl-node X as belonging to the current lexical scope.
- Check for errors (such as an incompatible declaration for the same
- name already seen in the same scope).
-
- Returns either X or an old decl for the same name.
- If an old decl is returned, it may have been smashed
- to agree with what X says. */
-
-tree
-pushdecl (tree x)
-{
- register tree t;
- register tree name = DECL_NAME (x);
- register struct f_binding_level *b = current_binding_level;
-
- if ((TREE_CODE (x) == FUNCTION_DECL)
- && (DECL_INITIAL (x) == 0)
- && DECL_EXTERNAL (x))
- DECL_CONTEXT (x) = NULL_TREE;
- else
- DECL_CONTEXT (x) = current_function_decl;
-
- if (name)
- {
- if (IDENTIFIER_INVENTED (name))
- {
- DECL_ARTIFICIAL (x) = 1;
- DECL_IN_SYSTEM_HEADER (x) = 1;
- }
-
- t = lookup_name_current_level (name);
-
- assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
-
- /* Don't push non-parms onto list for parms until we understand
- why we're doing this and whether it works. */
-
- assert ((b == global_binding_level)
- || !ffecom_transform_only_dummies_
- || TREE_CODE (x) == PARM_DECL);
-
- if ((t != NULL_TREE) && duplicate_decls (x, t))
- return t;
-
- /* If we are processing a typedef statement, generate a whole new
- ..._TYPE node (which will be just an variant of the existing
- ..._TYPE node with identical properties) and then install the
- TYPE_DECL node generated to represent the typedef name as the
- TYPE_NAME of this brand new (duplicate) ..._TYPE node.
-
- The whole point here is to end up with a situation where each and every
- ..._TYPE node the compiler creates will be uniquely associated with
- AT MOST one node representing a typedef name. This way, even though
- the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
- (i.e. "typedef name") nodes very early on, later parts of the
- compiler can always do the reverse translation and get back the
- corresponding typedef name. For example, given:
-
- typedef struct S MY_TYPE; MY_TYPE object;
-
- Later parts of the compiler might only know that `object' was of type
- `struct S' if it were not for code just below. With this code
- however, later parts of the compiler see something like:
-
- struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
-
- And they can then deduce (from the node for type struct S') that the
- original object declaration was:
-
- MY_TYPE object;
-
- Being able to do this is important for proper support of protoize, and
- also for generating precise symbolic debugging information which
- takes full account of the programmer's (typedef) vocabulary.
-
- Obviously, we don't want to generate a duplicate ..._TYPE node if the
- TYPE_DECL node that we are now processing really represents a
- standard built-in type.
-
- Since all standard types are effectively declared at line zero in the
- source file, we can easily check to see if we are working on a
- standard type by checking the current value of lineno. */
-
- if (TREE_CODE (x) == TYPE_DECL)
- {
- if (DECL_SOURCE_LINE (x) == 0)
- {
- if (TYPE_NAME (TREE_TYPE (x)) == 0)
- TYPE_NAME (TREE_TYPE (x)) = x;
- }
- else if (TREE_TYPE (x) != error_mark_node)
- {
- tree tt = TREE_TYPE (x);
-
- tt = build_type_copy (tt);
- TYPE_NAME (tt) = x;
- TREE_TYPE (x) = tt;
- }
- }
-
- /* This name is new in its binding level. Install the new declaration
- and return it. */
- if (b == global_binding_level)
- IDENTIFIER_GLOBAL_VALUE (name) = x;
- else
- IDENTIFIER_LOCAL_VALUE (name) = x;
- }
-
- /* Put decls on list in reverse order. We will reverse them later if
- necessary. */
- TREE_CHAIN (x) = b->names;
- b->names = x;
-
- return x;
-}
-
-/* Nonzero if the current level needs to have a BLOCK made. */
-
-static int
-kept_level_p (void)
-{
- tree decl;
-
- for (decl = current_binding_level->names;
- decl;
- decl = TREE_CHAIN (decl))
- {
- if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
- || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
- /* Currently, there aren't supposed to be non-artificial names
- at other than the top block for a function -- they're
- believed to always be temps. But it's wise to check anyway. */
- return 1;
- }
- return 0;
-}
-
-/* Enter a new binding level.
- If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
- not for that of tags. */
-
-void
-pushlevel (int tag_transparent)
-{
- register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
-
- assert (! tag_transparent);
-
- if (current_binding_level == global_binding_level)
- {
- named_labels = 0;
- }
-
- /* Reuse or create a struct for this binding level. */
-
- if (free_binding_level)
- {
- newlevel = free_binding_level;
- free_binding_level = free_binding_level->level_chain;
- }
- else
- {
- newlevel = make_binding_level ();
- }
-
- /* Add this level to the front of the chain (stack) of levels that
- are active. */
-
- *newlevel = clear_binding_level;
- newlevel->level_chain = current_binding_level;
- current_binding_level = newlevel;
-}
-
-/* Set the BLOCK node for the innermost scope
- (the one we are currently in). */
-
-void
-set_block (tree block)
-{
- current_binding_level->this_block = block;
- current_binding_level->names = chainon (current_binding_level->names,
- BLOCK_VARS (block));
- current_binding_level->blocks = chainon (current_binding_level->blocks,
- BLOCK_SUBBLOCKS (block));
-}
-
-static tree
-ffe_signed_or_unsigned_type (int unsignedp, tree type)
-{
- tree type2;
-
- if (! INTEGRAL_TYPE_P (type))
- return type;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
- return (unsignedp ? long_long_unsigned_type_node
- : long_long_integer_type_node);
-
- type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
- if (type2 == NULL_TREE)
- return type;
-
- return type2;
-}
-
-static tree
-ffe_signed_type (tree type)
-{
- tree type1 = TYPE_MAIN_VARIANT (type);
- ffeinfoKindtype kt;
- tree type2;
-
- if (type1 == unsigned_char_type_node || type1 == char_type_node)
- return signed_char_type_node;
- if (type1 == unsigned_type_node)
- return integer_type_node;
- if (type1 == short_unsigned_type_node)
- return short_integer_type_node;
- if (type1 == long_unsigned_type_node)
- return long_integer_type_node;
- if (type1 == long_long_unsigned_type_node)
- return long_long_integer_type_node;
-#if 0 /* gcc/c-* files only */
- if (type1 == unsigned_intDI_type_node)
- return intDI_type_node;
- if (type1 == unsigned_intSI_type_node)
- return intSI_type_node;
- if (type1 == unsigned_intHI_type_node)
- return intHI_type_node;
- if (type1 == unsigned_intQI_type_node)
- return intQI_type_node;
-#endif
-
- type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
- if (type2 != NULL_TREE)
- return type2;
-
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
- {
- type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
-
- if (type1 == type2)
- return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
- }
-
- return type;
-}
-
-/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
- or validate its data type for an `if' or `while' statement or ?..: exp.
-
- This preparation consists of taking the ordinary
- representation of an expression expr and producing a valid tree
- boolean expression describing whether expr is nonzero. We could
- simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
- but we optimize comparisons, &&, ||, and !.
-
- The resulting type should always be `integer_type_node'. */
-
-static tree
-ffe_truthvalue_conversion (tree expr)
-{
- if (TREE_CODE (expr) == ERROR_MARK)
- return expr;
-
-#if 0 /* This appears to be wrong for C++. */
- /* These really should return error_mark_node after 2.4 is stable.
- But not all callers handle ERROR_MARK properly. */
- switch (TREE_CODE (TREE_TYPE (expr)))
- {
- case RECORD_TYPE:
- error ("struct type value used where scalar is required");
- return integer_zero_node;
-
- case UNION_TYPE:
- error ("union type value used where scalar is required");
- return integer_zero_node;
-
- case ARRAY_TYPE:
- error ("array type value used where scalar is required");
- return integer_zero_node;
-
- default:
- break;
- }
-#endif /* 0 */
-
- switch (TREE_CODE (expr))
- {
- /* It is simpler and generates better code to have only TRUTH_*_EXPR
- or comparison expressions as truth values at this level. */
-#if 0
- case COMPONENT_REF:
- /* A one-bit unsigned bit-field is already acceptable. */
- if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
- && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
- return expr;
- break;
-#endif
-
- case EQ_EXPR:
- /* It is simpler and generates better code to have only TRUTH_*_EXPR
- or comparison expressions as truth values at this level. */
-#if 0
- if (integer_zerop (TREE_OPERAND (expr, 1)))
- return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
-#endif
- case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
- case TRUTH_ANDIF_EXPR:
- case TRUTH_ORIF_EXPR:
- case TRUTH_AND_EXPR:
- case TRUTH_OR_EXPR:
- case TRUTH_XOR_EXPR:
- TREE_TYPE (expr) = integer_type_node;
- return expr;
-
- case ERROR_MARK:
- return expr;
-
- case INTEGER_CST:
- return integer_zerop (expr) ? integer_zero_node : integer_one_node;
-
- case REAL_CST:
- return real_zerop (expr) ? integer_zero_node : integer_one_node;
-
- case ADDR_EXPR:
- if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
- return build (COMPOUND_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0), integer_one_node);
- else
- return integer_one_node;
-
- case COMPLEX_EXPR:
- return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
- ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
- integer_type_node,
- ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
- ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
-
- case NEGATE_EXPR:
- case ABS_EXPR:
- case FLOAT_EXPR:
- /* These don't change whether an object is nonzero or zero. */
- return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
-
- case LROTATE_EXPR:
- case RROTATE_EXPR:
- /* These don't change whether an object is zero or nonzero, but
- we can't ignore them if their second arg has side-effects. */
- if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
- return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
- ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
- else
- return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
-
- case COND_EXPR:
- {
- /* Distribute the conversion into the arms of a COND_EXPR. */
- tree arg1 = TREE_OPERAND (expr, 1);
- tree arg2 = TREE_OPERAND (expr, 2);
- if (! VOID_TYPE_P (TREE_TYPE (arg1)))
- arg1 = ffe_truthvalue_conversion (arg1);
- if (! VOID_TYPE_P (TREE_TYPE (arg2)))
- arg2 = ffe_truthvalue_conversion (arg2);
- return fold (build (COND_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0), arg1, arg2));
- }
-
- case CONVERT_EXPR:
- /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
- since that affects how `default_conversion' will behave. */
- if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
- || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
- break;
- /* fall through... */
- case NOP_EXPR:
- /* If this is widening the argument, we can ignore it. */
- if (TYPE_PRECISION (TREE_TYPE (expr))
- >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
- return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
- break;
-
- case MINUS_EXPR:
- /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
- this case. */
- if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
- && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
- break;
- /* fall through... */
- case BIT_XOR_EXPR:
- /* This and MINUS_EXPR can be changed into a comparison of the
- two objects. */
- if (TREE_TYPE (TREE_OPERAND (expr, 0))
- == TREE_TYPE (TREE_OPERAND (expr, 1)))
- return ffecom_2 (NE_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0),
- TREE_OPERAND (expr, 1));
- return ffecom_2 (NE_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0),
- fold (build1 (NOP_EXPR,
- TREE_TYPE (TREE_OPERAND (expr, 0)),
- TREE_OPERAND (expr, 1))));
-
- case BIT_AND_EXPR:
- if (integer_onep (TREE_OPERAND (expr, 1)))
- return expr;
- break;
-
- case MODIFY_EXPR:
-#if 0 /* No such thing in Fortran. */
- if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
- warning ("suggest parentheses around assignment used as truth value");
-#endif
- break;
-
- default:
- break;
- }
-
- if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
- return (ffecom_2
- ((TREE_SIDE_EFFECTS (expr)
- ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
- integer_type_node,
- ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr)),
- ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr))));
-
- return ffecom_2 (NE_EXPR, integer_type_node,
- expr,
- convert (TREE_TYPE (expr), integer_zero_node));
-}
-
-static tree
-ffe_type_for_mode (enum machine_mode mode, int unsignedp)
-{
- int i;
- int j;
- tree t;
-
- if (mode == TYPE_MODE (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
-
- if (mode == TYPE_MODE (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
-
- if (mode == TYPE_MODE (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
-
- if (mode == TYPE_MODE (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
-
- if (mode == TYPE_MODE (long_long_integer_type_node))
- return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
-
-#if HOST_BITS_PER_WIDE_INT >= 64
- if (mode == TYPE_MODE (intTI_type_node))
- return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
-#endif
-
- if (mode == TYPE_MODE (float_type_node))
- return float_type_node;
-
- if (mode == TYPE_MODE (double_type_node))
- return double_type_node;
-
- if (mode == TYPE_MODE (long_double_type_node))
- return long_double_type_node;
-
- if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
- return build_pointer_type (char_type_node);
-
- if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
- return build_pointer_type (integer_type_node);
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
- && (mode == TYPE_MODE (t)))
- {
- if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
- return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
- else
- return t;
- }
- }
-
- return 0;
-}
-
-static tree
-ffe_type_for_size (unsigned bits, int unsignedp)
-{
- ffeinfoKindtype kt;
- tree type_node;
-
- if (bits == TYPE_PRECISION (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
-
- if (bits == TYPE_PRECISION (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
-
- if (bits == TYPE_PRECISION (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
-
- if (bits == TYPE_PRECISION (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
-
- if (bits == TYPE_PRECISION (long_long_integer_type_node))
- return (unsignedp ? long_long_unsigned_type_node
- : long_long_integer_type_node);
-
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
- {
- type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
-
- if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
- return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
- : type_node;
- }
-
- return 0;
-}
-
-static tree
-ffe_unsigned_type (tree type)
-{
- tree type1 = TYPE_MAIN_VARIANT (type);
- ffeinfoKindtype kt;
- tree type2;
-
- if (type1 == signed_char_type_node || type1 == char_type_node)
- return unsigned_char_type_node;
- if (type1 == integer_type_node)
- return unsigned_type_node;
- if (type1 == short_integer_type_node)
- return short_unsigned_type_node;
- if (type1 == long_integer_type_node)
- return long_unsigned_type_node;
- if (type1 == long_long_integer_type_node)
- return long_long_unsigned_type_node;
-#if 0 /* gcc/c-* files only */
- if (type1 == intDI_type_node)
- return unsigned_intDI_type_node;
- if (type1 == intSI_type_node)
- return unsigned_intSI_type_node;
- if (type1 == intHI_type_node)
- return unsigned_intHI_type_node;
- if (type1 == intQI_type_node)
- return unsigned_intQI_type_node;
-#endif
-
- type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
- if (type2 != NULL_TREE)
- return type2;
-
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
- {
- type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
-
- if (type1 == type2)
- return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
- }
-
- return type;
-}
-\f
-/* From gcc/cccp.c, the code to handle -I. */
-
-/* Skip leading "./" from a directory name.
- This may yield the empty string, which represents the current directory. */
-
-static const char *
-skip_redundant_dir_prefix (const char *dir)
-{
- while (dir[0] == '.' && dir[1] == '/')
- for (dir += 2; *dir == '/'; dir++)
- continue;
- if (dir[0] == '.' && !dir[1])
- dir++;
- return dir;
-}
-
-/* The file_name_map structure holds a mapping of file names for a
- particular directory. This mapping is read from the file named
- FILE_NAME_MAP_FILE in that directory. Such a file can be used to
- map filenames on a file system with severe filename restrictions,
- such as DOS. The format of the file name map file is just a series
- of lines with two tokens on each line. The first token is the name
- to map, and the second token is the actual name to use. */
-
-struct file_name_map
-{
- struct file_name_map *map_next;
- char *map_from;
- char *map_to;
-};
-
-#define FILE_NAME_MAP_FILE "header.gcc"
-
-/* Current maximum length of directory names in the search path
- for include files. (Altered as we get more of them.) */
-
-static int max_include_len = 0;
-
-struct file_name_list
- {
- struct file_name_list *next;
- const char *fname;
- /* Mapping of file names for this directory. */
- struct file_name_map *name_map;
- /* Nonzero if name_map is valid. */
- int got_name_map;
- };
-
-static struct file_name_list *include = NULL; /* First dir to search */
-static struct file_name_list *last_include = NULL; /* Last in chain */
-
-/* I/O buffer structure.
- The `fname' field is nonzero for source files and #include files
- and for the dummy text used for -D and -U.
- It is zero for rescanning results of macro expansion
- and for expanding macro arguments. */
-#define INPUT_STACK_MAX 400
-static struct file_buf {
- const char *fname;
- /* Filename specified with #line command. */
- const char *nominal_fname;
- /* Record where in the search path this file was found.
- For #include_next. */
- struct file_name_list *dir;
- ffewhereLine line;
- ffewhereColumn column;
-} instack[INPUT_STACK_MAX];
-
-static int last_error_tick = 0; /* Incremented each time we print it. */
-
-/* Current nesting level of input sources.
- `instack[indepth]' is the level currently being read. */
-static int indepth = -1;
-
-typedef struct file_buf FILE_BUF;
-
-/* Nonzero means -I- has been seen,
- so don't look for #include "foo" the source-file directory. */
-static int ignore_srcdir;
-
-#ifndef INCLUDE_LEN_FUDGE
-#define INCLUDE_LEN_FUDGE 0
-#endif
-
-static void append_include_chain (struct file_name_list *first,
- struct file_name_list *last);
-static FILE *open_include_file (char *filename,
- struct file_name_list *searchptr);
-static void print_containing_files (ffebadSeverity sev);
-static char *read_filename_string (int ch, FILE *f);
-static struct file_name_map *read_name_map (const char *dirname);
-
-/* Append a chain of `struct file_name_list's
- to the end of the main include chain.
- FIRST is the beginning of the chain to append, and LAST is the end. */
-
-static void
-append_include_chain (struct file_name_list *first,
- struct file_name_list *last)
-{
- struct file_name_list *dir;
-
- if (!first || !last)
- return;
-
- if (include == 0)
- include = first;
- else
- last_include->next = first;
-
- for (dir = first; ; dir = dir->next) {
- int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
- if (len > max_include_len)
- max_include_len = len;
- if (dir == last)
- break;
- }
-
- last->next = NULL;
- last_include = last;
-}
-
-/* Try to open include file FILENAME. SEARCHPTR is the directory
- being tried from the include file search path. This function maps
- filenames on file systems based on information read by
- read_name_map. */
-
-static FILE *
-open_include_file (char *filename, struct file_name_list *searchptr)
-{
- register struct file_name_map *map;
- register char *from;
- char *p, *dir;
-
- if (searchptr && ! searchptr->got_name_map)
- {
- searchptr->name_map = read_name_map (searchptr->fname
- ? searchptr->fname : ".");
- searchptr->got_name_map = 1;
- }
-
- /* First check the mapping for the directory we are using. */
- if (searchptr && searchptr->name_map)
- {
- from = filename;
- if (searchptr->fname)
- from += strlen (searchptr->fname) + 1;
- for (map = searchptr->name_map; map; map = map->map_next)
- {
- if (! strcmp (map->map_from, from))
- {
- /* Found a match. */
- return fopen (map->map_to, "r");
- }
- }
- }
-
- /* Try to find a mapping file for the particular directory we are
- looking in. Thus #include <sys/types.h> will look up sys/types.h
- in /usr/include/header.gcc and look up types.h in
- /usr/include/sys/header.gcc. */
- p = strrchr (filename, '/');
-#ifdef DIR_SEPARATOR
- if (! p) p = strrchr (filename, DIR_SEPARATOR);
- else {
- char *tmp = strrchr (filename, DIR_SEPARATOR);
- if (tmp != NULL && tmp > p) p = tmp;
- }
-#endif
- if (! p)
- p = filename;
- if (searchptr
- && searchptr->fname
- && strlen (searchptr->fname) == (size_t) (p - filename)
- && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
- {
- /* FILENAME is in SEARCHPTR, which we've already checked. */
- return fopen (filename, "r");
- }
-
- if (p == filename)
- {
- from = filename;
- map = read_name_map (".");
- }
- else
- {
- dir = xmalloc (p - filename + 1);
- memcpy (dir, filename, p - filename);
- dir[p - filename] = '\0';
- from = p + 1;
- map = read_name_map (dir);
- free (dir);
- }
- for (; map; map = map->map_next)
- if (! strcmp (map->map_from, from))
- return fopen (map->map_to, "r");
-
- return fopen (filename, "r");
-}
-
-/* Print the file names and line numbers of the #include
- commands which led to the current file. */
-
-static void
-print_containing_files (ffebadSeverity sev)
-{
- FILE_BUF *ip = NULL;
- int i;
- int first = 1;
- const char *str1;
- const char *str2;
-
- /* If stack of files hasn't changed since we last printed
- this info, don't repeat it. */
- if (last_error_tick == input_file_stack_tick)
- return;
-
- for (i = indepth; i >= 0; i--)
- if (instack[i].fname != NULL) {
- ip = &instack[i];
- break;
- }
-
- /* Give up if we don't find a source file. */
- if (ip == NULL)
- return;
-
- /* Find the other, outer source files. */
- for (i--; i >= 0; i--)
- if (instack[i].fname != NULL)
- {
- ip = &instack[i];
- if (first)
- {
- first = 0;
- str1 = "In file included";
- }
- else
- {
- str1 = "... ...";
- }
-
- if (i == 1)
- str2 = ":";
- else
- str2 = "";
-
- /* xgettext:no-c-format */
- ffebad_start_msg ("%A from %B at %0%C", sev);
- ffebad_here (0, ip->line, ip->column);
- ffebad_string (str1);
- ffebad_string (ip->nominal_fname);
- ffebad_string (str2);
- ffebad_finish ();
- }
-
- /* Record we have printed the status as of this time. */
- last_error_tick = input_file_stack_tick;
-}
-
-/* Read a space delimited string of unlimited length from a stdio
- file. */
-
-static char *
-read_filename_string (int ch, FILE *f)
-{
- char *alloc, *set;
- int len;
-
- len = 20;
- set = alloc = xmalloc (len + 1);
- if (! ISSPACE (ch))
- {
- *set++ = ch;
- while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
- {
- if (set - alloc == len)
- {
- len *= 2;
- alloc = xrealloc (alloc, len + 1);
- set = alloc + len / 2;
- }
- *set++ = ch;
- }
- }
- *set = '\0';
- ungetc (ch, f);
- return alloc;
-}
-
-/* Read the file name map file for DIRNAME. */
-
-static struct file_name_map *
-read_name_map (const char *dirname)
-{
- /* This structure holds a linked list of file name maps, one per
- directory. */
- struct file_name_map_list
- {
- struct file_name_map_list *map_list_next;
- char *map_list_name;
- struct file_name_map *map_list_map;
- };
- static struct file_name_map_list *map_list;
- register struct file_name_map_list *map_list_ptr;
- char *name;
- FILE *f;
- size_t dirlen;
- int separator_needed;
-
- dirname = skip_redundant_dir_prefix (dirname);
-
- for (map_list_ptr = map_list; map_list_ptr;
- map_list_ptr = map_list_ptr->map_list_next)
- if (! strcmp (map_list_ptr->map_list_name, dirname))
- return map_list_ptr->map_list_map;
-
- map_list_ptr = xmalloc (sizeof (struct file_name_map_list));
- map_list_ptr->map_list_name = xstrdup (dirname);
- map_list_ptr->map_list_map = NULL;
-
- dirlen = strlen (dirname);
- separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
- if (separator_needed)
- name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL);
- else
- name = concat (dirname, FILE_NAME_MAP_FILE, NULL);
- f = fopen (name, "r");
- free (name);
- if (!f)
- map_list_ptr->map_list_map = NULL;
- else
- {
- int ch;
-
- while ((ch = getc (f)) != EOF)
- {
- char *from, *to;
- struct file_name_map *ptr;
-
- if (ISSPACE (ch))
- continue;
- from = read_filename_string (ch, f);
- while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
- ;
- to = read_filename_string (ch, f);
-
- ptr = xmalloc (sizeof (struct file_name_map));
- ptr->map_from = from;
-
- /* Make the real filename absolute. */
- if (*to == '/')
- ptr->map_to = to;
- else
- {
- if (separator_needed)
- ptr->map_to = concat (dirname, "/", to, NULL);
- else
- ptr->map_to = concat (dirname, to, NULL);
- free (to);
- }
-
- ptr->map_next = map_list_ptr->map_list_map;
- map_list_ptr->map_list_map = ptr;
-
- while ((ch = getc (f)) != '\n')
- if (ch == EOF)
- break;
- }
- fclose (f);
- }
-
- map_list_ptr->map_list_next = map_list;
- map_list = map_list_ptr;
-
- return map_list_ptr->map_list_map;
-}
-
-static void
-ffecom_file_ (const char *name)
-{
- FILE_BUF *fp;
-
- /* Do partial setup of input buffer for the sake of generating
- early #line directives (when -g is in effect). */
-
- fp = &instack[++indepth];
- memset (fp, 0, sizeof (FILE_BUF));
- if (name == NULL)
- name = "";
- fp->nominal_fname = fp->fname = name;
-}
-
-static void
-ffecom_close_include_ (FILE *f)
-{
- fclose (f);
-
- indepth--;
- input_file_stack_tick++;
-
- ffewhere_line_kill (instack[indepth].line);
- ffewhere_column_kill (instack[indepth].column);
-}
-
-void
-ffecom_decode_include_option (const char *dir)
-{
- if (! ignore_srcdir && !strcmp (dir, "-"))
- ignore_srcdir = 1;
- else
- {
- struct file_name_list *dirtmp
- = xmalloc (sizeof (struct file_name_list));
- dirtmp->next = 0; /* New one goes on the end */
- dirtmp->fname = dir;
- dirtmp->got_name_map = 0;
- append_include_chain (dirtmp, dirtmp);
- }
-}
-
-/* Open INCLUDEd file. */
-
-static FILE *
-ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
-{
- char *fbeg = name;
- size_t flen = strlen (fbeg);
- struct file_name_list *search_start = include; /* Chain of dirs to search */
- struct file_name_list dsp[1]; /* First in chain, if #include "..." */
- struct file_name_list *searchptr = 0;
- char *fname; /* Dynamically allocated fname buffer */
- FILE *f;
- FILE_BUF *fp;
-
- if (flen == 0)
- return NULL;
-
- dsp[0].fname = NULL;
-
- /* If -I- was specified, don't search current dir, only spec'd ones. */
- if (!ignore_srcdir)
- {
- for (fp = &instack[indepth]; fp >= instack; fp--)
- {
- int n;
- char *ep;
- const char *nam;
-
- if ((nam = fp->nominal_fname) != NULL)
- {
- /* Found a named file. Figure out dir of the file,
- and put it in front of the search list. */
- dsp[0].next = search_start;
- search_start = dsp;
-#ifndef VMS
- ep = strrchr (nam, '/');
-#ifdef DIR_SEPARATOR
- if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
- else {
- char *tmp = strrchr (nam, DIR_SEPARATOR);
- if (tmp != NULL && tmp > ep) ep = tmp;
- }
-#endif
-#else /* VMS */
- ep = strrchr (nam, ']');
- if (ep == NULL) ep = strrchr (nam, '>');
- if (ep == NULL) ep = strrchr (nam, ':');
- if (ep != NULL) ep++;
-#endif /* VMS */
- if (ep != NULL)
- {
- n = ep - nam;
- fname = xmalloc (n + 1);
- strncpy (fname, nam, n);
- fname[n] = '\0';
- dsp[0].fname = fname;
- if (n + INCLUDE_LEN_FUDGE > max_include_len)
- max_include_len = n + INCLUDE_LEN_FUDGE;
- }
- else
- dsp[0].fname = NULL; /* Current directory */
- dsp[0].got_name_map = 0;
- break;
- }
- }
- }
-
- /* Allocate this permanently, because it gets stored in the definitions
- of macros. */
- fname = xmalloc (max_include_len + flen + 4);
- /* + 2 above for slash and terminating null. */
- /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
- for g77 yet). */
-
- /* If specified file name is absolute, just open it. */
-
- if (*fbeg == '/'
-#ifdef DIR_SEPARATOR
- || *fbeg == DIR_SEPARATOR
-#endif
- )
- {
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
- f = open_include_file (fname, NULL);
- }
- else
- {
- f = NULL;
-
- /* Search directory path, trying to open the file.
- Copy each filename tried into FNAME. */
-
- for (searchptr = search_start; searchptr; searchptr = searchptr->next)
- {
- if (searchptr->fname)
- {
- /* The empty string in a search path is ignored.
- This makes it possible to turn off entirely
- a standard piece of the list. */
- if (searchptr->fname[0] == 0)
- continue;
- strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
- if (fname[0] && fname[strlen (fname) - 1] != '/')
- strcat (fname, "/");
- fname[strlen (fname) + flen] = 0;
- }
- else
- fname[0] = 0;
-
- strncat (fname, fbeg, flen);
-#ifdef VMS
- /* Change this 1/2 Unix 1/2 VMS file specification into a
- full VMS file specification */
- if (searchptr->fname && (searchptr->fname[0] != 0))
- {
- /* Fix up the filename */
- hack_vms_include_specification (fname);
- }
- else
- {
- /* This is a normal VMS filespec, so use it unchanged. */
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
-#if 0 /* Not for g77. */
- /* if it's '#include filename', add the missing .h */
- if (strchr (fname, '.') == NULL)
- strcat (fname, ".h");
-#endif
- }
-#endif /* VMS */
- f = open_include_file (fname, searchptr);
-#ifdef EACCES
- if (f == NULL && errno == EACCES)
- {
- print_containing_files (FFEBAD_severityWARNING);
- /* xgettext:no-c-format */
- ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
- FFEBAD_severityWARNING);
- ffebad_string (fname);
- ffebad_here (0, l, c);
- ffebad_finish ();
- }
-#endif
- if (f != NULL)
- break;
- }
- }
-
- if (f == NULL)
- {
- /* A file that was not found. */
-
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
- print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
- ffebad_start (FFEBAD_OPEN_INCLUDE);
- ffebad_here (0, l, c);
- ffebad_string (fname);
- ffebad_finish ();
- }
-
- if (dsp[0].fname != NULL)
- free ((char *) dsp[0].fname);
-
- if (f == NULL)
- return NULL;
-
- if (indepth >= (INPUT_STACK_MAX - 1))
- {
- print_containing_files (FFEBAD_severityFATAL);
- /* xgettext:no-c-format */
- ffebad_start_msg ("At %0, INCLUDE nesting too deep",
- FFEBAD_severityFATAL);
- ffebad_string (fname);
- ffebad_here (0, l, c);
- ffebad_finish ();
- return NULL;
- }
-
- instack[indepth].line = ffewhere_line_use (l);
- instack[indepth].column = ffewhere_column_use (c);
-
- fp = &instack[indepth + 1];
- memset (fp, 0, sizeof (FILE_BUF));
- fp->nominal_fname = fp->fname = fname;
- fp->dir = searchptr;
-
- indepth++;
- input_file_stack_tick++;
-
- return f;
-}
-
-/**INDENT* (Do not reformat this comment even with -fca option.)
- Data-gathering files: Given the source file listed below, compiled with
- f2c I obtained the output file listed after that, and from the output
- file I derived the above code.
-
--------- (begin input file to f2c)
- implicit none
- character*10 A1,A2
- complex C1,C2
- integer I1,I2
- real R1,R2
- double precision D1,D2
-C
- call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
-c /
- call fooI(I1/I2)
- call fooR(R1/I1)
- call fooD(D1/I1)
- call fooC(C1/I1)
- call fooR(R1/R2)
- call fooD(R1/D1)
- call fooD(D1/D2)
- call fooD(D1/R1)
- call fooC(C1/C2)
- call fooC(C1/R1)
- call fooZ(C1/D1)
-c **
- call fooI(I1**I2)
- call fooR(R1**I1)
- call fooD(D1**I1)
- call fooC(C1**I1)
- call fooR(R1**R2)
- call fooD(R1**D1)
- call fooD(D1**D2)
- call fooD(D1**R1)
- call fooC(C1**C2)
- call fooC(C1**R1)
- call fooZ(C1**D1)
-c FFEINTRIN_impABS
- call fooR(ABS(R1))
-c FFEINTRIN_impACOS
- call fooR(ACOS(R1))
-c FFEINTRIN_impAIMAG
- call fooR(AIMAG(C1))
-c FFEINTRIN_impAINT
- call fooR(AINT(R1))
-c FFEINTRIN_impALOG
- call fooR(ALOG(R1))
-c FFEINTRIN_impALOG10
- call fooR(ALOG10(R1))
-c FFEINTRIN_impAMAX0
- call fooR(AMAX0(I1,I2))
-c FFEINTRIN_impAMAX1
- call fooR(AMAX1(R1,R2))
-c FFEINTRIN_impAMIN0
- call fooR(AMIN0(I1,I2))
-c FFEINTRIN_impAMIN1
- call fooR(AMIN1(R1,R2))
-c FFEINTRIN_impAMOD
- call fooR(AMOD(R1,R2))
-c FFEINTRIN_impANINT
- call fooR(ANINT(R1))
-c FFEINTRIN_impASIN
- call fooR(ASIN(R1))
-c FFEINTRIN_impATAN
- call fooR(ATAN(R1))
-c FFEINTRIN_impATAN2
- call fooR(ATAN2(R1,R2))
-c FFEINTRIN_impCABS
- call fooR(CABS(C1))
-c FFEINTRIN_impCCOS
- call fooC(CCOS(C1))
-c FFEINTRIN_impCEXP
- call fooC(CEXP(C1))
-c FFEINTRIN_impCHAR
- call fooA(CHAR(I1))
-c FFEINTRIN_impCLOG
- call fooC(CLOG(C1))
-c FFEINTRIN_impCONJG
- call fooC(CONJG(C1))
-c FFEINTRIN_impCOS
- call fooR(COS(R1))
-c FFEINTRIN_impCOSH
- call fooR(COSH(R1))
-c FFEINTRIN_impCSIN
- call fooC(CSIN(C1))
-c FFEINTRIN_impCSQRT
- call fooC(CSQRT(C1))
-c FFEINTRIN_impDABS
- call fooD(DABS(D1))
-c FFEINTRIN_impDACOS
- call fooD(DACOS(D1))
-c FFEINTRIN_impDASIN
- call fooD(DASIN(D1))
-c FFEINTRIN_impDATAN
- call fooD(DATAN(D1))
-c FFEINTRIN_impDATAN2
- call fooD(DATAN2(D1,D2))
-c FFEINTRIN_impDCOS
- call fooD(DCOS(D1))
-c FFEINTRIN_impDCOSH
- call fooD(DCOSH(D1))
-c FFEINTRIN_impDDIM
- call fooD(DDIM(D1,D2))
-c FFEINTRIN_impDEXP
- call fooD(DEXP(D1))
-c FFEINTRIN_impDIM
- call fooR(DIM(R1,R2))
-c FFEINTRIN_impDINT
- call fooD(DINT(D1))
-c FFEINTRIN_impDLOG
- call fooD(DLOG(D1))
-c FFEINTRIN_impDLOG10
- call fooD(DLOG10(D1))
-c FFEINTRIN_impDMAX1
- call fooD(DMAX1(D1,D2))
-c FFEINTRIN_impDMIN1
- call fooD(DMIN1(D1,D2))
-c FFEINTRIN_impDMOD
- call fooD(DMOD(D1,D2))
-c FFEINTRIN_impDNINT
- call fooD(DNINT(D1))
-c FFEINTRIN_impDPROD
- call fooD(DPROD(R1,R2))
-c FFEINTRIN_impDSIGN
- call fooD(DSIGN(D1,D2))
-c FFEINTRIN_impDSIN
- call fooD(DSIN(D1))
-c FFEINTRIN_impDSINH
- call fooD(DSINH(D1))
-c FFEINTRIN_impDSQRT
- call fooD(DSQRT(D1))
-c FFEINTRIN_impDTAN
- call fooD(DTAN(D1))
-c FFEINTRIN_impDTANH
- call fooD(DTANH(D1))
-c FFEINTRIN_impEXP
- call fooR(EXP(R1))
-c FFEINTRIN_impIABS
- call fooI(IABS(I1))
-c FFEINTRIN_impICHAR
- call fooI(ICHAR(A1))
-c FFEINTRIN_impIDIM
- call fooI(IDIM(I1,I2))
-c FFEINTRIN_impIDNINT
- call fooI(IDNINT(D1))
-c FFEINTRIN_impINDEX
- call fooI(INDEX(A1,A2))
-c FFEINTRIN_impISIGN
- call fooI(ISIGN(I1,I2))
-c FFEINTRIN_impLEN
- call fooI(LEN(A1))
-c FFEINTRIN_impLGE
- call fooL(LGE(A1,A2))
-c FFEINTRIN_impLGT
- call fooL(LGT(A1,A2))
-c FFEINTRIN_impLLE
- call fooL(LLE(A1,A2))
-c FFEINTRIN_impLLT
- call fooL(LLT(A1,A2))
-c FFEINTRIN_impMAX0
- call fooI(MAX0(I1,I2))
-c FFEINTRIN_impMAX1
- call fooI(MAX1(R1,R2))
-c FFEINTRIN_impMIN0
- call fooI(MIN0(I1,I2))
-c FFEINTRIN_impMIN1
- call fooI(MIN1(R1,R2))
-c FFEINTRIN_impMOD
- call fooI(MOD(I1,I2))
-c FFEINTRIN_impNINT
- call fooI(NINT(R1))
-c FFEINTRIN_impSIGN
- call fooR(SIGN(R1,R2))
-c FFEINTRIN_impSIN
- call fooR(SIN(R1))
-c FFEINTRIN_impSINH
- call fooR(SINH(R1))
-c FFEINTRIN_impSQRT
- call fooR(SQRT(R1))
-c FFEINTRIN_impTAN
- call fooR(TAN(R1))
-c FFEINTRIN_impTANH
- call fooR(TANH(R1))
-c FFEINTRIN_imp_CMPLX_C
- call fooC(cmplx(C1,C2))
-c FFEINTRIN_imp_CMPLX_D
- call fooZ(cmplx(D1,D2))
-c FFEINTRIN_imp_CMPLX_I
- call fooC(cmplx(I1,I2))
-c FFEINTRIN_imp_CMPLX_R
- call fooC(cmplx(R1,R2))
-c FFEINTRIN_imp_DBLE_C
- call fooD(dble(C1))
-c FFEINTRIN_imp_DBLE_D
- call fooD(dble(D1))
-c FFEINTRIN_imp_DBLE_I
- call fooD(dble(I1))
-c FFEINTRIN_imp_DBLE_R
- call fooD(dble(R1))
-c FFEINTRIN_imp_INT_C
- call fooI(int(C1))
-c FFEINTRIN_imp_INT_D
- call fooI(int(D1))
-c FFEINTRIN_imp_INT_I
- call fooI(int(I1))
-c FFEINTRIN_imp_INT_R
- call fooI(int(R1))
-c FFEINTRIN_imp_REAL_C
- call fooR(real(C1))
-c FFEINTRIN_imp_REAL_D
- call fooR(real(D1))
-c FFEINTRIN_imp_REAL_I
- call fooR(real(I1))
-c FFEINTRIN_imp_REAL_R
- call fooR(real(R1))
-c
-c FFEINTRIN_imp_INT_D:
-c
-c FFEINTRIN_specIDINT
- call fooI(IDINT(D1))
-c
-c FFEINTRIN_imp_INT_R:
-c
-c FFEINTRIN_specIFIX
- call fooI(IFIX(R1))
-c FFEINTRIN_specINT
- call fooI(INT(R1))
-c
-c FFEINTRIN_imp_REAL_D:
-c
-c FFEINTRIN_specSNGL
- call fooR(SNGL(D1))
-c
-c FFEINTRIN_imp_REAL_I:
-c
-c FFEINTRIN_specFLOAT
- call fooR(FLOAT(I1))
-c FFEINTRIN_specREAL
- call fooR(REAL(I1))
-c
- end
--------- (end input file to f2c)
-
--------- (begin output from providing above input file as input to:
--------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
--------- -e "s:^#.*$::g"')
-
-// -- translated by f2c (version 19950223).
- You must link the resulting object file with the libraries:
- -lf2c -lm (in that order)
-//
-
-
-// f2c.h -- Standard Fortran to C header file //
-
-/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
-
- - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
-
-
-
-
-// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
-// we assume short, float are OK //
-typedef long int // long int // integer;
-typedef char *address;
-typedef short int shortint;
-typedef float real;
-typedef double doublereal;
-typedef struct { real r, i; } complex;
-typedef struct { doublereal r, i; } doublecomplex;
-typedef long int // long int // logical;
-typedef short int shortlogical;
-typedef char logical1;
-typedef char integer1;
-// typedef long long longint; // // system-dependent //
-
-
-
-
-// Extern is for use with -E //
-
-
-
-
-// I/O stuff //
-
-
-
-
-
-
-
-
-typedef long int // int or long int // flag;
-typedef long int // int or long int // ftnlen;
-typedef long int // int or long int // ftnint;
-
-
-//external read, write//
-typedef struct
-{ flag cierr;
- ftnint ciunit;
- flag ciend;
- char *cifmt;
- ftnint cirec;
-} cilist;
-
-//internal read, write//
-typedef struct
-{ flag icierr;
- char *iciunit;
- flag iciend;
- char *icifmt;
- ftnint icirlen;
- ftnint icirnum;
-} icilist;
-
-//open//
-typedef struct
-{ flag oerr;
- ftnint ounit;
- char *ofnm;
- ftnlen ofnmlen;
- char *osta;
- char *oacc;
- char *ofm;
- ftnint orl;
- char *oblnk;
-} olist;
-
-//close//
-typedef struct
-{ flag cerr;
- ftnint cunit;
- char *csta;
-} cllist;
-
-//rewind, backspace, endfile//
-typedef struct
-{ flag aerr;
- ftnint aunit;
-} alist;
-
-// inquire //
-typedef struct
-{ flag inerr;
- ftnint inunit;
- char *infile;
- ftnlen infilen;
- ftnint *inex; //parameters in standard's order//
- ftnint *inopen;
- ftnint *innum;
- ftnint *innamed;
- char *inname;
- ftnlen innamlen;
- char *inacc;
- ftnlen inacclen;
- char *inseq;
- ftnlen inseqlen;
- char *indir;
- ftnlen indirlen;
- char *infmt;
- ftnlen infmtlen;
- char *inform;
- ftnint informlen;
- char *inunf;
- ftnlen inunflen;
- ftnint *inrecl;
- ftnint *innrec;
- char *inblank;
- ftnlen inblanklen;
-} inlist;
-
-
-
-union Multitype { // for multiple entry points //
- integer1 g;
- shortint h;
- integer i;
- // longint j; //
- real r;
- doublereal d;
- complex c;
- doublecomplex z;
- };
-
-typedef union Multitype Multitype;
-
-typedef long Long; // No longer used; formerly in Namelist //
-
-struct Vardesc { // for Namelist //
- char *name;
- char *addr;
- ftnlen *dims;
- int type;
- };
-typedef struct Vardesc Vardesc;
-
-struct Namelist {
- char *name;
- Vardesc **vars;
- int nvars;
- };
-typedef struct Namelist Namelist;
-
-
-
-
-
-
-
-
-// procedure parameter types for -A and -C++ //
-
-
-
-
-typedef int // Unknown procedure type // (*U_fp)();
-typedef shortint (*J_fp)();
-typedef integer (*I_fp)();
-typedef real (*R_fp)();
-typedef doublereal (*D_fp)(), (*E_fp)();
-typedef // Complex // void (*C_fp)();
-typedef // Double Complex // void (*Z_fp)();
-typedef logical (*L_fp)();
-typedef shortlogical (*K_fp)();
-typedef // Character // void (*H_fp)();
-typedef // Subroutine // int (*S_fp)();
-
-// E_fp is for real functions when -R is not specified //
-typedef void C_f; // complex function //
-typedef void H_f; // character function //
-typedef void Z_f; // double complex function //
-typedef doublereal E_f; // real function with -R not specified //
-
-// undef any lower-case symbols that your C compiler predefines, e.g.: //
-
-
-// (No such symbols should be defined in a strict ANSI C compiler.
- We can avoid trouble with f2c-translated code by using
- gcc -ansi.) //
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-// Main program // MAIN__()
-{
- // System generated locals //
- integer i__1;
- real r__1, r__2;
- doublereal d__1, d__2;
- complex q__1;
- doublecomplex z__1, z__2, z__3;
- logical L__1;
- char ch__1[1];
-
- // Builtin functions //
- void c_div();
- integer pow_ii();
- double pow_ri(), pow_di();
- void pow_ci();
- double pow_dd();
- void pow_zz();
- double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
- asin(), atan(), atan2(), c_abs();
- void c_cos(), c_exp(), c_log(), r_cnjg();
- double cos(), cosh();
- void c_sin(), c_sqrt();
- double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
- d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
- integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
- logical l_ge(), l_gt(), l_le(), l_lt();
- integer i_nint();
- double r_sign();
-
- // Local variables //
- extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
- fool_(), fooz_(), getem_();
- static char a1[10], a2[10];
- static complex c1, c2;
- static doublereal d1, d2;
- static integer i1, i2;
- static real r1, r2;
-
-
- getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
-// / //
- i__1 = i1 / i2;
- fooi_(&i__1);
- r__1 = r1 / i1;
- foor_(&r__1);
- d__1 = d1 / i1;
- food_(&d__1);
- d__1 = (doublereal) i1;
- q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
- fooc_(&q__1);
- r__1 = r1 / r2;
- foor_(&r__1);
- d__1 = r1 / d1;
- food_(&d__1);
- d__1 = d1 / d2;
- food_(&d__1);
- d__1 = d1 / r1;
- food_(&d__1);
- c_div(&q__1, &c1, &c2);
- fooc_(&q__1);
- q__1.r = c1.r / r1, q__1.i = c1.i / r1;
- fooc_(&q__1);
- z__1.r = c1.r / d1, z__1.i = c1.i / d1;
- fooz_(&z__1);
-// ** //
- i__1 = pow_ii(&i1, &i2);
- fooi_(&i__1);
- r__1 = pow_ri(&r1, &i1);
- foor_(&r__1);
- d__1 = pow_di(&d1, &i1);
- food_(&d__1);
- pow_ci(&q__1, &c1, &i1);
- fooc_(&q__1);
- d__1 = (doublereal) r1;
- d__2 = (doublereal) r2;
- r__1 = pow_dd(&d__1, &d__2);
- foor_(&r__1);
- d__2 = (doublereal) r1;
- d__1 = pow_dd(&d__2, &d1);
- food_(&d__1);
- d__1 = pow_dd(&d1, &d2);
- food_(&d__1);
- d__2 = (doublereal) r1;
- d__1 = pow_dd(&d1, &d__2);
- food_(&d__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = c2.r, z__3.i = c2.i;
- pow_zz(&z__1, &z__2, &z__3);
- q__1.r = z__1.r, q__1.i = z__1.i;
- fooc_(&q__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = r1, z__3.i = 0.;
- pow_zz(&z__1, &z__2, &z__3);
- q__1.r = z__1.r, q__1.i = z__1.i;
- fooc_(&q__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = d1, z__3.i = 0.;
- pow_zz(&z__1, &z__2, &z__3);
- fooz_(&z__1);
-// FFEINTRIN_impABS //
- r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
- foor_(&r__1);
-// FFEINTRIN_impACOS //
- r__1 = acos(r1);
- foor_(&r__1);
-// FFEINTRIN_impAIMAG //
- r__1 = r_imag(&c1);
- foor_(&r__1);
-// FFEINTRIN_impAINT //
- r__1 = r_int(&r1);
- foor_(&r__1);
-// FFEINTRIN_impALOG //
- r__1 = log(r1);
- foor_(&r__1);
-// FFEINTRIN_impALOG10 //
- r__1 = r_lg10(&r1);
- foor_(&r__1);
-// FFEINTRIN_impAMAX0 //
- r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMAX1 //
- r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMIN0 //
- r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMIN1 //
- r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMOD //
- r__1 = r_mod(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impANINT //
- r__1 = r_nint(&r1);
- foor_(&r__1);
-// FFEINTRIN_impASIN //
- r__1 = asin(r1);
- foor_(&r__1);
-// FFEINTRIN_impATAN //
- r__1 = atan(r1);
- foor_(&r__1);
-// FFEINTRIN_impATAN2 //
- r__1 = atan2(r1, r2);
- foor_(&r__1);
-// FFEINTRIN_impCABS //
- r__1 = c_abs(&c1);
- foor_(&r__1);
-// FFEINTRIN_impCCOS //
- c_cos(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCEXP //
- c_exp(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCHAR //
- *(unsigned char *)&ch__1[0] = i1;
- fooa_(ch__1, 1L);
-// FFEINTRIN_impCLOG //
- c_log(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCONJG //
- r_cnjg(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCOS //
- r__1 = cos(r1);
- foor_(&r__1);
-// FFEINTRIN_impCOSH //
- r__1 = cosh(r1);
- foor_(&r__1);
-// FFEINTRIN_impCSIN //
- c_sin(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCSQRT //
- c_sqrt(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impDABS //
- d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
- food_(&d__1);
-// FFEINTRIN_impDACOS //
- d__1 = acos(d1);
- food_(&d__1);
-// FFEINTRIN_impDASIN //
- d__1 = asin(d1);
- food_(&d__1);
-// FFEINTRIN_impDATAN //
- d__1 = atan(d1);
- food_(&d__1);
-// FFEINTRIN_impDATAN2 //
- d__1 = atan2(d1, d2);
- food_(&d__1);
-// FFEINTRIN_impDCOS //
- d__1 = cos(d1);
- food_(&d__1);
-// FFEINTRIN_impDCOSH //
- d__1 = cosh(d1);
- food_(&d__1);
-// FFEINTRIN_impDDIM //
- d__1 = d_dim(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDEXP //
- d__1 = exp(d1);
- food_(&d__1);
-// FFEINTRIN_impDIM //
- r__1 = r_dim(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impDINT //
- d__1 = d_int(&d1);
- food_(&d__1);
-// FFEINTRIN_impDLOG //
- d__1 = log(d1);
- food_(&d__1);
-// FFEINTRIN_impDLOG10 //
- d__1 = d_lg10(&d1);
- food_(&d__1);
-// FFEINTRIN_impDMAX1 //
- d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
- food_(&d__1);
-// FFEINTRIN_impDMIN1 //
- d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
- food_(&d__1);
-// FFEINTRIN_impDMOD //
- d__1 = d_mod(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDNINT //
- d__1 = d_nint(&d1);
- food_(&d__1);
-// FFEINTRIN_impDPROD //
- d__1 = (doublereal) r1 * r2;
- food_(&d__1);
-// FFEINTRIN_impDSIGN //
- d__1 = d_sign(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDSIN //
- d__1 = sin(d1);
- food_(&d__1);
-// FFEINTRIN_impDSINH //
- d__1 = sinh(d1);
- food_(&d__1);
-// FFEINTRIN_impDSQRT //
- d__1 = sqrt(d1);
- food_(&d__1);
-// FFEINTRIN_impDTAN //
- d__1 = tan(d1);
- food_(&d__1);
-// FFEINTRIN_impDTANH //
- d__1 = tanh(d1);
- food_(&d__1);
-// FFEINTRIN_impEXP //
- r__1 = exp(r1);
- foor_(&r__1);
-// FFEINTRIN_impIABS //
- i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impICHAR //
- i__1 = *(unsigned char *)a1;
- fooi_(&i__1);
-// FFEINTRIN_impIDIM //
- i__1 = i_dim(&i1, &i2);
- fooi_(&i__1);
-// FFEINTRIN_impIDNINT //
- i__1 = i_dnnt(&d1);
- fooi_(&i__1);
-// FFEINTRIN_impINDEX //
- i__1 = i_indx(a1, a2, 10L, 10L);
- fooi_(&i__1);
-// FFEINTRIN_impISIGN //
- i__1 = i_sign(&i1, &i2);
- fooi_(&i__1);
-// FFEINTRIN_impLEN //
- i__1 = i_len(a1, 10L);
- fooi_(&i__1);
-// FFEINTRIN_impLGE //
- L__1 = l_ge(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLGT //
- L__1 = l_gt(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLLE //
- L__1 = l_le(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLLT //
- L__1 = l_lt(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impMAX0 //
- i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMAX1 //
- i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMIN0 //
- i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMIN1 //
- i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMOD //
- i__1 = i1 % i2;
- fooi_(&i__1);
-// FFEINTRIN_impNINT //
- i__1 = i_nint(&r1);
- fooi_(&i__1);
-// FFEINTRIN_impSIGN //
- r__1 = r_sign(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impSIN //
- r__1 = sin(r1);
- foor_(&r__1);
-// FFEINTRIN_impSINH //
- r__1 = sinh(r1);
- foor_(&r__1);
-// FFEINTRIN_impSQRT //
- r__1 = sqrt(r1);
- foor_(&r__1);
-// FFEINTRIN_impTAN //
- r__1 = tan(r1);
- foor_(&r__1);
-// FFEINTRIN_impTANH //
- r__1 = tanh(r1);
- foor_(&r__1);
-// FFEINTRIN_imp_CMPLX_C //
- r__1 = c1.r;
- r__2 = c2.r;
- q__1.r = r__1, q__1.i = r__2;
- fooc_(&q__1);
-// FFEINTRIN_imp_CMPLX_D //
- z__1.r = d1, z__1.i = d2;
- fooz_(&z__1);
-// FFEINTRIN_imp_CMPLX_I //
- r__1 = (real) i1;
- r__2 = (real) i2;
- q__1.r = r__1, q__1.i = r__2;
- fooc_(&q__1);
-// FFEINTRIN_imp_CMPLX_R //
- q__1.r = r1, q__1.i = r2;
- fooc_(&q__1);
-// FFEINTRIN_imp_DBLE_C //
- d__1 = (doublereal) c1.r;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_D //
- d__1 = d1;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_I //
- d__1 = (doublereal) i1;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_R //
- d__1 = (doublereal) r1;
- food_(&d__1);
-// FFEINTRIN_imp_INT_C //
- i__1 = (integer) c1.r;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_D //
- i__1 = (integer) d1;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_I //
- i__1 = i1;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_R //
- i__1 = (integer) r1;
- fooi_(&i__1);
-// FFEINTRIN_imp_REAL_C //
- r__1 = c1.r;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_D //
- r__1 = (real) d1;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_I //
- r__1 = (real) i1;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_R //
- r__1 = r1;
- foor_(&r__1);
-
-// FFEINTRIN_imp_INT_D: //
-
-// FFEINTRIN_specIDINT //
- i__1 = (integer) d1;
- fooi_(&i__1);
-
-// FFEINTRIN_imp_INT_R: //
-
-// FFEINTRIN_specIFIX //
- i__1 = (integer) r1;
- fooi_(&i__1);
-// FFEINTRIN_specINT //
- i__1 = (integer) r1;
- fooi_(&i__1);
-
-// FFEINTRIN_imp_REAL_D: //
-
-// FFEINTRIN_specSNGL //
- r__1 = (real) d1;
- foor_(&r__1);
-
-// FFEINTRIN_imp_REAL_I: //
-
-// FFEINTRIN_specFLOAT //
- r__1 = (real) i1;
- foor_(&r__1);
-// FFEINTRIN_specREAL //
- r__1 = (real) i1;
- foor_(&r__1);
-
-} // MAIN__ //
-
--------- (end output file from f2c)
-
-*/
-
-#include "gt-f-com.h"
-#include "gtype-f.h"
+++ /dev/null
-/* com.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 1996, 1997, 2000, 2003, 2004
- Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- com.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_COM_H
-#define GCC_F_COM_H
-
-/* Simple definitions and enumerations. */
-
-#define FFECOM_dimensionsMAX 7 /* Max # dimensions (quick hack). */
-
-#define FFECOM_SIZE_UNIT "byte" /* Singular form. */
-#define FFECOM_SIZE_UNITS "bytes" /* Plural form. */
-
-#define FFECOM_constantNULL NULL_TREE
-#define FFECOM_nonterNULL NULL_TREE
-#define FFECOM_globalNULL NULL_TREE
-#define FFECOM_labelNULL NULL_TREE
-#define FFECOM_storageNULL NULL_TREE
-#define FFECOM_symbolNULL ffecom_symbol_null_
-
-/* Shorthand for types used in f2c.h and that g77 perhaps allows some
- flexibility regarding in the section below. I.e. the actual numbers
- below aren't important, as long as they're unique. */
-
-#define FFECOM_f2ccodeCHAR 1
-#define FFECOM_f2ccodeSHORT 2
-#define FFECOM_f2ccodeINT 3
-#define FFECOM_f2ccodeLONG 4
-#define FFECOM_f2ccodeLONGLONG 5
-#define FFECOM_f2ccodeCHARPTR 6 /* char * */
-#define FFECOM_f2ccodeFLOAT 7
-#define FFECOM_f2ccodeDOUBLE 8
-#define FFECOM_f2ccodeLONGDOUBLE 9
-#define FFECOM_f2ccodeTWOREALS 10
-#define FFECOM_f2ccodeTWODOUBLEREALS 11
-
-#if FFECOM_DETERMINE_TYPES /* only for com.c and configure */
-
-/* Begin f2c.h information. This must match the info in the f2c.h used
- to build the libf2c with which g77-generated code is linked, or there
- will probably be bugs, some of them difficult to detect or even trigger. */
-
-/* The C front-end provides __g77_integer and __g77_uinteger types so that
- the appropriately-sized signed and unsigned integer types are available
- for libf2c. If you change this, also the definitions of those types
- in ../c-decl.c. */
-#define FFECOM_f2cINTEGER \
- (LONG_TYPE_SIZE == FLOAT_TYPE_SIZE \
- ? FFECOM_f2ccodeLONG \
- : (INT_TYPE_SIZE == FLOAT_TYPE_SIZE \
- ? FFECOM_f2ccodeINT \
- : (abort (), -1)))
-
-#define FFECOM_f2cLOGICAL FFECOM_f2cINTEGER
-
-/* The C front-end provides __g77_longint and __g77_ulongint types so that
- the appropriately-sized signed and unsigned integer types are available
- for libf2c. If you change this, also the definitions of those types
- in ../c-decl.c. */
-#define FFECOM_f2cLONGINT \
- (LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2) \
- ? FFECOM_f2ccodeLONG \
- : (LONG_LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2) \
- ? FFECOM_f2ccodeLONGLONG \
- : (abort (), -1)))
-
-#define FFECOM_f2cADDRESS FFECOM_f2ccodeCHARPTR
-#define FFECOM_f2cSHORTINT FFECOM_f2ccodeSHORT
-#define FFECOM_f2cREAL FFECOM_f2ccodeFLOAT
-#define FFECOM_f2cDOUBLEREAL FFECOM_f2ccodeDOUBLE
-#define FFECOM_f2cCOMPLEX FFECOM_f2ccodeTWOREALS
-#define FFECOM_f2cDOUBLECOMPLEX FFECOM_f2ccodeTWODOUBLEREALS
-#define FFECOM_f2cSHORTLOGICAL FFECOM_f2ccodeSHORT
-#define FFECOM_f2cLOGICAL1 FFECOM_f2ccodeCHAR
-#define FFECOM_f2cINTEGER1 FFECOM_f2ccodeCHAR
-
-/* These must be f2c's INTEGER type, to match runtime/f2c.h.in. */
-
-#define FFECOM_f2cFLAG FFECOM_f2cINTEGER
-#define FFECOM_f2cFTNINT FFECOM_f2cINTEGER
-#define FFECOM_f2cFTNLEN FFECOM_f2cINTEGER
-
-#endif /* #if FFECOM_DETERMINE_TYPES */
-
-/* Everything else in f2c.h, specifically the structures used in
- interfacing compiled code with the library, must remain exactly
- as delivered, or g77 internals (mostly com.c and ste.c) must
- be modified accordingly to compensate. Or there will be...trouble. */
-
-typedef enum
- {
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CODE,
-#include "com-rt.def"
-#undef DEFGFRT
- FFECOM_gfrt
- } ffecomGfrt;
-
-/* Typedefs. */
-
-#ifndef TREE_CODE
-#include "tree.h"
-#endif
-
-typedef tree ffecomConstant;
-typedef tree ffecomNonter;
-typedef tree ffecomLabel;
-typedef tree ffecomGlobal;
-typedef tree ffecomStorage;
-typedef struct _ffecom_symbol_ ffecomSymbol;
-
-struct _ffecom_symbol_
- {
- tree decl_tree;
- tree length_tree; /* For CHARACTER dummies. */
- tree vardesc_tree; /* For NAMELIST. */
- tree assign_tree; /* For ASSIGN'ed vars. */
- bool addr; /* Is address of item instead of item. */
- };
-
-/* Include files needed by this one. */
-
-#include "bld.h"
-#include "info.h"
-#include "lab.h"
-#include "storag.h"
-#include "symbol.h"
-
-extern int global_bindings_p (void);
-extern tree getdecls (void);
-extern void pushlevel (int);
-extern tree poplevel (int,int, int);
-extern void insert_block (tree);
-extern void set_block (tree);
-extern tree pushdecl (tree);
-
-/* Global objects accessed by users of this module. */
-
-extern GTY(()) tree string_type_node;
-extern GTY(()) tree ffecom_integer_type_node;
-extern GTY(()) tree ffecom_integer_zero_node;
-extern GTY(()) tree ffecom_integer_one_node;
-extern GTY(()) tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
-extern ffecomSymbol ffecom_symbol_null_;
-extern ffeinfoKindtype ffecom_pointer_kind_;
-extern ffeinfoKindtype ffecom_label_kind_;
-
-extern int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
-extern GTY(()) tree ffecom_f2c_integer_type_node;
-extern GTY(()) tree ffecom_f2c_address_type_node;
-extern GTY(()) tree ffecom_f2c_real_type_node;
-extern GTY(()) tree ffecom_f2c_doublereal_type_node;
-extern GTY(()) tree ffecom_f2c_complex_type_node;
-extern GTY(()) tree ffecom_f2c_doublecomplex_type_node;
-extern GTY(()) tree ffecom_f2c_longint_type_node;
-extern GTY(()) tree ffecom_f2c_logical_type_node;
-extern GTY(()) tree ffecom_f2c_flag_type_node;
-extern GTY(()) tree ffecom_f2c_ftnlen_type_node;
-extern GTY(()) tree ffecom_f2c_ftnlen_zero_node;
-extern GTY(()) tree ffecom_f2c_ftnlen_one_node;
-extern GTY(()) tree ffecom_f2c_ftnlen_two_node;
-extern GTY(()) tree ffecom_f2c_ptr_to_ftnlen_type_node;
-extern GTY(()) tree ffecom_f2c_ftnint_type_node;
-extern GTY(()) tree ffecom_f2c_ptr_to_ftnint_type_node;
-
-/* Declare functions with prototypes. */
-
-tree ffecom_1 (enum tree_code code, tree type, tree node);
-tree ffecom_1_fn (tree node);
-tree ffecom_2 (enum tree_code code, tree type, tree node1, tree node2);
-bool ffecom_2pass_advise_entrypoint (ffesymbol entry);
-void ffecom_2pass_do_entrypoint (ffesymbol entry);
-tree ffecom_2s (enum tree_code code, tree type, tree node1, tree node2);
-tree ffecom_3 (enum tree_code code, tree type, tree node1, tree node2,
- tree node3);
-tree ffecom_3s (enum tree_code code, tree type, tree node1, tree node2,
- tree node3);
-tree ffecom_arg_expr (ffebld expr, tree *length);
-tree ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length);
-tree ffecom_arg_ptr_to_expr (ffebld expr, tree *length);
-tree ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook);
-tree ffecom_constantunion_with_type (ffebldConstantUnion *cu,
- tree tree_type,ffebldConst ct);
-tree ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
- ffeinfoKindtype kt, tree tree_type);
-tree ffecom_const_expr (ffebld expr);
-tree ffecom_decl_field (tree context, tree prevfield, const char *name,
- tree type);
-void ffecom_close_include (FILE *f);
-void ffecom_decode_include_option (const char *dir);
-tree ffecom_end_compstmt (void);
-void ffecom_end_transition (void);
-void ffecom_exec_transition (void);
-void ffecom_expand_let_stmt (ffebld dest, ffebld source);
-tree ffecom_expr (ffebld expr);
-tree ffecom_expr_assign (ffebld expr);
-tree ffecom_expr_assign_w (ffebld expr);
-tree ffecom_expr_rw (tree type, ffebld expr);
-tree ffecom_expr_w (tree type, ffebld expr);
-void ffecom_finish_compile (void);
-void ffecom_finish_decl (tree decl, tree init, bool is_top_level);
-void ffecom_finish_progunit (void);
-tree ffecom_get_invented_identifier (const char *pattern, ...)
- ATTRIBUTE_PRINTF_1;
-ffeinfoBasictype ffecom_gfrt_basictype (ffecomGfrt ix);
-ffeinfoKindtype ffecom_gfrt_kindtype (ffecomGfrt ix);
-void ffecom_init_0 (void);
-void ffecom_init_2 (void);
-tree ffecom_list_expr (ffebld list);
-tree ffecom_list_ptr_to_expr (ffebld list);
-tree ffecom_lookup_label (ffelab label);
-tree ffecom_make_tempvar (const char *commentary, tree type,
- ffetargetCharacterSize size, int elements);
-tree ffecom_modify (tree newtype, tree lhs, tree rhs);
-void ffecom_save_tree_forever (tree t);
-void ffecom_file (const char *name);
-void ffecom_notify_init_storage (ffestorag st);
-void ffecom_notify_init_symbol (ffesymbol s);
-void ffecom_notify_primary_entry (ffesymbol fn);
-FILE *ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c);
-void ffecom_prepare_arg_ptr_to_expr (ffebld expr);
-bool ffecom_prepare_end (void);
-void ffecom_prepare_expr_ (ffebld expr, ffebld dest);
-void ffecom_prepare_expr_rw (tree type, ffebld expr);
-void ffecom_prepare_expr_w (tree type, ffebld expr);
-void ffecom_prepare_ptr_to_expr (ffebld expr);
-void ffecom_prepare_return_expr (ffebld expr);
-tree ffecom_ptr_to_const_expr (ffebld expr);
-tree ffecom_ptr_to_expr (ffebld expr);
-tree ffecom_return_expr (ffebld expr);
-tree ffecom_save_tree (tree t);
-void ffecom_start_compstmt (void);
-tree ffecom_start_decl (tree decl, bool is_init);
-void ffecom_sym_commit (ffesymbol s);
-ffesymbol ffecom_sym_end_transition (ffesymbol s);
-ffesymbol ffecom_sym_exec_transition (ffesymbol s);
-ffesymbol ffecom_sym_learned (ffesymbol s);
-void ffecom_sym_retract (ffesymbol s);
-tree ffecom_temp_label (void);
-tree ffecom_truth_value (tree expr);
-tree ffecom_truth_value_invert (tree expr);
-tree ffecom_type_expr (ffebld expr);
-tree ffecom_which_entrypoint_decl (void);
-void ffe_parse_file (int);
-
-/* Define macros. */
-
-#define ffecom_f2c_typecode(bt,kt) ffecom_f2c_typecode_[(bt)][(kt)]
-#define ffecom_label_kind() ffecom_label_kind_
-#define ffecom_pointer_kind() ffecom_pointer_kind_
-#define ffecom_prepare_expr(e) ffecom_prepare_expr_ ((e), NULL)
-
-#define ffecom_init_1()
-#define ffecom_init_3()
-#define ffecom_init_4()
-#define ffecom_terminate_0()
-#define ffecom_terminate_1()
-#define ffecom_terminate_2()
-#define ffecom_terminate_3()
-#define ffecom_terminate_4()
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_COM_H */
+++ /dev/null
-# Top level configure fragment for GNU FORTRAN.
-# Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002 Free Software Foundation, Inc.
-
-#This file is part of GNU Fortran.
-
-#GNU Fortran is free software; you can redistribute it and/or modify
-#it under the terms of the GNU General Public License as published by
-#the Free Software Foundation; either version 2, or (at your option)
-#any later version.
-
-#GNU Fortran is distributed in the hope that it will be useful,
-#but WITHOUT ANY WARRANTY; without even the implied warranty of
-#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-#GNU General Public License for more details.
-
-#You should have received a copy of the GNU General Public License
-#along with GNU Fortran; see the file COPYING. If not, write to
-#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-#02111-1307, USA.
-
-# Configure looks for the existence of this file to auto-config each language.
-# We define several parameters used by configure:
-#
-# language - name of language as it would appear in $(LANGUAGES)
-# compilers - value to add to $(COMPILERS)
-# stagestuff - files to add to $(STAGESTUFF)
-
-language="f77"
-
-compilers="f771\$(exeext)"
-
-stagestuff="g77\$(exeext) g77-cross\$(exeext) f771\$(exeext)"
-
-target_libs=target-libf2c
-
-gtfiles="\$(srcdir)/f/com.c \$(srcdir)/f/com.h \$(srcdir)/f/ste.c \$(srcdir)/f/where.h \$(srcdir)/f/where.c \$(srcdir)/f/lex.c"
+++ /dev/null
-/* data.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 2002, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
-
- Description:
- Do the tough things for DATA statement (and INTEGER FOO/.../-style
- initializations), like implied-DO and suchlike.
-
- Modifications:
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "data.h"
-#include "bit.h"
-#include "bld.h"
-#include "com.h"
-#include "expr.h"
-#include "global.h"
-#include "malloc.h"
-#include "st.h"
-#include "storag.h"
-#include "top.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-/* I picked this value as one that, when plugged into a couple of small
- but nearly identical test cases I have called BIG-0.f and BIG-1.f,
- causes BIG-1.f to take about 10 times as long (elapsed) to compile
- (in f771 only) as BIG-0.f. These test cases differ in that BIG-0.f
- doesn't put the one initialized variable in a common area that has
- a large uninitialized array in it, while BIG-1.f does. The size of
- the array is this many elements, as long as they all are INTEGER
- type. Note that, as of 0.5.18, sparse cases are better handled,
- so BIG-2.f now is used; it provides nonzero initial
- values for all elements of the same array BIG-0 has. */
-#ifndef FFEDATA_sizeTOO_BIG_INIT_
-#define FFEDATA_sizeTOO_BIG_INIT_ 75*1024
-#endif
-
-/* Internal typedefs. */
-
-typedef struct _ffedata_convert_cache_ *ffedataConvertCache_;
-typedef struct _ffedata_impdo_ *ffedataImpdo_;
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-struct _ffedata_convert_cache_
- {
- ffebld converted; /* Results of converting expr to following
- type. */
- ffeinfoBasictype basic_type;
- ffeinfoKindtype kind_type;
- ffetargetCharacterSize size;
- ffeinfoRank rank;
- };
-
-struct _ffedata_impdo_
- {
- ffedataImpdo_ outer; /* Enclosing IMPDO construct. */
- ffebld outer_list; /* Item after my IMPDO on the outer list. */
- ffebld my_list; /* Beginning of list in my IMPDO. */
- ffesymbol itervar; /* Iteration variable. */
- ffetargetIntegerDefault increment;
- ffetargetIntegerDefault final;
- };
-
-/* Static objects accessed by functions in this module. */
-
-static ffedataImpdo_ ffedata_stack_ = NULL;
-static ffebld ffedata_list_ = NULL;
-static bool ffedata_reinit_; /* value_ should report REINIT error. */
-static bool ffedata_reported_error_; /* Error has been reported. */
-static ffesymbol ffedata_symbol_ = NULL; /* Symbol being initialized. */
-static ffeinfoBasictype ffedata_basictype_; /* Info on symbol. */
-static ffeinfoKindtype ffedata_kindtype_;
-static ffestorag ffedata_storage_; /* If non-NULL, inits go into this parent. */
-static ffeinfoBasictype ffedata_storage_bt_; /* Info on storage. */
-static ffeinfoKindtype ffedata_storage_kt_;
-static ffetargetOffset ffedata_storage_size_; /* Size of entire storage. */
-static ffetargetAlign ffedata_storage_units_; /* #units per storage unit. */
-static ffetargetOffset ffedata_arraysize_; /* Size of array being
- inited. */
-static ffetargetOffset ffedata_expected_; /* Number of elements to
- init. */
-static ffetargetOffset ffedata_number_; /* #elements inited so far. */
-static ffetargetOffset ffedata_offset_; /* Offset of next element. */
-static ffetargetOffset ffedata_symbolsize_; /* Size of entire sym. */
-static ffetargetCharacterSize ffedata_size_; /* Size of an element. */
-static ffetargetCharacterSize ffedata_charexpected_; /* #char to init. */
-static ffetargetCharacterSize ffedata_charnumber_; /* #chars inited. */
-static ffetargetCharacterSize ffedata_charoffset_; /* Offset of next char. */
-static ffedataConvertCache_ ffedata_convert_cache_; /* Fewer conversions. */
-static int ffedata_convert_cache_max_ = 0; /* #entries available. */
-static int ffedata_convert_cache_use_ = 0; /* #entries in use. */
-
-/* Static functions (internal). */
-
-static bool ffedata_advance_ (void);
-static ffebld ffedata_convert_ (ffebld source, ffelexToken source_token,
- ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt,
- ffeinfoRank rk, ffetargetCharacterSize sz);
-static ffetargetInteger1 ffedata_eval_integer1_ (ffebld expr);
-static ffetargetOffset ffedata_eval_offset_ (ffebld subscripts,
- ffebld dims);
-static ffetargetCharacterSize ffedata_eval_substr_begin_ (ffebld expr);
-static ffetargetCharacterSize ffedata_eval_substr_end_ (ffebld expr,
- ffetargetCharacterSize min, ffetargetCharacterSize max);
-static void ffedata_gather_ (ffestorag mst, ffestorag st);
-static void ffedata_pop_ (void);
-static void ffedata_push_ (void);
-static bool ffedata_value_ (ffebld value, ffelexToken token);
-
-/* Internal macros. */
-\f
-
-/* ffedata_begin -- Initialize with list of targets
-
- ffebld list;
- ffedata_begin(list); // ITEM... list of SYMTERs, ARRAYs, SUBSTRs, ...
-
- Remember the list. After this call, 0...n calls to ffedata_value must
- follow, and then a single call to ffedata_end. */
-
-void
-ffedata_begin (ffebld list)
-{
- assert (ffedata_list_ == NULL);
- ffedata_list_ = list;
- ffedata_symbol_ = NULL;
- ffedata_reported_error_ = FALSE;
- ffedata_reinit_ = FALSE;
- ffedata_advance_ ();
-}
-
-/* ffedata_end -- End of initialization sequence
-
- if (ffedata_end(FALSE))
- // everything's ok
-
- Make sure the end of the list is valid here. */
-
-bool
-ffedata_end (bool reported_error, ffelexToken t)
-{
- reported_error |= ffedata_reported_error_;
-
- /* If still targets to initialize, too few initializers, so complain. */
-
- if ((ffedata_symbol_ != NULL) && !reported_error)
- {
- reported_error = TRUE;
- ffebad_start (FFEBAD_DATA_TOOFEW);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- }
-
- /* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */
-
- while (ffedata_stack_ != NULL)
- ffedata_pop_ ();
-
- if (ffedata_list_ != NULL)
- {
- assert (reported_error);
- ffedata_list_ = NULL;
- }
-
- return TRUE;
-}
-
-/* ffedata_gather -- Gather previously disparate initializations into one place
-
- ffestorag st; // A typeCBLOCK or typeLOCAL aggregate.
- ffedata_gather(st);
-
- Prior to this call, st has no init or accretion info, but (presumably
- at least one of) its subordinate storage areas has init or accretion
- info. After this call, none of the subordinate storage areas has inits,
- because they've all been moved into the newly created init/accretion
- info for st. During this call, conflicting inits produce only one
- error message. */
-
-void
-ffedata_gather (ffestorag st)
-{
- ffesymbol s;
- ffebld b;
-
- /* Prepare info on the storage area we're putting init info into. */
-
- ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
- &ffedata_storage_units_, ffestorag_basictype (st),
- ffestorag_kindtype (st));
- ffedata_storage_size_ = ffestorag_size (st) / ffedata_storage_units_;
- assert (ffestorag_size (st) % ffedata_storage_units_ == 0);
-
- /* If a CBLOCK, gather all the init info for its explicit members. */
-
- if ((ffestorag_type (st) == FFESTORAG_typeCBLOCK)
- && (ffestorag_symbol (st) != NULL))
- {
- s = ffestorag_symbol (st);
- for (b = ffesymbol_commonlist (s); b != NULL; b = ffebld_trail (b))
- ffedata_gather_ (st,
- ffesymbol_storage (ffebld_symter (ffebld_head (b))));
- }
-
- /* For CBLOCK or LOCAL, gather all the init info for equivalenced members. */
-
- ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st);
-}
-
-/* ffedata_value -- Provide some number of initial values
-
- ffebld value;
- ffelexToken t; // Points to the value.
- if (ffedata_value(1,value,t))
- // Everything's ok
-
- Makes sure the value is ok, then remembers it according to the list
- provided to ffedata_begin. As many instances of the value may be
- supplied as desired, as indicated by the first argument. */
-
-bool
-ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token)
-{
- ffetargetIntegerDefault i;
-
- /* Maybe ignore zero values, to speed up compiling, even though we lose
- checking for multiple initializations for now. */
-
- if (!ffe_is_zeros ()
- && (value != NULL)
- && (ffebld_op (value) == FFEBLD_opCONTER)
- && ffebld_constant_is_zero (ffebld_conter (value)))
- value = NULL;
- else if ((value != NULL)
- && (ffebld_op (value) == FFEBLD_opANY))
- value = NULL;
- else
- {
- /* Must be a constant. */
- assert (value != NULL);
- assert (ffebld_op (value) == FFEBLD_opCONTER);
- }
-
- /* Later we can optimize certain cases by seeing that the target array can
- take some number of values, and provide this number to _value_. */
-
- if (rpt == 1)
- ffedata_convert_cache_use_ = -1; /* Don't bother caching. */
- else
- ffedata_convert_cache_use_ = 0; /* Maybe use the cache. */
-
- for (i = 0; i < rpt; ++i)
- {
- if ((ffedata_symbol_ != NULL)
- && !ffesymbol_is_init (ffedata_symbol_))
- {
- ffesymbol_signal_change (ffedata_symbol_);
- ffesymbol_update_init (ffedata_symbol_);
- if (1 || ffe_is_90 ())
- ffesymbol_update_save (ffedata_symbol_);
-#if FFEGLOBAL_ENABLED
- if (ffesymbol_common (ffedata_symbol_) != NULL)
- ffeglobal_init_common (ffesymbol_common (ffedata_symbol_),
- token);
-#endif
- ffesymbol_signal_unreported (ffedata_symbol_);
- }
- if (!ffedata_value_ (value, token))
- return FALSE;
- }
-
- return TRUE;
-}
-
-/* ffedata_advance_ -- Advance initialization target to next item in list
-
- if (ffedata_advance_())
- // everything's ok
-
- Sets common info to characterize the next item in the list. Handles
- IMPDO constructs accordingly. Does not handle advances within a single
- item, as in the common extension "DATA CHARTYPE/33,34,35/", where
- CHARTYPE is CHARACTER*3, for example. */
-
-static bool
-ffedata_advance_ (void)
-{
- ffebld next;
-
- /* Come here after handling an IMPDO. */
-
-tail_recurse: /* :::::::::::::::::::: */
-
- /* Assume we're not going to find a new target for now. */
-
- ffedata_symbol_ = NULL;
-
- /* If at the end of the list, we're done. */
-
- if (ffedata_list_ == NULL)
- {
- ffetargetIntegerDefault newval;
-
- if (ffedata_stack_ == NULL)
- return TRUE; /* No IMPDO in progress, we is done! */
-
- /* Iterate the IMPDO. */
-
- newval = ffesymbol_value (ffedata_stack_->itervar)
- + ffedata_stack_->increment;
-
- /* See if we're still in the loop. */
-
- if (((ffedata_stack_->increment > 0)
- ? newval > ffedata_stack_->final
- : newval < ffedata_stack_->final)
- || (((ffesymbol_value (ffedata_stack_->itervar) < 0)
- == (ffedata_stack_->increment < 0))
- && ((ffesymbol_value (ffedata_stack_->itervar) < 0)
- != (newval < 0)))) /* Overflow/underflow? */
- { /* Done with the loop. */
- ffedata_list_ = ffedata_stack_->outer_list; /* Restore list. */
- ffedata_pop_ (); /* Pop me off the impdo stack. */
- }
- else
- { /* Still in the loop, reset the list and
- update the iter var. */
- ffedata_list_ = ffedata_stack_->my_list; /* Reset list. */
- ffesymbol_set_value (ffedata_stack_->itervar, newval);
- }
- goto tail_recurse; /* :::::::::::::::::::: */
- }
-
- /* Move to the next item in the list. */
-
- next = ffebld_head (ffedata_list_);
- ffedata_list_ = ffebld_trail (ffedata_list_);
-
- /* Really shouldn't happen. */
-
- if (next == NULL)
- return TRUE;
-
- /* See what kind of target this is. */
-
- switch (ffebld_op (next))
- {
- case FFEBLD_opSYMTER: /* Simple reference to scalar or array. */
- ffedata_symbol_ = ffebld_symter (next);
- ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
- : ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
- if (ffedata_storage_ != NULL)
- {
- ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
- &ffedata_storage_units_,
- ffestorag_basictype (ffedata_storage_),
- ffestorag_kindtype (ffedata_storage_));
- ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
- / ffedata_storage_units_;
- assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
- }
-
- if ((ffesymbol_init (ffedata_symbol_) != NULL)
- || (ffesymbol_accretion (ffedata_symbol_) != NULL)
- || ((ffedata_storage_ != NULL)
- && (ffestorag_init (ffedata_storage_) != NULL)))
- {
-#if 0
- ffebad_start (FFEBAD_DATA_REINIT);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
-#else
- ffedata_reinit_ = TRUE;
- return TRUE;
-#endif
- }
- ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
- ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
- if (ffesymbol_rank (ffedata_symbol_) == 0)
- ffedata_arraysize_ = 1;
- else
- {
- ffebld size = ffesymbol_arraysize (ffedata_symbol_);
-
- assert (size != NULL);
- assert (ffebld_op (size) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (size))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (size))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
- (size));
- }
- ffedata_expected_ = ffedata_arraysize_;
- ffedata_number_ = 0;
- ffedata_offset_ = 0;
- ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
- ? ffesymbol_size (ffedata_symbol_) : 1;
- ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
- ffedata_charexpected_ = ffedata_size_;
- ffedata_charnumber_ = 0;
- ffedata_charoffset_ = 0;
- break;
-
- case FFEBLD_opARRAYREF: /* Reference to element of array. */
- ffedata_symbol_ = ffebld_symter (ffebld_left (next));
- ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
- : ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
- if (ffedata_storage_ != NULL)
- {
- ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
- &ffedata_storage_units_,
- ffestorag_basictype (ffedata_storage_),
- ffestorag_kindtype (ffedata_storage_));
- ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
- / ffedata_storage_units_;
- assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
- }
-
- if ((ffesymbol_init (ffedata_symbol_) != NULL)
- || ((ffedata_storage_ != NULL)
- && (ffestorag_init (ffedata_storage_) != NULL)))
- {
-#if 0
- ffebad_start (FFEBAD_DATA_REINIT);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
-#else
- ffedata_reinit_ = TRUE;
- return TRUE;
-#endif
- }
- ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
- ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
- if (ffesymbol_rank (ffedata_symbol_) == 0)
- ffedata_arraysize_ = 1; /* Shouldn't happen in this case... */
- else
- {
- ffebld size = ffesymbol_arraysize (ffedata_symbol_);
-
- assert (size != NULL);
- assert (ffebld_op (size) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (size))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (size))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
- (size));
- }
- ffedata_expected_ = 1;
- ffedata_number_ = 0;
- ffedata_offset_ = ffedata_eval_offset_ (ffebld_right (next),
- ffesymbol_dims (ffedata_symbol_));
- ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
- ? ffesymbol_size (ffedata_symbol_) : 1;
- ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
- ffedata_charexpected_ = ffedata_size_;
- ffedata_charnumber_ = 0;
- ffedata_charoffset_ = 0;
- break;
-
- case FFEBLD_opSUBSTR: /* Substring reference to scalar or array
- element. */
- {
- bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF;
- ffebld colon = ffebld_right (next);
-
- assert (colon != NULL);
-
- ffedata_symbol_ = ffebld_symter (ffebld_left (arrayref
- ? ffebld_left (next) : next));
- ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
- : ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
- if (ffedata_storage_ != NULL)
- {
- ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
- &ffedata_storage_units_,
- ffestorag_basictype (ffedata_storage_),
- ffestorag_kindtype (ffedata_storage_));
- ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
- / ffedata_storage_units_;
- assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
- }
-
- if ((ffesymbol_init (ffedata_symbol_) != NULL)
- || ((ffedata_storage_ != NULL)
- && (ffestorag_init (ffedata_storage_) != NULL)))
- {
-#if 0
- ffebad_start (FFEBAD_DATA_REINIT);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
-#else
- ffedata_reinit_ = TRUE;
- return TRUE;
-#endif
- }
- ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
- ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
- if (ffesymbol_rank (ffedata_symbol_) == 0)
- ffedata_arraysize_ = 1;
- else
- {
- ffebld size = ffesymbol_arraysize (ffedata_symbol_);
-
- assert (size != NULL);
- assert (ffebld_op (size) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (size))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (size))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
- (size));
- }
- ffedata_expected_ = arrayref ? 1 : ffedata_arraysize_;
- ffedata_number_ = 0;
- ffedata_offset_ = arrayref ? ffedata_eval_offset_ (ffebld_right
- (ffebld_left (next)), ffesymbol_dims (ffedata_symbol_)) : 0;
- ffedata_size_ = ffesymbol_size (ffedata_symbol_);
- ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
- ffedata_charnumber_ = 0;
- ffedata_charoffset_ = ffedata_eval_substr_begin_ (ffebld_head (colon));
- ffedata_charexpected_ = ffedata_eval_substr_end_ (ffebld_head
- (ffebld_trail (colon)), ffedata_charoffset_,
- ffedata_size_) - ffedata_charoffset_ + 1;
- }
- break;
-
- case FFEBLD_opIMPDO: /* Implied-DO construct. */
- {
- ffebld itervar;
- ffebld start;
- ffebld end;
- ffebld incr;
- ffebld item = ffebld_right (next);
-
- itervar = ffebld_head (item);
- item = ffebld_trail (item);
- start = ffebld_head (item);
- item = ffebld_trail (item);
- end = ffebld_head (item);
- item = ffebld_trail (item);
- incr = ffebld_head (item);
-
- ffedata_push_ ();
- ffedata_stack_->outer_list = ffedata_list_;
- ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next);
-
- assert (ffeinfo_basictype (ffebld_info (itervar))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (itervar))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- ffedata_stack_->itervar = ffebld_symter (itervar);
- if (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
- {
- ffebad_start (FFEBAD_DATA_EVAL);
- ffest_ffebad_here_current_stmt (0);
- ffebad_finish ();
- ffedata_pop_ ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
- assert (ffeinfo_basictype (ffebld_info (start))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (start))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start));
- if (ffeinfo_basictype (ffebld_info (end)) != FFEINFO_basictypeINTEGER)
- {
- ffebad_start (FFEBAD_DATA_EVAL);
- ffest_ffebad_here_current_stmt (0);
- ffebad_finish ();
- ffedata_pop_ ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
- assert (ffeinfo_basictype (ffebld_info (end))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (end))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- ffedata_stack_->final = ffedata_eval_integer1_ (end);
-
- if (incr == NULL)
- ffedata_stack_->increment = 1;
- else
- {
- if (ffeinfo_basictype (ffebld_info (incr)) != FFEINFO_basictypeINTEGER)
- {
- ffebad_start (FFEBAD_DATA_EVAL);
- ffest_ffebad_here_current_stmt (0);
- ffebad_finish ();
- ffedata_pop_ ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
- assert (ffeinfo_basictype (ffebld_info (incr))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (incr))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- ffedata_stack_->increment = ffedata_eval_integer1_ (incr);
- if (ffedata_stack_->increment == 0)
- {
- ffebad_start (FFEBAD_DATA_ZERO);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
- ffebad_finish ();
- ffedata_pop_ ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
- }
-
- if ((ffedata_stack_->increment > 0)
- ? ffesymbol_value (ffedata_stack_->itervar)
- > ffedata_stack_->final
- : ffesymbol_value (ffedata_stack_->itervar)
- < ffedata_stack_->final)
- {
- ffedata_reported_error_ = TRUE;
- ffebad_start (FFEBAD_DATA_EMPTY);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
- ffebad_finish ();
- ffedata_pop_ ();
- return FALSE;
- }
- }
- goto tail_recurse; /* :::::::::::::::::::: */
-
- case FFEBLD_opANY:
- ffedata_reported_error_ = TRUE;
- return FALSE;
-
- default:
- assert ("bad op" == NULL);
- break;
- }
-
- return TRUE;
-}
-
-/* ffedata_convert_ -- Convert source expression to given type using cache
-
- ffebld source;
- ffelexToken source_token;
- ffelexToken dest_token; // Any appropriate token for "destination".
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharactersize sz;
- source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);
-
- Like ffeexpr_convert, but calls it only if necessary (if the converted
- expression doesn't already exist in the cache) and then puts the result
- in the cache. */
-
-static ffebld
-ffedata_convert_ (ffebld source, ffelexToken source_token,
- ffelexToken dest_token, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffeinfoRank rk,
- ffetargetCharacterSize sz)
-{
- ffebld converted;
- int i;
- int max;
- ffedataConvertCache_ cache;
-
- for (i = 0; i < ffedata_convert_cache_use_; ++i)
- if ((bt == ffedata_convert_cache_[i].basic_type)
- && (kt == ffedata_convert_cache_[i].kind_type)
- && (sz == ffedata_convert_cache_[i].size)
- && (rk == ffedata_convert_cache_[i].rank))
- return ffedata_convert_cache_[i].converted;
-
- converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk,
- sz, FFEEXPR_contextDATA);
-
- if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_)
- {
- if (ffedata_convert_cache_max_ == 0)
- max = 4;
- else
- max = ffedata_convert_cache_max_ << 1;
-
- if (max > ffedata_convert_cache_max_)
- {
- cache = malloc_new_ks (malloc_pool_image (),
- "FFEDATA cache", max * sizeof (*cache));
- if (ffedata_convert_cache_max_ != 0)
- {
- memcpy (cache, ffedata_convert_cache_,
- ffedata_convert_cache_max_ * sizeof (*cache));
- malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_,
- ffedata_convert_cache_max_ * sizeof (*cache));
- }
- ffedata_convert_cache_ = cache;
- ffedata_convert_cache_max_ = max;
- }
- else
- return converted; /* In case int overflows! */
- }
-
- i = ffedata_convert_cache_use_++;
-
- ffedata_convert_cache_[i].converted = converted;
- ffedata_convert_cache_[i].basic_type = bt;
- ffedata_convert_cache_[i].kind_type = kt;
- ffedata_convert_cache_[i].size = sz;
- ffedata_convert_cache_[i].rank = rk;
-
- return converted;
-}
-
-/* ffedata_eval_integer1_ -- Evaluate expression
-
- ffetargetIntegerDefault result;
- ffebld expr; // must be kindtypeINTEGER1.
-
- result = ffedata_eval_integer1_(expr);
-
- Evalues the expression (which yields a kindtypeINTEGER1 result) and
- returns the result. */
-
-static ffetargetIntegerDefault
-ffedata_eval_integer1_ (ffebld expr)
-{
- ffetargetInteger1 result;
- ffebad error;
-
- assert (expr != NULL);
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opCONTER:
- return ffebld_constant_integer1 (ffebld_conter (expr));
-
- case FFEBLD_opSYMTER:
- return ffesymbol_value (ffebld_symter (expr));
-
- case FFEBLD_opUPLUS:
- return ffedata_eval_integer1_ (ffebld_left (expr));
-
- case FFEBLD_opUMINUS:
- error = ffetarget_uminus_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)));
- break;
-
- case FFEBLD_opADD:
- error = ffetarget_add_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opSUBTRACT:
- error = ffetarget_subtract_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opMULTIPLY:
- error = ffetarget_multiply_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opDIVIDE:
- error = ffetarget_divide_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opPOWER:
- {
- ffebld r = ffebld_right (expr);
-
- if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
- error = FFEBAD_DATA_EVAL;
- else
- error = ffetarget_power_integerdefault_integerdefault (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (r));
- }
- break;
-
-#if 0 /* Only for character basictype. */
- case FFEBLD_opCONCATENATE:
- error =;
- break;
-#endif
-
- case FFEBLD_opNOT:
- error = ffetarget_not_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)));
- break;
-
-#if 0 /* Only for logical basictype. */
- case FFEBLD_opLT:
- error =;
- break;
-
- case FFEBLD_opLE:
- error =;
- break;
-
- case FFEBLD_opEQ:
- error =;
- break;
-
- case FFEBLD_opNE:
- error =;
- break;
-
- case FFEBLD_opGT:
- error =;
- break;
-
- case FFEBLD_opGE:
- error =;
- break;
-#endif
-
- case FFEBLD_opAND:
- error = ffetarget_and_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opOR:
- error = ffetarget_or_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opXOR:
- error = ffetarget_xor_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opEQV:
- error = ffetarget_eqv_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opNEQV:
- error = ffetarget_neqv_integer1 (&result,
- ffedata_eval_integer1_ (ffebld_left (expr)),
- ffedata_eval_integer1_ (ffebld_right (expr)));
- break;
-
- case FFEBLD_opPAREN:
- return ffedata_eval_integer1_ (ffebld_left (expr));
-
-#if 0 /* ~~ no idea how to do this */
- case FFEBLD_opPERCENT_LOC:
- error =;
- break;
-#endif
-
-#if 0 /* not allowed by ANSI, but perhaps as an
- extension someday? */
- case FFEBLD_opCONVERT:
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
- default:
- error = FFEBAD_DATA_EVAL;
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
- default:
- error = FFEBAD_DATA_EVAL;
- break;
- }
- break;
- }
- break;
-#endif
-
-#if 0 /* not valid ops */
- case FFEBLD_opREPEAT:
- error =;
- break;
-
- case FFEBLD_opBOUNDS:
- error =;
- break;
-#endif
-
-#if 0 /* not allowed by ANSI, but perhaps as an
- extension someday? */
- case FFEBLD_opFUNCREF:
- error =;
- break;
-#endif
-
-#if 0 /* not valid ops */
- case FFEBLD_opSUBRREF:
- error =;
- break;
-
- case FFEBLD_opARRAYREF:
- error =;
- break;
-#endif
-
-#if 0 /* not valid for integer1 */
- case FFEBLD_opSUBSTR:
- error =;
- break;
-#endif
-
- default:
- error = FFEBAD_DATA_EVAL;
- break;
- }
-
- if (error != FFEBAD)
- {
- ffebad_start (error);
- ffest_ffebad_here_current_stmt (0);
- ffebad_finish ();
- result = 0;
- }
-
- return result;
-}
-
-/* ffedata_eval_offset_ -- Evaluate offset info array
-
- ffetargetOffset offset; // 0...max-1.
- ffebld subscripts; // an opITEM list of subscript exprs.
- ffebld dims; // an opITEM list of opBOUNDS exprs.
-
- result = ffedata_eval_offset_(expr);
-
- Evalues the expression (which yields a kindtypeINTEGER1 result) and
- returns the result. */
-
-static ffetargetOffset
-ffedata_eval_offset_ (ffebld subscripts, ffebld dims)
-{
- ffetargetIntegerDefault offset = 0;
- ffetargetIntegerDefault width = 1;
- ffetargetIntegerDefault value;
- ffetargetIntegerDefault lowbound;
- ffetargetIntegerDefault highbound;
- ffetargetOffset final;
- ffebld subscript;
- ffebld dim;
- ffebld low;
- ffebld high;
- int rank = 0;
- bool ok;
-
- while (subscripts != NULL)
- {
- ffeinfoKindtype sub_kind, low_kind, hi_kind;
- ffebld sub1, low1, hi1;
-
- ++rank;
- assert (dims != NULL);
-
- subscript = ffebld_head (subscripts);
- dim = ffebld_head (dims);
-
- assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
- if (ffebld_op (subscript) == FFEBLD_opCONTER)
- {
- /* Force to default - it's a constant expression ! */
- sub_kind = ffeinfo_kindtype (ffebld_info (subscript));
- sub1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
- sub_kind == FFEINFO_kindtypeINTEGER2 ? subscript->u.conter.expr->u.integer2 :
- sub_kind == FFEINFO_kindtypeINTEGER3 ? subscript->u.conter.expr->u.integer3 :
- sub_kind == FFEINFO_kindtypeINTEGER4 ? subscript->u.conter.expr->u.integer4 :
- subscript->u.conter.expr->u.integer1), NULL);
- value = ffedata_eval_integer1_ (sub1);
- }
- else
- value = ffedata_eval_integer1_ (subscript);
-
- assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
- low = ffebld_left (dim);
- high = ffebld_right (dim);
-
- if (low == NULL)
- lowbound = 1;
- else
- {
- assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
- if (ffebld_op (low) == FFEBLD_opCONTER)
- {
- /* Force to default - it's a constant expression ! */
- low_kind = ffeinfo_kindtype (ffebld_info (low));
- low1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
- low_kind == FFEINFO_kindtypeINTEGER2 ? low->u.conter.expr->u.integer2 :
- low_kind == FFEINFO_kindtypeINTEGER3 ? low->u.conter.expr->u.integer3 :
- low_kind == FFEINFO_kindtypeINTEGER4 ? low->u.conter.expr->u.integer4 :
- low->u.conter.expr->u.integer1), NULL);
- lowbound = ffedata_eval_integer1_ (low1);
- }
- else
- lowbound = ffedata_eval_integer1_ (low);
- }
-
- assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
- if (ffebld_op (high) == FFEBLD_opCONTER)
- {
- /* Force to default - it's a constant expression ! */
- hi_kind = ffeinfo_kindtype (ffebld_info (high));
- hi1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
- hi_kind == FFEINFO_kindtypeINTEGER2 ? high->u.conter.expr->u.integer2 :
- hi_kind == FFEINFO_kindtypeINTEGER3 ? high->u.conter.expr->u.integer3 :
- hi_kind == FFEINFO_kindtypeINTEGER4 ? high->u.conter.expr->u.integer4 :
- high->u.conter.expr->u.integer1), NULL);
- highbound = ffedata_eval_integer1_ (hi1);
- }
- else
- highbound = ffedata_eval_integer1_ (high);
-
- if ((value < lowbound) || (value > highbound))
- {
- char rankstr[10];
-
- sprintf (rankstr, "%d", rank);
- value = lowbound;
- ffebad_start (FFEBAD_DATA_SUBSCRIPT);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_string (rankstr);
- ffebad_finish ();
- }
-
- subscripts = ffebld_trail (subscripts);
- dims = ffebld_trail (dims);
-
- offset += width * (value - lowbound);
- if (subscripts != NULL)
- width *= highbound - lowbound + 1;
- }
-
- assert (dims == NULL);
-
- ok = ffetarget_offset (&final, offset);
- assert (ok);
-
- return final;
-}
-
-/* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference
-
- ffetargetCharacterSize beginpoint;
- ffebld endval; // head(colon).
-
- beginpoint = ffedata_eval_substr_end_(endval);
-
- If beginval is NULL, returns 0. Otherwise makes sure beginval is
- kindtypeINTEGERDEFAULT, makes sure its value is > 0,
- and returns its value minus one, or issues an error message. */
-
-static ffetargetCharacterSize
-ffedata_eval_substr_begin_ (ffebld expr)
-{
- ffetargetIntegerDefault val;
-
- if (expr == NULL)
- return 0;
-
- assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);
-
- val = ffedata_eval_integer1_ (expr);
-
- if (val < 1)
- {
- val = 1;
- ffebad_start (FFEBAD_DATA_RANGE);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- }
-
- return val - 1;
-}
-
-/* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference
-
- ffetargetCharacterSize endpoint;
- ffebld endval; // head(trail(colon)).
- ffetargetCharacterSize min; // beginpoint of substr reference.
- ffetargetCharacterSize max; // size of entity.
-
- endpoint = ffedata_eval_substr_end_(endval,dflt);
-
- If endval is NULL, returns max. Otherwise makes sure endval is
- kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
- and returns its value minus one, or issues an error message. */
-
-static ffetargetCharacterSize
-ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
- ffetargetCharacterSize max)
-{
- ffetargetIntegerDefault val;
-
- if (expr == NULL)
- return max - 1;
-
- assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);
-
- val = ffedata_eval_integer1_ (expr);
-
- if ((val < (ffetargetIntegerDefault) min)
- || (val > (ffetargetIntegerDefault) max))
- {
- val = 1;
- ffebad_start (FFEBAD_DATA_RANGE);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- }
-
- return val - 1;
-}
-
-/* ffedata_gather_ -- Gather initial values for sym into master sym inits
-
- ffestorag mst; // A typeCBLOCK or typeLOCAL aggregate.
- ffestorag st; // A typeCOMMON or typeEQUIV member.
- ffedata_gather_(mst,st);
-
- If st has any initialization info, transfer that info into mst and
- clear st's info. */
-
-static void
-ffedata_gather_ (ffestorag mst, ffestorag st)
-{
- ffesymbol s;
- ffesymbol s_whine; /* Symbol to complain about in diagnostics. */
- ffebld b;
- ffetargetOffset offset;
- ffetargetOffset units_expected;
- ffebitCount actual;
- ffebldConstantArray array;
- ffebld accter;
- ffetargetCopyfunc fn;
- void *ptr1;
- void *ptr2;
- size_t size;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeinfoBasictype ign_bt;
- ffeinfoKindtype ign_kt;
- ffetargetAlign units;
- ffebit bits;
- ffetargetOffset source_offset;
- bool whine = FALSE;
-
- if (st == NULL)
- return; /* Nothing to do. */
-
- s = ffestorag_symbol (st);
-
- assert (s != NULL); /* Must have a corresponding symbol (else how
- inited?). */
- assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */
- assert (ffestorag_accretion (st) == NULL);
-
- if ((((b = ffesymbol_init (s)) == NULL)
- && ((b = ffesymbol_accretion (s)) == NULL))
- || (ffebld_op (b) == FFEBLD_opANY)
- || ((ffebld_op (b) == FFEBLD_opCONVERT)
- && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
- return; /* Nothing to do. */
-
- /* b now holds the init/accretion expr. */
-
- ffesymbol_set_init (s, NULL);
- ffesymbol_set_accretion (s, NULL);
- ffesymbol_set_accretes (s, 0);
-
- s_whine = ffestorag_symbol (mst);
- if (s_whine == NULL)
- s_whine = s;
-
- /* Make sure we haven't fully accreted during an array init. */
-
- if (ffestorag_init (mst) != NULL)
- {
- ffebad_start (FFEBAD_DATA_MULTIPLE);
- ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
- ffebad_string (ffesymbol_text (s_whine));
- ffebad_finish ();
- return;
- }
-
- bt = ffeinfo_basictype (ffebld_info (b));
- kt = ffeinfo_kindtype (ffebld_info (b));
-
- /* Calculate offset for aggregate area. */
-
- ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
- ? ffebld_size (b) : 1;
- ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
- kt);/* Find out unit size of source datum. */
- assert (units % ffedata_storage_units_ == 0);
- units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
- offset = (ffestorag_offset (st) - ffestorag_offset (mst))
- / ffedata_storage_units_;
-
- /* Does an accretion array exist? If not, create it. */
-
- if (ffestorag_accretion (mst) == NULL)
- {
-#if FFEDATA_sizeTOO_BIG_INIT_ != 0
- if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
- {
- char bignum[40];
-
- sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
- ffebad_start (FFEBAD_TOO_BIG_INIT);
- ffebad_here (0, ffesymbol_where_line (s_whine),
- ffesymbol_where_column (s_whine));
- ffebad_string (ffesymbol_text (s_whine));
- ffebad_string (bignum);
- ffebad_finish ();
- }
-#endif
- array = ffebld_constantarray_new (ffedata_storage_bt_,
- ffedata_storage_kt_, ffedata_storage_size_);
- accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
- ffedata_storage_size_));
- ffebld_set_info (accter, ffeinfo_new
- (ffedata_storage_bt_,
- ffedata_storage_kt_,
- 1,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
- ? 1 : FFETARGET_charactersizeNONE));
- ffestorag_set_accretion (mst, accter);
- ffestorag_set_accretes (mst, ffedata_storage_size_);
- }
- else
- {
- accter = ffestorag_accretion (mst);
- assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
- array = ffebld_accter (accter);
- }
-
- /* Put value in accretion array at desired offset. */
-
- fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
- bt, kt);
-
- switch (ffebld_op (b))
- {
- case FFEBLD_opCONTER:
- ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
- ffedata_storage_kt_, offset,
- ffebld_constant_ptr_to_union (ffebld_conter (b)),
- bt, kt);
- (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
- operation. */
- ffebit_count (ffebld_accter_bits (accter),
- offset, FALSE, units_expected, &actual); /* How many FALSE? */
- if (units_expected != (ffetargetOffset) actual)
- {
- ffebad_start (FFEBAD_DATA_MULTIPLE);
- ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- }
- ffestorag_set_accretes (mst,
- ffestorag_accretes (mst)
- - actual); /* Decrement # of values
- actually accreted. */
- ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
-
- /* If done accreting for this storage area, establish as initialized. */
-
- if (ffestorag_accretes (mst) == 0)
- {
- ffestorag_set_init (mst, accter);
- ffestorag_set_accretion (mst, NULL);
- ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
- ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
- ffebld_set_arrter (ffestorag_init (mst),
- ffebld_accter (ffestorag_init (mst)));
- ffebld_arrter_set_size (ffestorag_init (mst),
- ffedata_storage_size_);
- ffebld_arrter_set_pad (ffestorag_init (mst), 0);
- ffecom_notify_init_storage (mst);
- }
-
- return;
-
- case FFEBLD_opARRTER:
- ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
- ffedata_storage_kt_, offset, ffebld_arrter (b),
- bt, kt);
- size *= ffebld_arrter_size (b);
- units_expected *= ffebld_arrter_size (b);
- (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
- operation. */
- ffebit_count (ffebld_accter_bits (accter),
- offset, FALSE, units_expected, &actual); /* How many FALSE? */
- if (units_expected != (ffetargetOffset) actual)
- {
- ffebad_start (FFEBAD_DATA_MULTIPLE);
- ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- }
- ffestorag_set_accretes (mst,
- ffestorag_accretes (mst)
- - actual); /* Decrement # of values
- actually accreted. */
- ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
-
- /* If done accreting for this storage area, establish as initialized. */
-
- if (ffestorag_accretes (mst) == 0)
- {
- ffestorag_set_init (mst, accter);
- ffestorag_set_accretion (mst, NULL);
- ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
- ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
- ffebld_set_arrter (ffestorag_init (mst),
- ffebld_accter (ffestorag_init (mst)));
- ffebld_arrter_set_size (ffestorag_init (mst),
- ffedata_storage_size_);
- ffebld_arrter_set_pad (ffestorag_init (mst), 0);
- ffecom_notify_init_storage (mst);
- }
-
- return;
-
- case FFEBLD_opACCTER:
- ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
- ffedata_storage_kt_, offset, ffebld_accter (b),
- bt, kt);
- bits = ffebld_accter_bits (b);
- source_offset = 0;
-
- for (;;)
- {
- ffetargetOffset unexp;
- ffetargetOffset siz;
- ffebitCount length;
- bool value;
-
- ffebit_test (bits, source_offset, &value, &length);
- if (length == 0)
- break; /* Exit the loop early. */
- siz = size * length;
- unexp = units_expected * length;
- if (value)
- {
- (*fn) (ptr1, ptr2, siz); /* Does memcpy-like operation. */
- ffebit_count (ffebld_accter_bits (accter), /* How many FALSE? */
- offset, FALSE, unexp, &actual);
- if (!whine && (unexp != (ffetargetOffset) actual))
- {
- whine = TRUE; /* Don't whine more than once for one gather. */
- ffebad_start (FFEBAD_DATA_MULTIPLE);
- ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- }
- ffestorag_set_accretes (mst,
- ffestorag_accretes (mst)
- - actual); /* Decrement # of values
- actually accreted. */
- ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
- }
- source_offset += length;
- offset += unexp;
- ptr1 = ((char *) ptr1) + siz;
- ptr2 = ((char *) ptr2) + siz;
- }
-
- /* If done accreting for this storage area, establish as initialized. */
-
- if (ffestorag_accretes (mst) == 0)
- {
- ffestorag_set_init (mst, accter);
- ffestorag_set_accretion (mst, NULL);
- ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
- ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
- ffebld_set_arrter (ffestorag_init (mst),
- ffebld_accter (ffestorag_init (mst)));
- ffebld_arrter_set_size (ffestorag_init (mst),
- ffedata_storage_size_);
- ffebld_arrter_set_pad (ffestorag_init (mst), 0);
- ffecom_notify_init_storage (mst);
- }
-
- return;
-
- default:
- assert ("bad init op in gather_" == NULL);
- return;
- }
-}
-
-/* ffedata_pop_ -- Pop an impdo stack entry
-
- ffedata_pop_(); */
-
-static void
-ffedata_pop_ (void)
-{
- ffedataImpdo_ victim = ffedata_stack_;
-
- assert (victim != NULL);
-
- ffedata_stack_ = ffedata_stack_->outer;
-
- malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
-}
-
-/* ffedata_push_ -- Push an impdo stack entry
-
- ffedata_push_(); */
-
-static void
-ffedata_push_ (void)
-{
- ffedataImpdo_ baby;
-
- baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));
-
- baby->outer = ffedata_stack_;
- ffedata_stack_ = baby;
-}
-
-/* ffedata_value_ -- Provide an initial value
-
- ffebld value;
- ffelexToken t; // Points to the value.
- if (ffedata_value(value,t))
- // Everything's ok
-
- Makes sure the value is ok, then remembers it according to the list
- provided to ffedata_begin. */
-
-static bool
-ffedata_value_ (ffebld value, ffelexToken token)
-{
-
- /* If already reported an error, don't do anything. */
-
- if (ffedata_reported_error_)
- return FALSE;
-
- /* If the value is an error marker, remember we've seen one and do nothing
- else. */
-
- if ((value != NULL)
- && (ffebld_op (value) == FFEBLD_opANY))
- {
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
-
- /* If too many values (no more targets), complain. */
-
- if (ffedata_symbol_ == NULL)
- {
- ffebad_start (FFEBAD_DATA_TOOMANY);
- ffebad_here (0, ffelex_token_where_line (token),
- ffelex_token_where_column (token));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
-
- /* If ffedata_advance_ wanted to register a complaint, do it now
- that we have the token to point at instead of just the start
- of the whole statement. */
-
- if (ffedata_reinit_)
- {
- ffebad_start (FFEBAD_DATA_REINIT);
- ffebad_here (0, ffelex_token_where_line (token),
- ffelex_token_where_column (token));
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
-
-#if FFEGLOBAL_ENABLED
- if (ffesymbol_common (ffedata_symbol_) != NULL)
- ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token);
-#endif
-
- /* Convert value to desired type. */
-
- if (value != NULL)
- {
- if (ffedata_convert_cache_use_ == -1)
- value = ffeexpr_convert
- (value, token, NULL, ffedata_basictype_,
- ffedata_kindtype_, 0,
- (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
- ? ffedata_charexpected_ : FFETARGET_charactersizeNONE,
- FFEEXPR_contextDATA);
- else /* Use the cache. */
- value = ffedata_convert_
- (value, token, NULL, ffedata_basictype_,
- ffedata_kindtype_, 0,
- (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
- ? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
- }
-
- /* If we couldn't, bug out. */
-
- if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
- {
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
-
- /* Handle the case where initializes go to a parent's storage area. */
-
- if (ffedata_storage_ != NULL)
- {
- ffetargetOffset offset;
- ffetargetOffset units_expected;
- ffebitCount actual;
- ffebldConstantArray array;
- ffebld accter;
- ffetargetCopyfunc fn;
- void *ptr1;
- void *ptr2;
- size_t size;
- ffeinfoBasictype ign_bt;
- ffeinfoKindtype ign_kt;
- ffetargetAlign units;
-
- /* Make sure we haven't fully accreted during an array init. */
-
- if (ffestorag_init (ffedata_storage_) != NULL)
- {
- ffebad_start (FFEBAD_DATA_MULTIPLE);
- ffebad_here (0, ffelex_token_where_line (token),
- ffelex_token_where_column (token));
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
-
- /* Calculate offset. */
-
- offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
-
- /* Is offset within range? If not, whine, but don't do anything else. */
-
- if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
- {
- ffebad_start (FFEBAD_DATA_RANGE);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
-
- /* Now calculate offset for aggregate area. */
-
- ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
- ffedata_kindtype_); /* Find out unit size of
- source datum. */
- assert (units % ffedata_storage_units_ == 0);
- units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
- offset *= units / ffedata_storage_units_;
- offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_))
- - ffestorag_offset (ffedata_storage_))
- / ffedata_storage_units_;
-
- assert (offset + units_expected - 1 <= ffedata_storage_size_);
-
- /* Does an accretion array exist? If not, create it. */
-
- if (value != NULL)
- {
- if (ffestorag_accretion (ffedata_storage_) == NULL)
- {
-#if FFEDATA_sizeTOO_BIG_INIT_ != 0
- if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
- {
- char bignum[40];
-
- sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
- ffebad_start (FFEBAD_TOO_BIG_INIT);
- ffebad_here (0, ffelex_token_where_line (token),
- ffelex_token_where_column (token));
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_string (bignum);
- ffebad_finish ();
- }
-#endif
- array = ffebld_constantarray_new
- (ffedata_storage_bt_, ffedata_storage_kt_,
- ffedata_storage_size_);
- accter = ffebld_new_accter (array,
- ffebit_new (ffe_pool_program_unit (),
- ffedata_storage_size_));
- ffebld_set_info (accter, ffeinfo_new
- (ffedata_storage_bt_,
- ffedata_storage_kt_,
- 1,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- (ffedata_basictype_
- == FFEINFO_basictypeCHARACTER)
- ? 1 : FFETARGET_charactersizeNONE));
- ffestorag_set_accretion (ffedata_storage_, accter);
- ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_);
- }
- else
- {
- accter = ffestorag_accretion (ffedata_storage_);
- assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
- array = ffebld_accter (accter);
- }
-
- /* Put value in accretion array at desired offset. */
-
- fn = ffetarget_aggregate_ptr_memcpy
- (ffedata_storage_bt_, ffedata_storage_kt_,
- ffedata_basictype_, ffedata_kindtype_);
- ffebld_constantarray_prepare
- (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
- ffedata_storage_kt_, offset,
- ffebld_constant_ptr_to_union (ffebld_conter (value)),
- ffedata_basictype_, ffedata_kindtype_);
- (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
- operation. */
- ffebit_count (ffebld_accter_bits (accter),
- offset, FALSE, units_expected,
- &actual); /* How many FALSE? */
- if (units_expected != (ffetargetOffset) actual)
- {
- ffebad_start (FFEBAD_DATA_MULTIPLE);
- ffebad_here (0, ffelex_token_where_line (token),
- ffelex_token_where_column (token));
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- }
- ffestorag_set_accretes (ffedata_storage_,
- ffestorag_accretes (ffedata_storage_)
- - actual); /* Decrement # of values
- actually accreted. */
- ffebit_set (ffebld_accter_bits (accter), offset,
- 1, units_expected);
-
- /* If done accreting for this storage area, establish as
- initialized. */
-
- if (ffestorag_accretes (ffedata_storage_) == 0)
- {
- ffestorag_set_init (ffedata_storage_, accter);
- ffestorag_set_accretion (ffedata_storage_, NULL);
- ffebit_kill (ffebld_accter_bits
- (ffestorag_init (ffedata_storage_)));
- ffebld_set_op (ffestorag_init (ffedata_storage_),
- FFEBLD_opARRTER);
- ffebld_set_arrter
- (ffestorag_init (ffedata_storage_),
- ffebld_accter (ffestorag_init (ffedata_storage_)));
- ffebld_arrter_set_size (ffestorag_init (ffedata_storage_),
- ffedata_storage_size_);
- ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_),
- 0);
- ffecom_notify_init_storage (ffedata_storage_);
- }
- }
-
- /* If still accreting, adjust specs accordingly and return. */
-
- if (++ffedata_number_ < ffedata_expected_)
- {
- ++ffedata_offset_;
- return TRUE;
- }
-
- return ffedata_advance_ ();
- }
-
- /* Figure out where the value goes -- in an accretion array or directly
- into the final initial-value slot for the symbol. */
-
- if ((ffedata_number_ != 0)
- || (ffedata_arraysize_ > 1)
- || (ffedata_charnumber_ != 0)
- || (ffedata_size_ > ffedata_charexpected_))
- { /* Accrete this value. */
- ffetargetOffset offset;
- ffebitCount actual;
- ffebldConstantArray array;
- ffebld accter = NULL;
-
- /* Calculate offset. */
-
- offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
-
- /* Is offset within range? If not, whine, but don't do anything else. */
-
- if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
- {
- ffebad_start (FFEBAD_DATA_RANGE);
- ffest_ffebad_here_current_stmt (0);
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- ffedata_reported_error_ = TRUE;
- return FALSE;
- }
-
- /* Does an accretion array exist? If not, create it. */
-
- if (value != NULL)
- {
- if (ffesymbol_accretion (ffedata_symbol_) == NULL)
- {
-#if FFEDATA_sizeTOO_BIG_INIT_ != 0
- if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ )
- {
- char bignum[40];
-
- sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_);
- ffebad_start (FFEBAD_TOO_BIG_INIT);
- ffebad_here (0, ffelex_token_where_line (token),
- ffelex_token_where_column (token));
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_string (bignum);
- ffebad_finish ();
- }
-#endif
- array = ffebld_constantarray_new
- (ffedata_basictype_, ffedata_kindtype_,
- ffedata_symbolsize_);
- accter = ffebld_new_accter (array,
- ffebit_new (ffe_pool_program_unit (),
- ffedata_symbolsize_));
- ffebld_set_info (accter, ffeinfo_new
- (ffedata_basictype_,
- ffedata_kindtype_,
- 1,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- (ffedata_basictype_
- == FFEINFO_basictypeCHARACTER)
- ? 1 : FFETARGET_charactersizeNONE));
- ffesymbol_set_accretion (ffedata_symbol_, accter);
- ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_);
- }
- else
- {
- accter = ffesymbol_accretion (ffedata_symbol_);
- assert (ffedata_symbolsize_
- == (ffetargetOffset) ffebld_accter_size (accter));
- array = ffebld_accter (accter);
- }
-
- /* Put value in accretion array at desired offset. */
-
- ffebld_constantarray_put
- (array, ffedata_basictype_, ffedata_kindtype_,
- offset, ffebld_constant_union (ffebld_conter (value)));
- ffebit_count (ffebld_accter_bits (accter), offset, FALSE,
- ffedata_charexpected_,
- &actual); /* How many FALSE? */
- if (actual != (unsigned long int) ffedata_charexpected_)
- {
- ffebad_start (FFEBAD_DATA_MULTIPLE);
- ffebad_here (0, ffelex_token_where_line (token),
- ffelex_token_where_column (token));
- ffebad_string (ffesymbol_text (ffedata_symbol_));
- ffebad_finish ();
- }
- ffesymbol_set_accretes (ffedata_symbol_,
- ffesymbol_accretes (ffedata_symbol_)
- - actual); /* Decrement # of values
- actually accreted. */
- ffebit_set (ffebld_accter_bits (accter), offset,
- 1, ffedata_charexpected_);
- ffesymbol_signal_unreported (ffedata_symbol_);
- }
-
- /* If still accreting, adjust specs accordingly and return. */
-
- if (++ffedata_number_ < ffedata_expected_)
- {
- ++ffedata_offset_;
- return TRUE;
- }
-
- /* Else, if done accreting for this symbol, establish as initialized. */
-
- if ((value != NULL)
- && (ffesymbol_accretes (ffedata_symbol_) == 0))
- {
- ffesymbol_set_init (ffedata_symbol_, accter);
- ffesymbol_set_accretion (ffedata_symbol_, NULL);
- ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_)));
- ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER);
- ffebld_set_arrter (ffesymbol_init (ffedata_symbol_),
- ffebld_accter (ffesymbol_init (ffedata_symbol_)));
- ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_),
- ffedata_symbolsize_);
- ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0);
- ffecom_notify_init_symbol (ffedata_symbol_);
- }
- }
- else if (value != NULL)
- {
- /* Simple, direct, one-shot assignment. */
- ffesymbol_set_init (ffedata_symbol_, value);
- ffecom_notify_init_symbol (ffedata_symbol_);
- }
-
- /* Call on advance function to get next target in list. */
-
- return ffedata_advance_ ();
-}
+++ /dev/null
-/* data.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- data.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_DATA_H
-#define GCC_F_DATA_H
-
-/* Simple definitions and enumerations. */
-
-
-/* Typedefs. */
-
-
-/* Include files needed by this one. */
-
-#include "bld.h"
-#include "lex.h"
-#include "storag.h"
-
-/* Structure definitions. */
-
-
-/* Global objects accessed by users of this module. */
-
-
-/* Declare functions with prototypes. */
-
-void ffedata_begin (ffebld list);
-bool ffedata_end (bool report_errors, ffelexToken t);
-void ffedata_gather (ffestorag st);
-bool ffedata_value (ffetargetIntegerDefault rpt, ffebld value,
- ffelexToken value_token);
-
-/* Define macros. */
-
-#define ffedata_init_0()
-#define ffedata_init_1()
-#define ffedata_init_2()
-#define ffedata_init_3()
-#define ffedata_init_4()
-#define ffedata_terminate_0()
-#define ffedata_terminate_1()
-#define ffedata_terminate_2()
-#define ffedata_terminate_3()
-#define ffedata_terminate_4()
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_DATA_H */
+++ /dev/null
-/* equiv.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 1997, 1998, 2003
- Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None
-
- Description:
- Handles the EQUIVALENCE relationships in a program unit.
-
- Modifications:
-*/
-
-#define FFEEQUIV_DEBUG 0
-
-/* Include files. */
-
-#include "proj.h"
-#include "equiv.h"
-#include "bad.h"
-#include "bld.h"
-#include "com.h"
-#include "data.h"
-#include "global.h"
-#include "lex.h"
-#include "malloc.h"
-#include "symbol.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-struct _ffeequiv_list_
- {
- ffeequiv first;
- ffeequiv last;
- };
-
-/* Static objects accessed by functions in this module. */
-
-static struct _ffeequiv_list_ ffeequiv_list_;
-
-/* Static functions (internal). */
-
-static void ffeequiv_destroy_ (ffeequiv eq);
-static void ffeequiv_layout_local_ (ffeequiv eq);
-static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s,
- ffebld expr, bool subtract,
- ffetargetOffset adjust, bool no_precede);
-
-/* Internal macros. */
-\f
-
-static void
-ffeequiv_destroy_ (ffeequiv victim)
-{
- ffebld list;
- ffebld item;
- ffebld expr;
-
- for (list = victim->list; list != NULL; list = ffebld_trail (list))
- {
- for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
- {
- ffesymbol sym;
-
- expr = ffebld_head (item);
- sym = ffeequiv_symbol (expr);
- if (sym == NULL)
- continue;
- if (ffesymbol_equiv (sym) != NULL)
- ffesymbol_set_equiv (sym, NULL);
- }
- }
- ffeequiv_kill (victim);
-}
-
-/* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars
-
- ffeequiv eq;
- ffeequiv_layout_local_(eq);
-
- Makes a single master ffestorag object that contains all the vars
- in the equivalence, and makes subordinate ffestorag objects for the
- vars with the correct offsets.
-
- The resulting var offsets are relative not necessarily to 0 -- the
- are relative to the offset of the master area, which might be 0 or
- negative, but should never be positive. */
-
-static void
-ffeequiv_layout_local_ (ffeequiv eq)
-{
- ffestorag st; /* Equivalence storage area. */
- ffebld list; /* List of list of equivalences. */
- ffebld item; /* List of equivalences. */
- ffebld root_exp; /* Expression for root sym. */
- ffestorag root_st; /* Storage for root. */
- ffesymbol root_sym; /* Root itself. */
- ffebld rooted_exp; /* Expression for rooted sym in an eqlist. */
- ffestorag rooted_st; /* Storage for rooted. */
- ffesymbol rooted_sym; /* Rooted symbol itself. */
- ffetargetOffset eqlist_offset;/* Offset for eqlist from rooted sym. */
- ffetargetAlign alignment;
- ffetargetAlign modulo;
- ffetargetAlign pad;
- ffetargetOffset size;
- ffetargetOffset num_elements;
- bool new_storage; /* Established new storage info. */
- bool need_storage; /* Have need for more storage info. */
- bool init;
-
- assert (eq != NULL);
-
- if (ffeequiv_common (eq) != NULL)
- { /* Put in common due to programmer error. */
- ffeequiv_destroy_ (eq);
- return;
- }
-
- /* Find the symbol for the first valid item in the list of lists, use that
- as the root symbol. Doesn't matter if it won't end up at the beginning
- of the list, though. */
-
-#if FFEEQUIV_DEBUG
- fprintf (stderr, "Equiv1:\n");
-#endif
-
- root_sym = NULL;
- root_exp = NULL;
-
- for (list = ffeequiv_list (eq);
- list != NULL;
- list = ffebld_trail (list))
- { /* For every equivalence list in the list of
- equivs */
- for (item = ffebld_head (list);
- item != NULL;
- item = ffebld_trail (item))
- { /* For every equivalence item in the list */
- ffetargetOffset ign; /* Ignored. */
-
- root_exp = ffebld_head (item);
- root_sym = ffeequiv_symbol (root_exp);
- if (root_sym == NULL)
- continue; /* Ignore me. */
-
- assert (ffesymbol_storage (root_sym) == NULL); /* No storage yet. */
-
- if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE))
- {
- /* We can't just eliminate this one symbol from the list
- of candidates, because it might be the only one that
- ties all these equivs together. So just destroy the
- whole list. */
-
- ffeequiv_destroy_ (eq);
- return;
- }
-
- break; /* Use first valid eqv expr for root exp/sym. */
- }
- if (root_sym != NULL)
- break;
- }
-
- if (root_sym == NULL)
- {
- ffeequiv_destroy_ (eq);
- return;
- }
-
-
-#if FFEEQUIV_DEBUG
- fprintf (stderr, " Root: `%s'\n", ffesymbol_text (root_sym));
-#endif
-
- /* We've got work to do, so make the LOCAL storage object that'll hold all
- the equivalenced vars inside it. */
-
- st = ffestorag_new (ffestorag_list_master ());
- ffestorag_set_parent (st, NULL); /* Initializations happen here. */
- ffestorag_set_init (st, NULL);
- ffestorag_set_accretion (st, NULL);
- ffestorag_set_offset (st, 0); /* Assume equiv will be at root offset 0 for now. */
- ffestorag_set_alignment (st, 1);
- ffestorag_set_modulo (st, 0);
- ffestorag_set_type (st, FFESTORAG_typeLOCAL);
- ffestorag_set_basictype (st, ffesymbol_basictype (root_sym));
- ffestorag_set_kindtype (st, ffesymbol_kindtype (root_sym));
- ffestorag_set_typesymbol (st, root_sym);
- ffestorag_set_is_save (st, ffeequiv_is_save (eq));
- if (ffesymbol_is_save (root_sym))
- ffestorag_update_save (st);
- ffestorag_set_is_init (st, ffeequiv_is_init (eq));
- if (ffesymbol_is_init (root_sym))
- ffestorag_update_init (st);
- ffestorag_set_symbol (st, root_sym); /* Assume this will be the root until
- we know better (used only to generate
- the internal name for the aggregate area,
- e.g. for debugging). */
-
- /* Make the EQUIV storage object for the root symbol. */
-
- if (ffesymbol_rank (root_sym) == 0)
- num_elements = 1;
- else
- num_elements = ffebld_constant_integerdefault (ffebld_conter
- (ffesymbol_arraysize (root_sym)));
- ffetarget_layout (ffesymbol_text (root_sym), &alignment, &modulo, &size,
- ffesymbol_basictype (root_sym), ffesymbol_kindtype (root_sym),
- ffesymbol_size (root_sym), num_elements);
- ffestorag_set_size (st, size); /* Set initial size of aggregate area. */
-
- pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
- ffestorag_ptr_to_modulo (st), 0, alignment,
- modulo);
- assert (pad == 0);
-
- root_st = ffestorag_new (ffestorag_list_equivs (st));
- ffestorag_set_parent (root_st, st); /* Initializations happen there. */
- ffestorag_set_init (root_st, NULL);
- ffestorag_set_accretion (root_st, NULL);
- ffestorag_set_symbol (root_st, root_sym);
- ffestorag_set_size (root_st, size);
- ffestorag_set_offset (root_st, 0); /* Will not change; always 0 relative to itself! */
- ffestorag_set_alignment (root_st, alignment);
- ffestorag_set_modulo (root_st, modulo);
- ffestorag_set_type (root_st, FFESTORAG_typeEQUIV);
- ffestorag_set_basictype (root_st, ffesymbol_basictype (root_sym));
- ffestorag_set_kindtype (root_st, ffesymbol_kindtype (root_sym));
- ffestorag_set_typesymbol (root_st, root_sym);
- ffestorag_set_is_save (root_st, FALSE); /* Assume FALSE, then... */
- if (ffestorag_is_save (st)) /* ...update to TRUE if needed. */
- ffestorag_update_save (root_st);
- ffestorag_set_is_init (root_st, FALSE); /* Assume FALSE, then... */
- if (ffestorag_is_init (st)) /* ...update to TRUE if needed. */
- ffestorag_update_init (root_st);
- ffesymbol_set_storage (root_sym, root_st);
- ffesymbol_signal_unreported (root_sym);
- init = ffesymbol_is_init (root_sym);
-
- /* Now that we know the root (offset=0) symbol, revisit all the lists and
- do the actual storage allocation. Keep doing this until we've gone
- through them all without making any new storage objects. */
-
- do
- {
- new_storage = FALSE;
- need_storage = FALSE;
- for (list = ffeequiv_list (eq);
- list != NULL;
- list = ffebld_trail (list))
- { /* For every equivalence list in the list of
- equivs */
- /* Now find a "rooted" symbol in this list. That is, find the
- first item we can that is valid and whose symbol already
- has a storage area, because that means we know where it
- belongs in the equivalence area and can then allocate the
- rest of the items in the list accordingly. */
-
- rooted_sym = NULL;
- rooted_exp = NULL;
- eqlist_offset = 0;
-
- for (item = ffebld_head (list);
- item != NULL;
- item = ffebld_trail (item))
- { /* For every equivalence item in the list */
- rooted_exp = ffebld_head (item);
- rooted_sym = ffeequiv_symbol (rooted_exp);
- if ((rooted_sym == NULL)
- || ((rooted_st = ffesymbol_storage (rooted_sym)) == NULL))
- {
- rooted_sym = NULL;
- continue; /* Ignore me. */
- }
-
- need_storage = TRUE; /* Somebody is likely to need
- storage. */
-
-#if FFEEQUIV_DEBUG
- fprintf (stderr, " Rooted: `%s' at %" ffetargetOffset_f "d\n",
- ffesymbol_text (rooted_sym),
- ffestorag_offset (rooted_st));
-#endif
-
- /* The offset of this symbol from the equiv's root symbol
- is already known, and the size of this symbol is already
- incorporated in the size of the equiv's aggregate area.
- What we now determine is the offset of this equivalence
- _list_ from the equiv's root symbol.
-
- For example, if we know that A is at offset 16 from the
- root symbol, given EQUIVALENCE (B(24),A(2)), we're looking
- at A(2), meaning that the offset for this equivalence list
- is 20 (4 bytes beyond the beginning of A, assuming typical
- array types, dimensions, and type info). */
-
- if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE,
- ffestorag_offset (rooted_st), FALSE))
-
- { /* Can't use this one. */
- ffesymbol_set_equiv (rooted_sym, NULL);/* Equiv area slated for
- death. */
- rooted_sym = NULL;
- continue; /* Something's wrong with eqv expr, try another. */
- }
-
-#if FFEEQUIV_DEBUG
- fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n",
- eqlist_offset);
-#endif
-
- break;
- }
-
- /* If no rooted symbol, it means this list has no roots -- yet.
- So, forget this list this time around, but we'll get back
- to it after the outer loop iterates at least one more time,
- and, ultimately, it will have a root. */
-
- if (rooted_sym == NULL)
- {
-#if FFEEQUIV_DEBUG
- fprintf (stderr, "No roots.\n");
-#endif
- continue;
- }
-
- /* We now have a rooted symbol/expr and the offset of this equivalence
- list from the root symbol. The other expressions in this
- list all identify an initial storage unit that must have the
- same offset. */
-
- for (item = ffebld_head (list);
- item != NULL;
- item = ffebld_trail (item))
- { /* For every equivalence item in the list */
- ffebld item_exp; /* Expression for equivalence. */
- ffestorag item_st; /* Storage for var. */
- ffesymbol item_sym; /* Var itself. */
- ffetargetOffset item_offset; /* Offset for var from root. */
- ffetargetOffset new_size;
-
- item_exp = ffebld_head (item);
- item_sym = ffeequiv_symbol (item_exp);
- if ((item_sym == NULL)
- || (ffesymbol_equiv (item_sym) == NULL))
- continue; /* Ignore me. */
-
- if (item_sym == rooted_sym)
- continue; /* Rooted sym already set up. */
-
- if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE,
- eqlist_offset, FALSE))
- {
- ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
- continue;
- }
-
-#if FFEEQUIV_DEBUG
- fprintf (stderr, " Item `%s' at %" ffetargetOffset_f "d",
- ffesymbol_text (item_sym), item_offset);
-#endif
-
- if (ffesymbol_rank (item_sym) == 0)
- num_elements = 1;
- else
- num_elements = ffebld_constant_integerdefault (ffebld_conter
- (ffesymbol_arraysize (item_sym)));
- ffetarget_layout (ffesymbol_text (item_sym), &alignment, &modulo,
- &size, ffesymbol_basictype (item_sym),
- ffesymbol_kindtype (item_sym), ffesymbol_size (item_sym),
- num_elements);
- pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
- ffestorag_ptr_to_modulo (st),
- item_offset, alignment, modulo);
- if (pad != 0)
- {
- ffebad_start (FFEBAD_EQUIV_ALIGN);
- ffebad_string (ffesymbol_text (item_sym));
- ffebad_finish ();
- ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
- continue;
- }
-
- /* If the variable's offset is less than the offset for the
- aggregate storage area, it means it has to expand backwards
- -- i.e. the new known starting point of the area precedes the
- old one. This can't happen with COMMON areas (the standard,
- and common sense, disallow it), but it is normal for local
- EQUIVALENCE areas.
-
- Also handle choosing the "documented" rooted symbol for this
- area here. It's the symbol at the bottom (lowest offset)
- of the aggregate area, with ties going to the name that would
- sort to the top of the list of ties. */
-
- if (item_offset == ffestorag_offset (st))
- {
- if ((item_sym != ffestorag_symbol (st))
- && (strcmp (ffesymbol_text (item_sym),
- ffesymbol_text (ffestorag_symbol (st)))
- < 0))
- ffestorag_set_symbol (st, item_sym);
- }
- else if (item_offset < ffestorag_offset (st))
- {
- /* Increase size of equiv area to start for lower offset
- relative to root symbol. */
- if (! ffetarget_offset_add (&new_size,
- ffestorag_offset (st)
- - item_offset,
- ffestorag_size (st)))
- ffetarget_offset_overflow (ffesymbol_text (s));
- else
- ffestorag_set_size (st, new_size);
-
- ffestorag_set_symbol (st, item_sym);
- ffestorag_set_offset (st, item_offset);
-
-#if FFEEQUIV_DEBUG
- fprintf (stderr, " [eq offset=%" ffetargetOffset_f
- "d, size=%" ffetargetOffset_f "d]",
- item_offset, new_size);
-#endif
- }
-
- if ((item_st = ffesymbol_storage (item_sym)) == NULL)
- { /* Create new ffestorag object, extend equiv
- area. */
-#if FFEEQUIV_DEBUG
- fprintf (stderr, ".\n");
-#endif
- new_storage = TRUE;
- item_st = ffestorag_new (ffestorag_list_equivs (st));
- ffestorag_set_parent (item_st, st); /* Initializations
- happen there. */
- ffestorag_set_init (item_st, NULL);
- ffestorag_set_accretion (item_st, NULL);
- ffestorag_set_symbol (item_st, item_sym);
- ffestorag_set_size (item_st, size);
- ffestorag_set_offset (item_st, item_offset);
- ffestorag_set_alignment (item_st, alignment);
- ffestorag_set_modulo (item_st, modulo);
- ffestorag_set_type (item_st, FFESTORAG_typeEQUIV);
- ffestorag_set_basictype (item_st, ffesymbol_basictype (item_sym));
- ffestorag_set_kindtype (item_st, ffesymbol_kindtype (item_sym));
- ffestorag_set_typesymbol (item_st, item_sym);
- ffestorag_set_is_save (item_st, FALSE); /* Assume FALSE... */
- if (ffestorag_is_save (st)) /* ...update TRUE */
- ffestorag_update_save (item_st); /* if needed. */
- ffestorag_set_is_init (item_st, FALSE); /* Assume FALSE... */
- if (ffestorag_is_init (st)) /* ...update TRUE */
- ffestorag_update_init (item_st); /* if needed. */
- ffesymbol_set_storage (item_sym, item_st);
- ffesymbol_signal_unreported (item_sym);
- if (ffesymbol_is_init (item_sym))
- init = TRUE;
-
- /* Determine new size of equiv area, complain if overflow. */
-
- if (!ffetarget_offset_add (&size, item_offset, size)
- || !ffetarget_offset_add (&size, -ffestorag_offset (st), size))
- ffetarget_offset_overflow (ffesymbol_text (s));
- else if (size > ffestorag_size (st))
- ffestorag_set_size (st, size);
- ffestorag_update (st, item_sym, ffesymbol_basictype (item_sym),
- ffesymbol_kindtype (item_sym));
- }
- else
- {
-#if FFEEQUIV_DEBUG
- fprintf (stderr, " (was %" ffetargetOffset_f "d).\n",
- ffestorag_offset (item_st));
-#endif
- /* Make sure offset agrees with known offset. */
- if (item_offset != ffestorag_offset (item_st))
- {
- char io1[40];
- char io2[40];
-
- sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset);
- sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st));
- ffebad_start (FFEBAD_EQUIV_MISMATCH);
- ffebad_string (ffesymbol_text (item_sym));
- ffebad_string (ffesymbol_text (root_sym));
- ffebad_string (io1);
- ffebad_string (io2);
- ffebad_finish ();
- }
- }
- ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
- } /* (For every equivalence item in the list) */
- ffebld_set_head (list, NULL); /* Don't do this list again. */
- } /* (For every equivalence list in the list of
- equivs) */
- } while (new_storage && need_storage);
-
- ffesymbol_set_equiv (root_sym, NULL); /* This one has storage now. */
-
- ffeequiv_kill (eq); /* Fully processed, no longer needed. */
-
- /* If the offset for this storage area is zero (it cannot be positive),
- that means the alignment/modulo info is already correct. Otherwise,
- the alignment info is correct, but the modulo info reflects a
- zero offset, so fix it. */
-
- if (ffestorag_offset (st) < 0)
- {
- /* Calculate the initial padding necessary to preserve
- the alignment/modulo requirements for the storage area.
- These requirements are themselves kept track of in the
- record for the storage area as a whole, but really pertain
- to offset 0 of that area, which is where the root symbol
- was originally placed.
-
- The goal here is to have the offset and size for the area
- faithfully reflect the area itself, not extra requirements
- like alignment. So to meet the alignment requirements,
- the modulo for the area should be set as if the area had an
- alignment requirement of alignment/0 and was aligned/padded
- downward to meet the alignment requirements of the area at
- offset zero, the amount of padding needed being the desired
- value for the modulo of the area. */
-
- alignment = ffestorag_alignment (st);
- modulo = ffestorag_modulo (st);
-
- /* Since we want to move the whole area *down* (lower memory
- addresses) as required by the alignment/modulo paid, negate
- the offset to ffetarget_align, which assumes aligning *up*
- is desired. */
- pad = ffetarget_align (&alignment, &modulo,
- - ffestorag_offset (st),
- alignment, 0);
- ffestorag_set_modulo (st, pad);
- }
-
- if (init)
- ffedata_gather (st); /* Gather subordinate inits into one init. */
-}
-
-/* ffeequiv_offset_ -- Determine offset from start of symbol
-
- ffetargetOffset offset;
- ffesymbol s; // Symbol for error reporting.
- ffebld expr; // opSUBSTR, opARRAYREF, opSYMTER, opANY.
- bool subtract; // FALSE means add to adjust, TRUE means subtract from it.
- ffetargetOffset adjust; // Helps keep answer in pos range (unsigned).
- if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust))
- // error doing the calculation, message already printed
-
- Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF
- combination added-to/subtracted-from the adjustment specified. If there
- is an error of some kind, returns FALSE, else returns TRUE. Note that
- only the first storage unit specified is considered; A(1:1) and A(1:2000)
- have the same first storage unit and so return the same offset. */
-
-static bool
-ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED,
- ffebld expr, bool subtract, ffetargetOffset adjust,
- bool no_precede)
-{
- ffetargetIntegerDefault value = 0;
- ffetargetOffset cval; /* Converted value. */
- ffesymbol sym;
-
- if (expr == NULL)
- return FALSE;
-
-again: /* :::::::::::::::::::: */
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opANY:
- return FALSE;
-
- case FFEBLD_opSYMTER:
- {
- ffetargetOffset size; /* Size of a single unit. */
- ffetargetAlign a; /* Ignored. */
- ffetargetAlign m; /* Ignored. */
-
- sym = ffebld_symter (expr);
- if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
- return FALSE;
-
- ffetarget_layout (ffesymbol_text (sym), &a, &m, &size,
- ffesymbol_basictype (sym),
- ffesymbol_kindtype (sym), 1, 1);
-
- if (value < 0)
- { /* Really invalid, as in A(-2:5), but in case
- it's wanted.... */
- if (!ffetarget_offset (&cval, -value))
- return FALSE;
-
- if (!ffetarget_offset_multiply (&cval, cval, size))
- return FALSE;
-
- if (subtract)
- return ffetarget_offset_add (offset, cval, adjust);
-
- if (no_precede && (cval > adjust))
- {
- neg: /* :::::::::::::::::::: */
- ffebad_start (FFEBAD_COMMON_NEG);
- ffebad_string (ffesymbol_text (sym));
- ffebad_finish ();
- return FALSE;
- }
- return ffetarget_offset_add (offset, -cval, adjust);
- }
-
- if (!ffetarget_offset (&cval, value))
- return FALSE;
-
- if (!ffetarget_offset_multiply (&cval, cval, size))
- return FALSE;
-
- if (!subtract)
- return ffetarget_offset_add (offset, cval, adjust);
-
- if (no_precede && (cval > adjust))
- goto neg; /* :::::::::::::::::::: */
-
- return ffetarget_offset_add (offset, -cval, adjust);
- }
-
- case FFEBLD_opARRAYREF:
- {
- ffebld symexp = ffebld_left (expr);
- ffebld subscripts = ffebld_right (expr);
- ffebld dims;
- ffetargetIntegerDefault width;
- ffetargetIntegerDefault arrayval;
- ffetargetIntegerDefault lowbound;
- ffetargetIntegerDefault highbound;
- ffebld subscript;
- ffebld dim;
- ffebld low;
- ffebld high;
- int rank = 0;
-
- if (ffebld_op (symexp) != FFEBLD_opSYMTER)
- return FALSE;
-
- sym = ffebld_symter (symexp);
- if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
- return FALSE;
-
- if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE)
- width = 1;
- else
- width = ffesymbol_size (sym);
- dims = ffesymbol_dims (sym);
-
- while (subscripts != NULL)
- {
- ++rank;
- if (dims == NULL)
- {
- ffebad_start (FFEBAD_EQUIV_MANY);
- ffebad_string (ffesymbol_text (sym));
- ffebad_finish ();
- return FALSE;
- }
-
- subscript = ffebld_head (subscripts);
- dim = ffebld_head (dims);
-
- if (ffebld_op (subscript) == FFEBLD_opANY)
- return FALSE;
-
- assert (ffebld_op (subscript) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (subscript))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (subscript))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- arrayval = ffebld_constant_integerdefault (ffebld_conter
- (subscript));
-
- if (ffebld_op (dim) == FFEBLD_opANY)
- return FALSE;
-
- assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
- low = ffebld_left (dim);
- high = ffebld_right (dim);
-
- if (low == NULL)
- lowbound = 1;
- else
- {
- if (ffebld_op (low) == FFEBLD_opANY)
- return FALSE;
-
- assert (ffebld_op (low) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (low))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (low))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- lowbound
- = ffebld_constant_integerdefault (ffebld_conter (low));
- }
-
- if (ffebld_op (high) == FFEBLD_opANY)
- return FALSE;
-
- assert (ffebld_op (high) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (high))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (high))
- == FFEINFO_kindtypeINTEGER1);
- highbound
- = ffebld_constant_integerdefault (ffebld_conter (high));
-
- if ((arrayval < lowbound) || (arrayval > highbound))
- {
- char rankstr[10];
-
- sprintf (rankstr, "%d", rank);
- ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
- ffebad_string (ffesymbol_text (sym));
- ffebad_string (rankstr);
- ffebad_finish ();
- }
-
- subscripts = ffebld_trail (subscripts);
- dims = ffebld_trail (dims);
-
- value += width * (arrayval - lowbound);
- if (subscripts != NULL)
- width *= highbound - lowbound + 1;
- }
-
- if (dims != NULL)
- {
- ffebad_start (FFEBAD_EQUIV_FEW);
- ffebad_string (ffesymbol_text (sym));
- ffebad_finish ();
- return FALSE;
- }
-
- expr = symexp;
- }
- goto again; /* :::::::::::::::::::: */
-
- case FFEBLD_opSUBSTR:
- {
- ffebld begin = ffebld_head (ffebld_right (expr));
-
- expr = ffebld_left (expr);
- if (ffebld_op (expr) == FFEBLD_opANY)
- return FALSE;
- if (ffebld_op (expr) == FFEBLD_opARRAYREF)
- sym = ffebld_symter (ffebld_left (expr));
- else if (ffebld_op (expr) == FFEBLD_opSYMTER)
- sym = ffebld_symter (expr);
- else
- sym = NULL;
-
- if ((sym != NULL)
- && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
- return FALSE;
-
- if (begin == NULL)
- value = 0;
- else
- {
- if (ffebld_op (begin) == FFEBLD_opANY)
- return FALSE;
- assert (ffebld_op (begin) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (begin))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (begin))
- == FFEINFO_kindtypeINTEGERDEFAULT);
-
- value = ffebld_constant_integerdefault (ffebld_conter (begin));
-
- if ((value < 1)
- || ((sym != NULL)
- && (value > ffesymbol_size (sym))))
- {
- ffebad_start (FFEBAD_EQUIV_RANGE);
- ffebad_string (ffesymbol_text (sym));
- ffebad_finish ();
- }
-
- --value;
- }
- if ((sym != NULL)
- && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
- {
- ffebad_start (FFEBAD_EQUIV_SUBSTR);
- ffebad_string (ffesymbol_text (sym));
- ffebad_finish ();
- value = 0;
- }
- }
- goto again; /* :::::::::::::::::::: */
-
- default:
- assert ("bad op" == NULL);
- return FALSE;
- }
-
-}
-
-/* ffeequiv_add -- Add list of equivalences to list of lists for eq object
-
- ffeequiv eq;
- ffebld list;
- ffelexToken t; // points to first item in equivalence list
- ffeequiv_add(eq,list,t);
-
- Check the list to make sure only one common symbol is involved (even
- if multiple times) and agrees with the common symbol for the equivalence
- object (or it has no common symbol until now). Prepend (or append, it
- doesn't matter) the list to the list of lists for the equivalence object.
- Otherwise report an error and return. */
-
-void
-ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
-{
- ffebld item;
- ffesymbol symbol;
- ffesymbol common = ffeequiv_common (eq);
-
- for (item = list; item != NULL; item = ffebld_trail (item))
- {
- symbol = ffeequiv_symbol (ffebld_head (item));
-
- if (ffesymbol_common (symbol) != NULL) /* Is symbol known in COMMON yet? */
- {
- if (common == NULL)
- common = ffesymbol_common (symbol);
- else if (common != ffesymbol_common (symbol))
- {
- /* Yes, and symbol disagrees with others on the COMMON area. */
- ffebad_start (FFEBAD_EQUIV_COMMON);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_string (ffesymbol_text (common));
- ffebad_string (ffesymbol_text (ffesymbol_common (symbol)));
- ffebad_finish ();
- return;
- }
- }
- }
-
- if ((common != NULL)
- && (ffeequiv_common (eq) == NULL)) /* Is COMMON involved already? */
- ffeequiv_set_common (eq, common); /* No, but it is now. */
-
- for (item = list; item != NULL; item = ffebld_trail (item))
- {
- symbol = ffeequiv_symbol (ffebld_head (item));
-
- if (ffesymbol_equiv (symbol) == NULL)
- ffesymbol_set_equiv (symbol, eq);
- else
- assert (ffesymbol_equiv (symbol) == eq);
-
- if (ffesymbol_common (symbol) == NULL) /* Is symbol in a COMMON
- area? */
- { /* No (at least not yet). */
- if (ffesymbol_is_save (symbol))
- ffeequiv_update_save (eq); /* EQUIVALENCE has >=1 SAVEd entity. */
- if (ffesymbol_is_init (symbol))
- ffeequiv_update_init (eq); /* EQUIVALENCE has >=1 init'd entity. */
- continue; /* Nothing more to do here. */
- }
-
-#if FFEGLOBAL_ENABLED
- if (ffesymbol_is_init (symbol))
- ffeglobal_init_common (ffesymbol_common (symbol), t);
-#endif
-
- if (ffesymbol_is_save (ffesymbol_common (symbol)))
- ffeequiv_update_save (eq); /* EQUIVALENCE is in a SAVEd COMMON block. */
- if (ffesymbol_is_init (ffesymbol_common (symbol)))
- ffeequiv_update_init (eq); /* EQUIVALENCE is in a init'd COMMON block. */
- }
-
- ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
-}
-
-/* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects
-
- ffeequiv_exec_transition(); */
-
-void
-ffeequiv_exec_transition (void)
-{
- while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
- ffeequiv_layout_local_ (ffeequiv_list_.first);
-}
-
-/* ffeequiv_init_2 -- Initialize for new program unit
-
- ffeequiv_init_2();
-
- Initializes the list of equivalences. */
-
-void
-ffeequiv_init_2 (void)
-{
- ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
- ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
-}
-
-/* ffeequiv_kill -- Kill equivalence object after removing from list
-
- ffeequiv eq;
- ffeequiv_kill(eq);
-
- Removes equivalence object from master list, then kills it. */
-
-void
-ffeequiv_kill (ffeequiv victim)
-{
- victim->next->previous = victim->previous;
- victim->previous->next = victim->next;
- if (ffe_is_do_internal_checks ())
- {
- ffebld list;
- ffebld item;
- ffebld expr;
-
- /* Assert that nobody our victim points to still points to it. */
-
- assert ((victim->common == NULL)
- || (ffesymbol_equiv (victim->common) == NULL));
-
- for (list = victim->list; list != NULL; list = ffebld_trail (list))
- {
- for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
- {
- ffesymbol sym;
-
- expr = ffebld_head (item);
- sym = ffeequiv_symbol (expr);
- if (sym == NULL)
- continue;
- assert (ffesymbol_equiv (sym) != victim);
- }
- }
- }
- malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
-}
-
-/* ffeequiv_layout_cblock -- Lay out storage for common area
-
- ffestorag st;
- if (ffeequiv_layout_cblock(st))
- // at least one equiv'd symbol has init/accretion expr.
-
- Now that the explicitly COMMONed variables in the common area (whose
- ffestorag object is passed) have been laid out, lay out the storage
- for all variables equivalenced into the area by making subordinate
- ffestorag objects for them. */
-
-bool
-ffeequiv_layout_cblock (ffestorag st)
-{
- ffesymbol s = ffestorag_symbol (st); /* CBLOCK symbol. */
- ffebld list; /* List of explicit common vars, in order, in
- s. */
- ffebld item; /* List of list of equivalences in a given
- explicit common var. */
- ffebld root; /* Expression for (1st) explicit common var
- in list of eqs. */
- ffestorag rst; /* Storage for root. */
- ffetargetOffset root_offset; /* Offset for root into common area. */
- ffesymbol sr; /* Root itself. */
- ffeequiv seq; /* Its equivalence object, if any. */
- ffebld var; /* Expression for equivalence. */
- ffestorag vst; /* Storage for var. */
- ffetargetOffset var_offset; /* Offset for var into common area. */
- ffesymbol sv; /* Var itself. */
- ffebld altroot; /* Alternate root. */
- ffesymbol altrootsym; /* Alternate root symbol. */
- ffetargetAlign alignment;
- ffetargetAlign modulo;
- ffetargetAlign pad;
- ffetargetOffset size;
- ffetargetOffset num_elements;
- bool new_storage; /* Established new storage info. */
- bool need_storage; /* Have need for more storage info. */
- bool ok;
- bool init = FALSE;
-
- assert (st != NULL);
- assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK);
- assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON);
-
- for (list = ffesymbol_commonlist (ffestorag_symbol (st));
- list != NULL;
- list = ffebld_trail (list))
- { /* For every variable in the common area */
- assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
- sr = ffebld_symter (ffebld_head (list));
- if ((seq = ffesymbol_equiv (sr)) == NULL)
- continue; /* No equivalences to process. */
- rst = ffesymbol_storage (sr);
- if (rst == NULL)
- {
- assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
- continue;
- }
- ffesymbol_set_equiv (sr, NULL); /* Cancel ref to equiv obj. */
- do
- {
- new_storage = FALSE;
- need_storage = FALSE;
- for (item = ffeequiv_list (seq); /* Get list of equivs. */
- item != NULL;
- item = ffebld_trail (item))
- { /* For every eqv list in the list of equivs
- for the variable */
- altroot = NULL;
- altrootsym = NULL;
- for (root = ffebld_head (item);
- root != NULL;
- root = ffebld_trail (root))
- { /* For every equivalence item in the list */
- sv = ffeequiv_symbol (ffebld_head (root));
- if (sv == sr)
- break; /* Found first mention of "rooted" symbol. */
- if (ffesymbol_storage (sv) != NULL)
- {
- altroot = root; /* If no mention, use this guy
- instead. */
- altrootsym = sv;
- }
- }
- if (root != NULL)
- {
- root = ffebld_head (root); /* Lose its opITEM. */
- ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
- ffestorag_offset (rst), TRUE);
- /* Equiv point prior to start of common area? */
- }
- else if (altroot != NULL)
- {
- /* Equiv point prior to start of common area? */
- root = ffebld_head (altroot);
- ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
- FALSE,
- ffestorag_offset (ffesymbol_storage (altrootsym)),
- TRUE);
- ffesymbol_set_equiv (altrootsym, NULL);
- }
- else
- /* No rooted symbol in list of equivalences! */
- { /* Assume this was due to opANY and ignore
- this list for now. */
- need_storage = TRUE;
- continue;
- }
-
- /* We now know the root symbol and the operating offset of that
- root into the common area. The other expressions in the
- list all identify an initial storage unit that must have the
- same offset. */
-
- for (var = ffebld_head (item);
- var != NULL;
- var = ffebld_trail (var))
- { /* For every equivalence item in the list */
- if (ffebld_head (var) == root)
- continue; /* Except root, of course. */
- sv = ffeequiv_symbol (ffebld_head (var));
- if (sv == NULL)
- continue; /* Except erroneous stuff (opANY). */
- ffesymbol_set_equiv (sv, NULL); /* Don't need this ref
- anymore. */
- if (!ok
- || !ffeequiv_offset_ (&var_offset, sv,
- ffebld_head (var), TRUE,
- root_offset, TRUE))
- continue; /* Can't do negative offset wrt COMMON. */
-
- if (ffesymbol_rank (sv) == 0)
- num_elements = 1;
- else
- num_elements = ffebld_constant_integerdefault
- (ffebld_conter (ffesymbol_arraysize (sv)));
- ffetarget_layout (ffesymbol_text (sv), &alignment,
- &modulo, &size,
- ffesymbol_basictype (sv),
- ffesymbol_kindtype (sv),
- ffesymbol_size (sv), num_elements);
- pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
- ffestorag_ptr_to_modulo (st),
- var_offset, alignment, modulo);
- if (pad != 0)
- {
- ffebad_start (FFEBAD_EQUIV_ALIGN);
- ffebad_string (ffesymbol_text (sv));
- ffebad_finish ();
- continue;
- }
-
- if ((vst = ffesymbol_storage (sv)) == NULL)
- { /* Create new ffestorag object, extend
- cblock. */
- new_storage = TRUE;
- vst = ffestorag_new (ffestorag_list_equivs (st));
- ffestorag_set_parent (vst, st); /* Initializations
- happen there. */
- ffestorag_set_init (vst, NULL);
- ffestorag_set_accretion (vst, NULL);
- ffestorag_set_symbol (vst, sv);
- ffestorag_set_size (vst, size);
- ffestorag_set_offset (vst, var_offset);
- ffestorag_set_alignment (vst, alignment);
- ffestorag_set_modulo (vst, modulo);
- ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
- ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
- ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
- ffestorag_set_typesymbol (vst, sv);
- ffestorag_set_is_save (vst, FALSE); /* Assume FALSE... */
- if (ffestorag_is_save (st)) /* ...update TRUE */
- ffestorag_update_save (vst); /* if needed. */
- ffestorag_set_is_init (vst, FALSE); /* Assume FALSE... */
- if (ffestorag_is_init (st)) /* ...update TRUE */
- ffestorag_update_init (vst); /* if needed. */
- if (!ffetarget_offset_add (&size, var_offset, size))
- /* Find one size of common block, complain if
- overflow. */
- ffetarget_offset_overflow (ffesymbol_text (s));
- else if (size > ffestorag_size (st))
- /* Extend common. */
- ffestorag_set_size (st, size);
- ffesymbol_set_storage (sv, vst);
- ffesymbol_set_common (sv, s);
- ffesymbol_signal_unreported (sv);
- ffestorag_update (st, sv, ffesymbol_basictype (sv),
- ffesymbol_kindtype (sv));
- if (ffesymbol_is_init (sv))
- init = TRUE;
- }
- else
- {
- /* Make sure offset agrees with known offset. */
- if (var_offset != ffestorag_offset (vst))
- {
- char io1[40];
- char io2[40];
-
- sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset);
- sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst));
- ffebad_start (FFEBAD_EQUIV_MISMATCH);
- ffebad_string (ffesymbol_text (sv));
- ffebad_string (ffesymbol_text (s));
- ffebad_string (io1);
- ffebad_string (io2);
- ffebad_finish ();
- }
- }
- } /* (For every equivalence item in the list) */
- } /* (For every eqv list in the list of equivs
- for the variable) */
- }
- while (new_storage && need_storage);
-
- ffeequiv_kill (seq); /* Kill equiv obj. */
- } /* (For every variable in the common area) */
-
- return init;
-}
-
-/* ffeequiv_merge -- Merge two equivalence objects, return the merged result
-
- ffeequiv eq1;
- ffeequiv eq2;
- ffelexToken t; // points to current equivalence item forcing the merge.
- eq1 = ffeequiv_merge(eq1,eq2,t);
-
- If the two equivalence objects can be merged, they are, all the
- ffesymbols in their lists of lists are adjusted to point to the merged
- equivalence object, and the merged object is returned.
-
- Otherwise, the two equivalence objects have different non-NULL common
- symbols, so the merge cannot take place. An error message is issued and
- NULL is returned. */
-
-ffeequiv
-ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
-{
- ffebld list;
- ffebld eqs;
- ffesymbol symbol;
- ffebld last = NULL;
-
- /* If both equivalence objects point to different common-based symbols,
- complain. Of course, one or both might have NULL common symbols now,
- and get COMMONed later, but the COMMON statement handler checks for
- this. */
-
- if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL)
- && (ffeequiv_common (eq1) != ffeequiv_common (eq2)))
- {
- ffebad_start (FFEBAD_EQUIV_COMMON);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_string (ffesymbol_text (ffeequiv_common (eq1)));
- ffebad_string (ffesymbol_text (ffeequiv_common (eq2)));
- ffebad_finish ();
- return NULL;
- }
-
- /* Make eq1 the new, merged object (arbitrarily). */
-
- if (ffeequiv_common (eq1) == NULL)
- ffeequiv_set_common (eq1, ffeequiv_common (eq2));
-
- /* If the victim object has any init'ed entities, so does the new object. */
-
- if (eq2->is_init)
- eq1->is_init = TRUE;
-
-#if FFEGLOBAL_ENABLED
- if (eq1->is_init && (ffeequiv_common (eq1) != NULL))
- ffeglobal_init_common (ffeequiv_common (eq1), t);
-#endif
-
- /* If the victim object has any SAVEd entities, then the new object has
- some. */
-
- if (ffeequiv_is_save (eq2))
- ffeequiv_update_save (eq1);
-
- /* If the victim object has any init'd entities, then the new object has
- some. */
-
- if (ffeequiv_is_init (eq2))
- ffeequiv_update_init (eq1);
-
- /* Adjust all the symbols in the list of lists of equivalences for the
- victim equivalence object so they point to the new merged object
- instead. */
-
- for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list))
- {
- for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs))
- {
- symbol = ffeequiv_symbol (ffebld_head (eqs));
- if (ffesymbol_equiv (symbol) == eq2)
- ffesymbol_set_equiv (symbol, eq1);
- else
- assert (ffesymbol_equiv (symbol) == eq1); /* Can see a sym > once. */
- }
-
- /* For convenience, remember where the last ITEM in the outer list is. */
-
- if (ffebld_trail (list) == NULL)
- {
- last = list;
- break;
- }
- }
-
- /* Append the list of lists in the new, merged object to the list of lists
- in the victim object, then use the new combined list in the new merged
- object. */
-
- ffebld_set_trail (last, ffeequiv_list (eq1));
- ffeequiv_set_list (eq1, ffeequiv_list (eq2));
-
- /* Unlink and kill the victim object. */
-
- ffeequiv_kill (eq2);
-
- return eq1; /* Return the new merged object. */
-}
-
-/* ffeequiv_new -- Create new equivalence object, put in list
-
- ffeequiv eq;
- eq = ffeequiv_new();
-
- Creates a new equivalence object and adds it to the list of equivalence
- objects. */
-
-ffeequiv
-ffeequiv_new (void)
-{
- ffeequiv eq;
-
- eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq));
- eq->next = (ffeequiv) &ffeequiv_list_.first;
- eq->previous = ffeequiv_list_.last;
- ffeequiv_set_common (eq, NULL); /* No COMMON area yet. */
- ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */
- ffeequiv_set_is_save (eq, FALSE);
- ffeequiv_set_is_init (eq, FALSE);
- eq->next->previous = eq;
- eq->previous->next = eq;
-
- return eq;
-}
-
-/* ffeequiv_symbol -- Return symbol for equivalence expression
-
- ffesymbol symbol;
- ffebld expr;
- symbol = ffeequiv_symbol(expr);
-
- Finds the terminal SYMTER in an equivalence expression and returns the
- ffesymbol for it. */
-
-ffesymbol
-ffeequiv_symbol (ffebld expr)
-{
- assert (expr != NULL);
-
-again: /* :::::::::::::::::::: */
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opARRAYREF:
- case FFEBLD_opSUBSTR:
- expr = ffebld_left (expr);
- goto again; /* :::::::::::::::::::: */
-
- case FFEBLD_opSYMTER:
- return ffebld_symter (expr);
-
- case FFEBLD_opANY:
- return NULL;
-
- default:
- assert ("bad eq expr" == NULL);
- return NULL;
- }
-}
-
-/* ffeequiv_update_init -- Update the INIT flag for the area to TRUE
-
- ffeequiv eq;
- ffeequiv_update_init(eq);
-
- If the INIT flag for the <eq> object is already set, return. Else,
- set it TRUE and call ffe*_update_init for all objects contained in
- this one. */
-
-void
-ffeequiv_update_init (ffeequiv eq)
-{
- ffebld list; /* Current list in list of lists. */
- ffebld item; /* Current item in current list. */
- ffebld expr; /* Expression in head of current item. */
-
- if (eq->is_init)
- return;
-
- eq->is_init = TRUE;
-
- if ((eq->common != NULL)
- && !ffesymbol_is_init (eq->common))
- ffesymbol_update_init (eq->common); /* Shouldn't be needed. */
-
- for (list = eq->list; list != NULL; list = ffebld_trail (list))
- {
- for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
- {
- expr = ffebld_head (item);
-
- again: /* :::::::::::::::::::: */
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opANY:
- break;
-
- case FFEBLD_opSYMTER:
- if (!ffesymbol_is_init (ffebld_symter (expr)))
- ffesymbol_update_init (ffebld_symter (expr));
- break;
-
- case FFEBLD_opARRAYREF:
- expr = ffebld_left (expr);
- goto again; /* :::::::::::::::::::: */
-
- case FFEBLD_opSUBSTR:
- expr = ffebld_left (expr);
- goto again; /* :::::::::::::::::::: */
-
- default:
- assert ("bad op for ffeequiv_update_init" == NULL);
- break;
- }
- }
- }
-}
-
-/* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE
-
- ffeequiv eq;
- ffeequiv_update_save(eq);
-
- If the SAVE flag for the <eq> object is already set, return. Else,
- set it TRUE and call ffe*_update_save for all objects contained in
- this one. */
-
-void
-ffeequiv_update_save (ffeequiv eq)
-{
- ffebld list; /* Current list in list of lists. */
- ffebld item; /* Current item in current list. */
- ffebld expr; /* Expression in head of current item. */
-
- if (eq->is_save)
- return;
-
- eq->is_save = TRUE;
-
- if ((eq->common != NULL)
- && !ffesymbol_is_save (eq->common))
- ffesymbol_update_save (eq->common); /* Shouldn't be needed. */
-
- for (list = eq->list; list != NULL; list = ffebld_trail (list))
- {
- for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
- {
- expr = ffebld_head (item);
-
- again: /* :::::::::::::::::::: */
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opANY:
- break;
-
- case FFEBLD_opSYMTER:
- if (!ffesymbol_is_save (ffebld_symter (expr)))
- ffesymbol_update_save (ffebld_symter (expr));
- break;
-
- case FFEBLD_opARRAYREF:
- expr = ffebld_left (expr);
- goto again; /* :::::::::::::::::::: */
-
- case FFEBLD_opSUBSTR:
- expr = ffebld_left (expr);
- goto again; /* :::::::::::::::::::: */
-
- default:
- assert ("bad op for ffeequiv_update_save" == NULL);
- break;
- }
- }
- }
-}
+++ /dev/null
-/* equiv.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 1996 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- equiv.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_EQUIV_H
-#define GCC_F_EQUIV_H
-
-/* Simple definitions and enumerations. */
-
-
-/* Typedefs. */
-
-typedef struct _ffeequiv_ *ffeequiv;
-
-/* Include files needed by this one. */
-
-#include "bld.h"
-#include "lex.h"
-#include "storag.h"
-#include "symbol.h"
-
-/* Structure definitions. */
-
-struct _ffeequiv_
- {
- ffeequiv next;
- ffeequiv previous;
- ffesymbol common; /* Common area for this equiv, if any. */
- ffebld list; /* List of lists of equiv exprs. */
- bool is_save; /* Any SAVEd members? */
- bool is_init; /* Any initialized members? */
- };
-
-/* Global objects accessed by users of this module. */
-
-
-/* Declare functions with prototypes. */
-
-void ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t);
-void ffeequiv_exec_transition (void);
-void ffeequiv_init_2 (void);
-void ffeequiv_kill (ffeequiv victim);
-bool ffeequiv_layout_cblock (ffestorag st);
-ffeequiv ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t);
-ffeequiv ffeequiv_new (void);
-ffesymbol ffeequiv_symbol (ffebld expr);
-void ffeequiv_update_init (ffeequiv eq);
-void ffeequiv_update_save (ffeequiv eq);
-
-/* Define macros. */
-
-#define ffeequiv_common(e) ((e)->common)
-#define ffeequiv_init_0()
-#define ffeequiv_init_1()
-#define ffeequiv_init_3()
-#define ffeequiv_init_4()
-#define ffeequiv_is_init(e) ((e)->is_init)
-#define ffeequiv_is_save(e) ((e)->is_save)
-#define ffeequiv_list(e) ((e)->list)
-#define ffeequiv_next(e) ((e)->next)
-#define ffeequiv_previous(e) ((e)->previous)
-#define ffeequiv_set_common(e,c) ((e)->common = (c))
-#define ffeequiv_set_init(e,i) ((e)->init = (i))
-#define ffeequiv_set_is_init(e,in) ((e)->is_init = (in))
-#define ffeequiv_set_is_save(e,sa) ((e)->is_save = (sa))
-#define ffeequiv_set_list(e,l) ((e)->list = (l))
-#define ffeequiv_terminate_0()
-#define ffeequiv_terminate_1()
-#define ffeequiv_terminate_2()
-#define ffeequiv_terminate_3()
-#define ffeequiv_terminate_4()
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_EQUIV_H */
+++ /dev/null
-/* expr.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
- Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None.
-
- Description:
- Handles syntactic and semantic analysis of Fortran expressions.
-
- Modifications:
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "expr.h"
-#include "bad.h"
-#include "bld.h"
-#include "com.h"
-#include "global.h"
-#include "implic.h"
-#include "intrin.h"
-#include "info.h"
-#include "lex.h"
-#include "malloc.h"
-#include "src.h"
-#include "st.h"
-#include "symbol.h"
-#include "str.h"
-#include "target.h"
-#include "where.h"
-#include "real.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFEEXPR_exprtypeUNKNOWN_,
- FFEEXPR_exprtypeOPERAND_,
- FFEEXPR_exprtypeUNARY_,
- FFEEXPR_exprtypeBINARY_,
- FFEEXPR_exprtype_
- } ffeexprExprtype_;
-
-typedef enum
- {
- FFEEXPR_operatorPOWER_,
- FFEEXPR_operatorMULTIPLY_,
- FFEEXPR_operatorDIVIDE_,
- FFEEXPR_operatorADD_,
- FFEEXPR_operatorSUBTRACT_,
- FFEEXPR_operatorCONCATENATE_,
- FFEEXPR_operatorLT_,
- FFEEXPR_operatorLE_,
- FFEEXPR_operatorEQ_,
- FFEEXPR_operatorNE_,
- FFEEXPR_operatorGT_,
- FFEEXPR_operatorGE_,
- FFEEXPR_operatorNOT_,
- FFEEXPR_operatorAND_,
- FFEEXPR_operatorOR_,
- FFEEXPR_operatorXOR_,
- FFEEXPR_operatorEQV_,
- FFEEXPR_operatorNEQV_,
- FFEEXPR_operator_
- } ffeexprOperator_;
-
-typedef enum
- {
- FFEEXPR_operatorprecedenceHIGHEST_ = 1,
- FFEEXPR_operatorprecedencePOWER_ = 1,
- FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
- FFEEXPR_operatorprecedenceDIVIDE_ = 2,
- FFEEXPR_operatorprecedenceADD_ = 3,
- FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
- FFEEXPR_operatorprecedenceLOWARITH_ = 3,
- FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
- FFEEXPR_operatorprecedenceLT_ = 4,
- FFEEXPR_operatorprecedenceLE_ = 4,
- FFEEXPR_operatorprecedenceEQ_ = 4,
- FFEEXPR_operatorprecedenceNE_ = 4,
- FFEEXPR_operatorprecedenceGT_ = 4,
- FFEEXPR_operatorprecedenceGE_ = 4,
- FFEEXPR_operatorprecedenceNOT_ = 5,
- FFEEXPR_operatorprecedenceAND_ = 6,
- FFEEXPR_operatorprecedenceOR_ = 7,
- FFEEXPR_operatorprecedenceXOR_ = 8,
- FFEEXPR_operatorprecedenceEQV_ = 8,
- FFEEXPR_operatorprecedenceNEQV_ = 8,
- FFEEXPR_operatorprecedenceLOWEST_ = 8,
- FFEEXPR_operatorprecedence_
- } ffeexprOperatorPrecedence_;
-
-#define FFEEXPR_operatorassociativityL2R_ TRUE
-#define FFEEXPR_operatorassociativityR2L_ FALSE
-#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
-#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
-
-typedef enum
- {
- FFEEXPR_parentypeFUNCTION_,
- FFEEXPR_parentypeSUBROUTINE_,
- FFEEXPR_parentypeARRAY_,
- FFEEXPR_parentypeSUBSTRING_,
- FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
- FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
- FFEEXPR_parentypeANY_, /* Allow basically anything. */
- FFEEXPR_parentype_
- } ffeexprParenType_;
-
-typedef enum
- {
- FFEEXPR_percentNONE_,
- FFEEXPR_percentLOC_,
- FFEEXPR_percentVAL_,
- FFEEXPR_percentREF_,
- FFEEXPR_percentDESCR_,
- FFEEXPR_percent_
- } ffeexprPercent_;
-
-/* Internal typedefs. */
-
-typedef struct _ffeexpr_expr_ *ffeexprExpr_;
-typedef bool ffeexprOperatorAssociativity_;
-typedef struct _ffeexpr_stack_ *ffeexprStack_;
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-struct _ffeexpr_expr_
- {
- ffeexprExpr_ previous;
- ffelexToken token;
- ffeexprExprtype_ type;
- union
- {
- struct
- {
- ffeexprOperator_ op;
- ffeexprOperatorPrecedence_ prec;
- ffeexprOperatorAssociativity_ as;
- }
- operator;
- ffebld operand;
- }
- u;
- };
-
-struct _ffeexpr_stack_
- {
- ffeexprStack_ previous;
- mallocPool pool;
- ffeexprContext context;
- ffeexprCallback callback;
- ffelexToken first_token;
- ffeexprExpr_ exprstack;
- ffelexToken tokens[10]; /* Used in certain cases, like (unary)
- open-paren. */
- ffebld expr; /* For first of
- complex/implied-do/substring/array-elements
- / actual-args expression. */
- ffebld bound_list; /* For tracking dimension bounds list of
- array. */
- ffebldListBottom bottom; /* For building lists. */
- ffeinfoRank rank; /* For elements in an array reference. */
- bool constant; /* TRUE while elements seen so far are
- constants. */
- bool immediate; /* TRUE while elements seen so far are
- immediate/constants. */
- ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
- ffebldListLength num_args; /* Number of dummy args expected in arg list. */
- bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
- ffeexprPercent_ percent; /* Current %FOO keyword. */
- };
-
-struct _ffeexpr_find_
- {
- ffelexToken t;
- ffelexHandler after;
- int level;
- };
-
-/* Static objects accessed by functions in this module. */
-
-static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
-static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
-static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
-static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
-static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
-static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
-static struct _ffeexpr_find_ ffeexpr_find_;
-
-/* Static functions (internal). */
-
-static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
- ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
- ffebld expr, ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
- ffebld expr, ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
-static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
-static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
-static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
- ffebld dovar, ffelexToken dovar_t);
-static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
-static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
-static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
-static ffeexprExpr_ ffeexpr_expr_new_ (void);
-static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
-static bool ffeexpr_isdigits_ (const char *p);
-static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
-static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
-static void ffeexpr_reduce_ (void);
-static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
- ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
- ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
- ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r,
- bool *);
-static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
- ffelexHandler after);
-static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
-static ffelexHandler ffeexpr_finished_ (ffelexToken t);
-static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
-static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
- ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
- ffelexToken exponent_sign, ffelexToken exponent_digits);
-static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
-static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
- bool maybe_intrin,
- ffeexprParenType_ *paren_type);
-static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
-
-/* Internal macros. */
-
-#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
-#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
-\f
-/* ffeexpr_collapse_convert -- Collapse convert expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_convert(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize sz;
- ffetargetCharacterSize sz2;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_integer1_integer2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_integer1_integer3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_integer1_integer4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer1_real1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer1_real2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer1_real3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer1_complex1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer1_complex2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer1_complex3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer1_logical1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer1_logical2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer1_logical3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer1_logical4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer1_character1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer1_hollerith
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer1_typeless
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_integer2_integer1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_integer2_integer3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_integer2_integer4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer2_real1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer2_real2
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer2_real3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer2_complex1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer2_complex2
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer2_complex3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer2_logical1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer2_logical2
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer2_logical3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer2_logical4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer2_character1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer2_hollerith
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer2_typeless
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_integer3_integer1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_integer3_integer2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_integer3_integer4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer3_real1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer3_real2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer3_real3
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer3_complex1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer3_complex2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer3_complex3
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer3_logical1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer3_logical2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer3_logical3
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer3_logical4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer3_character1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer3_hollerith
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer3_typeless
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_integer4_integer1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_integer4_integer2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_integer4_integer3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer4_real1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer4_real2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer4_real3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER4/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer4_complex1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer4_complex2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer4_complex3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer4_logical1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer4_logical2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer4_logical3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer4_logical4
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer4_character1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer4_hollerith
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer4_typeless
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER4 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_logical1_logical2
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_logical1_logical3
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_logical1_logical4
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical1_integer1
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical1_integer2
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical1_integer3
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical1_integer4
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical1_character1
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical1_hollerith
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical1_typeless
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_logical2_logical1
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_logical2_logical3
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_logical2_logical4
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical2_integer1
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical2_integer2
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical2_integer3
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical2_integer4
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical2_character1
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical2_hollerith
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical2_typeless
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_logical3_logical1
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_logical3_logical2
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_logical3_logical4
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical3_integer1
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical3_integer2
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical3_integer3
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical3_integer4
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical3_character1
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical3_hollerith
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical3_typeless
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_logical4_logical1
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_logical4_logical2
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_logical4_logical3
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical4_integer1
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical4_integer2
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical4_integer3
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical4_integer4
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical4_character1
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical4_hollerith
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical4_typeless
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL4 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real1_integer1
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real1_integer2
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real1_integer3
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real1_integer4
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real1_real2
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real1_real3
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL1/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real1_complex1
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real1_complex2
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real1_complex3
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL1/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real1_character1
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real1_hollerith
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real1_typeless
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real2_integer1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real2_integer2
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real2_integer3
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real2_integer4
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real2_real1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real2_real3
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL2/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real2_complex1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real2_complex2
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real2_complex3
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL2/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real2_character1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real2_hollerith
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real2_typeless
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real3_integer1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real3_integer2
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real3_integer3
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real3_integer4
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real3_real1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real3_real2
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL3/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real3_complex1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real3_complex2
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real3_complex3
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real3_character1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real3_hollerith
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real3_typeless
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex1_integer1
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex1_integer2
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex1_integer3
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex1_integer4
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex1_real1
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex1_real2
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex1_real3
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX1/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex1_complex2
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex1_complex3
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex1_character1
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex1_hollerith
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex1_typeless
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex2_integer1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex2_integer2
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex2_integer3
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex2_integer4
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex2_real1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex2_real2
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex2_real3
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX2/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex2_complex1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex2_complex3
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex2_character1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex2_hollerith
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex2_typeless
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex3_integer1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex3_integer2
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex3_integer3
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex3_integer4
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex3_real1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex3_real2
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex3_real3
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX3/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex3_complex1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex3_complex2
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex3_character1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex3_hollerith
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex3_typeless
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
- return expr;
- kt = ffeinfo_kindtype (ffebld_info (expr));
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeCHARACTER:
- if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
- return expr;
- assert (kt == ffeinfo_kindtype (ffebld_info (l)));
- assert (sz2 == ffetarget_length_character1
- (ffebld_constant_character1
- (ffebld_conter (l))));
- error
- = ffetarget_convert_character1_character1
- (ffebld_cu_ptr_character1 (u), sz,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error
- = ffetarget_convert_character1_integer1
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error
- = ffetarget_convert_character1_integer2
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error
- = ffetarget_convert_character1_integer3
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error
- = ffetarget_convert_character1_integer4
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
- default:
- assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error
- = ffetarget_convert_character1_logical1
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error
- = ffetarget_convert_character1_logical2
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error
- = ffetarget_convert_character1_logical3
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error
- = ffetarget_convert_character1_logical4
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
- default:
- assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error
- = ffetarget_convert_character1_hollerith
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_hollerith (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error
- = ffetarget_convert_character1_typeless
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_typeless (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-
- default:
- assert ("CHARACTER1 bad type" == NULL);
- }
-
- expr
- = ffebld_new_conter_with_orig
- (ffebld_constant_new_character1_val
- (ffebld_cu_val_character1 (u)),
- expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- sz));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- assert (t != NULL);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_paren -- Collapse paren expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_paren(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
-{
- ffebld r;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- bt = ffeinfo_basictype (ffebld_info (r));
- kt = ffeinfo_kindtype (ffebld_info (r));
- len = ffebld_size (r);
-
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
- expr);
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
-}
-
-/* ffeexpr_collapse_uplus -- Collapse uplus expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_uplus(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
-{
- ffebld r;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- bt = ffeinfo_basictype (ffebld_info (r));
- kt = ffeinfo_kindtype (ffebld_info (r));
- len = ffebld_size (r);
-
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
- expr);
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
-}
-
-/* ffeexpr_collapse_uminus -- Collapse uminus expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_uminus(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_not -- Collapse not expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_not(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_not (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_add -- Collapse add expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_add(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_add (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_subtract -- Collapse subtract expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_subtract(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_multiply -- Collapse multiply expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_multiply(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_divide -- Collapse divide expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_divide(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_power -- Collapse power expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_power(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_power (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
- case FFEINFO_kindtypeINTEGERDEFAULT:
- error = ffetarget_power_integerdefault_integerdefault
- (ffebld_cu_ptr_integerdefault (u),
- ffebld_constant_integerdefault (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integerdefault_val
- (ffebld_cu_val_integerdefault (u)), expr);
- break;
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
- case FFEINFO_kindtypeREALDEFAULT:
- error = ffetarget_power_realdefault_integerdefault
- (ffebld_cu_ptr_realdefault (u),
- ffebld_constant_realdefault (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_realdefault_val
- (ffebld_cu_val_realdefault (u)), expr);
- break;
-
- case FFEINFO_kindtypeREALDOUBLE:
- error = ffetarget_power_realdouble_integerdefault
- (ffebld_cu_ptr_realdouble (u),
- ffebld_constant_realdouble (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_realdouble_val
- (ffebld_cu_val_realdouble (u)), expr);
- break;
-
-#if FFETARGET_okREALQUAD
- case FFEINFO_kindtypeREALQUAD:
- error = ffetarget_power_realquad_integerdefault
- (ffebld_cu_ptr_realquad (u),
- ffebld_constant_realquad (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_realquad_val
- (ffebld_cu_val_realquad (u)), expr);
- break;
-#endif
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
- case FFEINFO_kindtypeREALDEFAULT:
- error = ffetarget_power_complexdefault_integerdefault
- (ffebld_cu_ptr_complexdefault (u),
- ffebld_constant_complexdefault (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complexdefault_val
- (ffebld_cu_val_complexdefault (u)), expr);
- break;
-
-#if FFETARGET_okCOMPLEXDOUBLE
- case FFEINFO_kindtypeREALDOUBLE:
- error = ffetarget_power_complexdouble_integerdefault
- (ffebld_cu_ptr_complexdouble (u),
- ffebld_constant_complexdouble (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complexdouble_val
- (ffebld_cu_val_complexdouble (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEXQUAD
- case FFEINFO_kindtypeREALQUAD:
- error = ffetarget_power_complexquad_integerdefault
- (ffebld_cu_ptr_complexquad (u),
- ffebld_constant_complexquad (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complexquad_val
- (ffebld_cu_val_complexquad (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_concatenate -- Collapse concatenate expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_concatenate(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
- (ffebld_cu_val_character1 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeCHARACTER,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_eq -- Collapse eq expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_eq(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_eq_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_eq_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_eq_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_eq_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_eq_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_eq_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_eq_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_eq_complex1 (&val,
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_eq_complex2 (&val,
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_eq_complex3 (&val,
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_eq_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_ne -- Collapse ne expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_ne(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_ne_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_ne_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_ne_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_ne_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_ne_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_ne_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_ne_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_ne_complex1 (&val,
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_ne_complex2 (&val,
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_ne_complex3 (&val,
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_ne_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_ge -- Collapse ge expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_ge(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_ge_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_ge_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_ge_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_ge_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_ge_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_ge_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_ge_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_ge_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_gt -- Collapse gt expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_gt(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_gt_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_gt_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_gt_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_gt_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_gt_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_gt_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_gt_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_gt_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_le -- Collapse le expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_le(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_le (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_le_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_le_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_le_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_le_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_le_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_le_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_le_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_le_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_lt -- Collapse lt expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_lt(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_lt_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_lt_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_lt_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_lt_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_lt_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_lt_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_lt_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_lt_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_and -- Collapse and expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_and(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_and (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_or -- Collapse or expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_or(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_or (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_xor -- Collapse xor expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_xor(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_eqv -- Collapse eqv expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_eqv(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_neqv -- Collapse neqv expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_neqv(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_symter -- Collapse symter expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_symter(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
-{
- ffebld r;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
- return expr; /* A PARAMETER lhs in progress. */
-
- switch (ffebld_op (r))
- {
- case FFEBLD_opCONTER:
- break;
-
- case FFEBLD_opANY:
- return r;
-
- default:
- return expr;
- }
-
- bt = ffeinfo_basictype (ffebld_info (r));
- kt = ffeinfo_kindtype (ffebld_info (r));
- len = ffebld_size (r);
-
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
- expr);
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
-}
-
-/* ffeexpr_collapse_funcref -- Collapse funcref expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_funcref(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
-{
- return expr; /* ~~someday go ahead and collapse these,
- though not required */
-}
-
-/* ffeexpr_collapse_arrayref -- Collapse arrayref expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_arrayref(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
-{
- return expr;
-}
-
-/* ffeexpr_collapse_substr -- Collapse substr expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_substr(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebld start;
- ffebld stop;
- ffebldConstantUnion u;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
- ffetargetIntegerDefault first;
- ffetargetIntegerDefault last;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr); /* opITEM. */
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
-
- kt = ffeinfo_kindtype (ffebld_info (l));
- len = ffebld_size (l);
-
- start = ffebld_head (r);
- stop = ffebld_head (ffebld_trail (r));
- if (start == NULL)
- first = 1;
- else
- {
- if ((ffebld_op (start) != FFEBLD_opCONTER)
- || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (start))
- != FFEINFO_kindtypeINTEGERDEFAULT))
- return expr;
- first = ffebld_constant_integerdefault (ffebld_conter (start));
- }
- if (stop == NULL)
- last = len;
- else
- {
- if ((ffebld_op (stop) != FFEBLD_opCONTER)
- || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (stop))
- != FFEINFO_kindtypeINTEGERDEFAULT))
- return expr;
- last = ffebld_constant_integerdefault (ffebld_conter (stop));
- }
-
- /* Handle problems that should have already been diagnosed, but
- left in the expression tree. */
-
- if (first <= 0)
- first = 1;
- if (last < first)
- last = first + len - 1;
-
- if ((first == 1) && (last == len))
- { /* Same as original. */
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy
- (ffebld_conter (l)), expr);
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeCHARACTER,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
- }
-
- switch (ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
- ffebld_constant_character1 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
- (ffebld_cu_val_character1 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeCHARACTER,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_convert -- Convert source expression to given type
-
- ffebld source;
- ffelexToken source_token;
- ffelexToken dest_token; // Any appropriate token for "destination".
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharactersize sz;
- ffeexprContext context; // Mainly LET or DATA.
- source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
-
- If the expression conforms, returns the source expression. Otherwise
- returns source wrapped in a convert node doing the conversion, or
- ANY wrapped in convert if there is a conversion error (and issues an
- error message). Be sensitive to the context for certain aspects of
- the conversion. */
-
-ffebld
-ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
- ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
- ffetargetCharacterSize sz, ffeexprContext context)
-{
- bool bad;
- ffeinfo info;
- ffeinfoWhere wh;
-
- info = ffebld_info (source);
- if ((bt != ffeinfo_basictype (info))
- || (kt != ffeinfo_kindtype (info))
- || (rk != 0) /* Can't convert from or to arrays yet. */
- || (ffeinfo_rank (info) != 0)
- || (sz != ffebld_size_known (source)))
-#if 0 /* Nobody seems to need this spurious CONVERT node. */
- || ((context != FFEEXPR_contextLET)
- && (bt == FFEINFO_basictypeCHARACTER)
- && (sz == FFETARGET_charactersizeNONE)))
-#endif
- {
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- bad = FALSE;
- break;
-
- case FFEINFO_basictypeINTEGER:
- bad = !ffe_is_ugly_logint ();
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = ffe_is_pedantic ()
- || !(ffe_is_ugly_init ()
- && (context == FFEEXPR_contextDATA));
- break;
-
- default:
- bad = TRUE;
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- bad = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- bad = !ffe_is_ugly_logint ();
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = ffe_is_pedantic ()
- || !(ffe_is_ugly_init ()
- && (context == FFEEXPR_contextDATA));
- break;
-
- default:
- bad = TRUE;
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- bad = FALSE;
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = TRUE;
- break;
-
- default:
- bad = TRUE;
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = (bt != FFEINFO_basictypeCHARACTER)
- && (ffe_is_pedantic ()
- || (bt != FFEINFO_basictypeINTEGER)
- || !(ffe_is_ugly_init ()
- && (context == FFEEXPR_contextDATA)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- case FFEINFO_basictypeHOLLERITH:
- bad = ffe_is_pedantic ()
- || !(ffe_is_ugly_init ()
- && ((context == FFEEXPR_contextDATA)
- || (context == FFEEXPR_contextLET)));
- break;
-
- default:
- bad = TRUE;
- break;
- }
-
- if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
- bad = TRUE;
-
- if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
- && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
- && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
- && (ffeinfo_where (info) != FFEINFO_whereANY))
- {
- if (ffebad_start (FFEBAD_BAD_TYPES))
- {
- if (dest_token == NULL)
- ffebad_here (0, ffewhere_line_unknown (),
- ffewhere_column_unknown ());
- else
- ffebad_here (0, ffelex_token_where_line (dest_token),
- ffelex_token_where_column (dest_token));
- assert (source_token != NULL);
- ffebad_here (1, ffelex_token_where_line (source_token),
- ffelex_token_where_column (source_token));
- ffebad_finish ();
- }
-
- source = ffebld_new_any ();
- ffebld_set_info (source, ffeinfo_new_any ());
- }
- else
- {
- switch (ffeinfo_where (info))
- {
- case FFEINFO_whereCONSTANT:
- wh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- wh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- wh = FFEINFO_whereFLEETING;
- break;
- }
- source = ffebld_new_convert (source);
- ffebld_set_info (source, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- wh,
- sz));
- source = ffeexpr_collapse_convert (source, source_token);
- }
- }
-
- return source;
-}
-
-/* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
-
- ffebld source;
- ffebld dest;
- ffelexToken source_token;
- ffelexToken dest_token;
- ffeexprContext context;
- source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
-
- If the expressions conform, returns the source expression. Otherwise
- returns source wrapped in a convert node doing the conversion, or
- ANY wrapped in convert if there is a conversion error (and issues an
- error message). Be sensitive to the context, such as LET or DATA. */
-
-ffebld
-ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
- ffelexToken dest_token, ffeexprContext context)
-{
- ffeinfo info;
-
- info = ffebld_info (dest);
- return ffeexpr_convert (source, source_token, dest_token,
- ffeinfo_basictype (info),
- ffeinfo_kindtype (info),
- ffeinfo_rank (info),
- ffebld_size_known (dest),
- context);
-}
-
-/* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
-
- ffebld source;
- ffesymbol dest;
- ffelexToken source_token;
- ffelexToken dest_token;
- source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
-
- If the expressions conform, returns the source expression. Otherwise
- returns source wrapped in a convert node doing the conversion, or
- ANY wrapped in convert if there is a conversion error (and issues an
- error message). */
-
-ffebld
-ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
- ffesymbol dest, ffelexToken dest_token)
-{
- return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
- ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
- FFEEXPR_contextLET);
-}
-
-/* Initializes the module. */
-
-void
-ffeexpr_init_2 (void)
-{
- ffeexpr_stack_ = NULL;
- ffeexpr_level_ = 0;
-}
-
-/* ffeexpr_lhs -- Begin processing left-hand-side-context expression
-
- Prepares cluster for delivery of lexer tokens representing an expression
- in a left-hand-side context (A in A=B, for example). ffebld is used
- to build expressions in the given pool. The appropriate lexer-token
- handling routine within ffeexpr is returned. When the end of the
- expression is detected, mycallbackroutine is called with the resulting
- single ffebld object specifying the entire expression and the first
- lexer token that is not considered part of the expression. This caller-
- supplied routine itself returns a lexer-token handling routine. Thus,
- if necessary, ffeexpr can return several tokens as end-of-expression
- tokens if it needs to scan forward more than one in any instance. */
-
-ffelexHandler
-ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
-{
- ffeexprStack_ s;
-
- ffebld_pool_push (pool);
- s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
- s->previous = ffeexpr_stack_;
- s->pool = pool;
- s->context = context;
- s->callback = callback;
- s->first_token = NULL;
- s->exprstack = NULL;
- s->is_rhs = FALSE;
- ffeexpr_stack_ = s;
- return (ffelexHandler) ffeexpr_token_first_lhs_;
-}
-
-/* ffeexpr_rhs -- Begin processing right-hand-side-context expression
-
- return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
-
- Prepares cluster for delivery of lexer tokens representing an expression
- in a right-hand-side context (B in A=B, for example). ffebld is used
- to build expressions in the given pool. The appropriate lexer-token
- handling routine within ffeexpr is returned. When the end of the
- expression is detected, mycallbackroutine is called with the resulting
- single ffebld object specifying the entire expression and the first
- lexer token that is not considered part of the expression. This caller-
- supplied routine itself returns a lexer-token handling routine. Thus,
- if necessary, ffeexpr can return several tokens as end-of-expression
- tokens if it needs to scan forward more than one in any instance. */
-
-ffelexHandler
-ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
-{
- ffeexprStack_ s;
-
- ffebld_pool_push (pool);
- s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
- s->previous = ffeexpr_stack_;
- s->pool = pool;
- s->context = context;
- s->callback = callback;
- s->first_token = NULL;
- s->exprstack = NULL;
- s->is_rhs = TRUE;
- ffeexpr_stack_ = s;
- return (ffelexHandler) ffeexpr_token_first_rhs_;
-}
-
-/* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Makes sure the end token is close-paren and swallows it, else issues
- an error message and doesn't swallow the token (passing it along instead).
- In either case wraps up subexpression construction by enclosing the
- ffebld expression in a paren. */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
-
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- {
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- ffeexpr_exprstack_push_operand_ (e);
-
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_binary_);
- }
-
- if (expr->op == FFEBLD_opIMPDO)
- {
- if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
- }
- else
- {
- expr = ffebld_new_paren (expr);
- ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
- }
-
- /* Now push the (parenthesized) expression as an operand onto the
- expression stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand = expr;
- e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
- e->token = ffeexpr_stack_->tokens[0];
- ffeexpr_exprstack_push_operand_ (e);
-
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
- with the next token in t. If the next token is possibly a binary
- operator, continue processing the outer expression. If the next
- token is COMMA, then the expression is a unit specifier, and
- parentheses should not be added to it because it surrounds the
- I/O control list that starts with the unit specifier (and continues
- on from here -- we haven't seen the CLOSE_PAREN that matches the
- OPEN_PAREN, it is up to the callback function to expect to see it
- at some point). In this case, we notify the callback function that
- the COMMA is inside, not outside, the parens by wrapping the expression
- in an opITEM (with a NULL trail) -- the callback function presumably
- unwraps it after seeing this kludgey indicator.
-
- If the next token is CLOSE_PAREN, then we go to the _1_ state to
- decide what to do with the token after that.
-
- 15-Feb-91 JCB 1.1
- Use an extra state for the CLOSE_PAREN case to make READ &co really
- work right. */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- { /* Need to see the next token before we
- decide anything. */
- ffeexpr_stack_->expr = expr;
- ffeexpr_tokens_[0] = ffelex_token_use (ft);
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
- }
-
- expr = ffeexpr_finished_ambig_ (ft, expr);
-
- /* Let the callback function handle the case where t isn't COMMA. */
-
- /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
- that preceded the expression starts a list of expressions, and the expr
- hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
- node. The callback function should extract the real expr from the head
- of this opITEM node after testing it. */
-
- expr = ffebld_new_item (expr, NULL);
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ffelex_token_kill (ffeexpr_stack_->first_token);
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- return (ffelexHandler) (*callback) (ft, expr, t);
-}
-
-/* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
-
- See ffeexpr_cb_close_paren_ambig_.
-
- We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
- with the next token in t. If the next token is possibly a binary
- operator, continue processing the outer expression. If the next
- token is COMMA, the expression is a parenthesized format specifier.
- If the next token is not EOS or SEMICOLON, then because it is not a
- binary operator (it is NAME, OPEN_PAREN, &c), the expression is
- a unit specifier, and parentheses should not be added to it because
- they surround the I/O control list that consists of only the unit
- specifier. If the next token is EOS or SEMICOLON, the statement
- must be disambiguated by looking at the type of the expression -- a
- character expression is a parenthesized format specifier, while a
- non-character expression is a unit specifier.
-
- Another issue is how to do the callback so the recipient of the
- next token knows how to handle it if it is a COMMA. In all other
- cases, disambiguation is straightforward: the same approach as the
- above is used.
-
- EXTENSION: in COMMA case, if not pedantic, use same disambiguation
- as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
- and apparently other compilers do, as well, and some code out there
- uses this "feature".
-
- 19-Feb-91 JCB 1.1
- Extend to allow COMMA as nondisambiguating by itself. Remember
- to not try and check info field for opSTAR, since that expr doesn't
- have a valid info field. */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
- these. */
- ffelexToken orig_t = ffeexpr_tokens_[1];
- ffebld expr = ffeexpr_stack_->expr;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
- if (ffe_is_pedantic ())
- goto pedantic_comma; /* :::::::::::::::::::: */
- /* Fall through. */
- case FFELEX_typeEOS: /* Ambiguous; use type of expr to
- disambiguate. */
- case FFELEX_typeSEMICOLON:
- if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
- || (ffebld_op (expr) == FFEBLD_opSTAR)
- || (ffeinfo_basictype (ffebld_info (expr))
- != FFEINFO_basictypeCHARACTER))
- break; /* Not a valid CHARACTER entity, can't be a
- format spec. */
- /* Fall through. */
- default: /* Binary op (we assume; error otherwise);
- format specifier. */
-
- pedantic_comma: /* :::::::::::::::::::: */
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILENUMAMBIG:
- ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
- break;
-
- case FFEEXPR_contextFILEUNITAMBIG:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- assert ("bad context" == NULL);
- break;
- }
-
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
- next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
- ffelex_token_kill (orig_ft);
- ffelex_token_kill (orig_t);
- return (ffelexHandler) (*next) (t);
-
- case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
- case FFELEX_typeNAME:
- break;
- }
-
- expr = ffeexpr_finished_ambig_ (orig_ft, expr);
-
- /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
- that preceded the expression starts a list of expressions, and the expr
- hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
- node. The callback function should extract the real expr from the head
- of this opITEM node after testing it. */
-
- expr = ffebld_new_item (expr, NULL);
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ffelex_token_kill (ffeexpr_stack_->first_token);
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
- ffelex_token_kill (orig_ft);
- ffelex_token_kill (orig_t);
- return (ffelexHandler) (*next) (t);
-}
-
-/* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Makes sure the end token is close-paren and swallows it, or a comma
- and handles complex/implied-do possibilities, else issues
- an error message and doesn't swallow the token (passing it along instead). */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- /* First check to see if this is a possible complex entity. It is if the
- token is a comma. */
-
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- {
- ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
- ffeexpr_stack_->expr = expr;
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
- }
-
- return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- If this token is not a comma, we have a complex constant (or an attempt
- at one), so handle it accordingly, displaying error messages if the token
- is not a close-paren. */
-
-static ffelexHandler
-ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
- ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
- ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
- ffeinfoBasictype rty = (expr == NULL)
- ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
- ffeinfoKindtype lkt;
- ffeinfoKindtype rkt;
- ffeinfoKindtype nkt;
- bool ok = TRUE;
- ffebld orig;
-
- if ((ffeexpr_stack_->expr == NULL)
- || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
- || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
- && (((ffebld_op (orig) != FFEBLD_opUMINUS)
- && (ffebld_op (orig) != FFEBLD_opUPLUS))
- || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
- || ((lty != FFEINFO_basictypeINTEGER)
- && (lty != FFEINFO_basictypeREAL)))
- {
- if ((lty != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_string ("Real");
- ffebad_finish ();
- }
- ok = FALSE;
- }
- if ((expr == NULL)
- || (ffebld_op (expr) != FFEBLD_opCONTER)
- || (((orig = ffebld_conter_orig (expr)) != NULL)
- && (((ffebld_op (orig) != FFEBLD_opUMINUS)
- && (ffebld_op (orig) != FFEBLD_opUPLUS))
- || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
- || ((rty != FFEINFO_basictypeINTEGER)
- && (rty != FFEINFO_basictypeREAL)))
- {
- if ((rty != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
- {
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string ("Imaginary");
- ffebad_finish ();
- }
- ok = FALSE;
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
-
- /* Push the (parenthesized) expression as an operand onto the expression
- stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_stack_->tokens[0];
-
- if (ok)
- {
- if (lty == FFEINFO_basictypeINTEGER)
- lkt = FFEINFO_kindtypeREALDEFAULT;
- else
- lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
- if (rty == FFEINFO_basictypeINTEGER)
- rkt = FFEINFO_kindtypeREALDEFAULT;
- else
- rkt = ffeinfo_kindtype (ffebld_info (expr));
-
- nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
- ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
- ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
- FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- expr = ffeexpr_convert (expr,
- ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
- FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- }
- else
- nkt = FFEINFO_kindtypeANY;
-
- switch (nkt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
- default:
- if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
- ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- break;
- }
- ffeexpr_exprstack_push_operand_ (e);
-
- /* Now, if the token is a close parenthese, we're in great shape so return
- the next handler. */
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_token_binary_;
-
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
-
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_binary_);
-}
-
-/* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
- implied-DO construct)
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Makes sure the end token is close-paren and swallows it, or a comma
- and handles complex/implied-do possibilities, else issues
- an error message and doesn't swallow the token (passing it along instead). */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctx;
-
- /* First check to see if this is a possible complex or implied-DO entity.
- It is if the token is a comma. */
-
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- {
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- ctx = FFEEXPR_contextIMPDOITEM_;
- break;
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctx = FFEEXPR_contextIMPDOITEMDF_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_contextIMPDOITEM_;
- break;
- }
-
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
- ffeexpr_stack_->expr = expr;
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctx, ffeexpr_cb_comma_ci_);
- }
-
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
- return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- If this token is not a comma, we have a complex constant (or an attempt
- at one), so handle it accordingly, displaying error messages if the token
- is not a close-paren. If we have a comma here, it is an attempt at an
- implied-DO, so start making a list accordingly. Oh, it might be an
- equal sign also, meaning an implied-DO with only one item in its list. */
-
-static ffelexHandler
-ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffebld fexpr;
-
- /* First check to see if this is a possible complex constant. It is if the
- token is not a comma or an equals sign, in which case it should be a
- close-paren. */
-
- if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
- && (ffelex_token_type (t) != FFELEX_typeEQUALS))
- {
- ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
- return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
- }
-
- /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
- construct. Make a list and handle accordingly. */
-
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- fexpr = ffeexpr_stack_->expr;
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
- return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle first item in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeCOMMA)
- {
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-
- return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle first item in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctxi;
- ffeexprContext ctxc;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- ctxi = FFEEXPR_contextDATAIMPDOITEM_;
- ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- ctxi = FFEEXPR_contextIMPDOITEM_;
- ctxc = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctxi = FFEEXPR_contextIMPDOITEMDF_;
- ctxc = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctxi = FFEEXPR_context;
- ctxc = FFEEXPR_context;
- break;
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- if (ffeexpr_stack_->is_rhs)
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctxi, ffeexpr_cb_comma_i_1_);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- ctxi, ffeexpr_cb_comma_i_1_);
-
- case FFELEX_typeEQUALS:
- ffebld_end_list (&ffeexpr_stack_->bottom);
-
- /* Complain if implied-DO variable in list of items to be read. */
-
- if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
- ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
- ffeexpr_stack_->first_token, expr, ft);
-
- /* Set doiter flag for all appropriate SYMTERs. */
-
- ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
-
- ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
- ffebld_set_info (ffeexpr_stack_->expr,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
- &ffeexpr_stack_->bottom);
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctxc, ffeexpr_cb_comma_i_2_);
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-}
-
-/* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle start-value in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctx;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- ctx = FFEEXPR_contextDATAIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctx = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_context;
- break;
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctx, ffeexpr_cb_comma_i_3_);
- break;
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-}
-
-/* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle end-value in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctx;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- ctx = FFEEXPR_contextDATAIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctx = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_context;
- break;
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctx, ffeexpr_cb_comma_i_4_);
- break;
-
- case FFELEX_typeCLOSE_PAREN:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
- break;
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-}
-
-/* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
- [COMMA expr]
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle incr-value in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- ffebld_end_list (&ffeexpr_stack_->bottom);
- {
- ffebld item;
-
- for (item = ffebld_left (ffeexpr_stack_->expr);
- item != NULL;
- item = ffebld_trail (item))
- if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
- goto replace_with_any; /* :::::::::::::::::::: */
-
- for (item = ffebld_right (ffeexpr_stack_->expr);
- item != NULL;
- item = ffebld_trail (item))
- if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
- && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
- goto replace_with_any; /* :::::::::::::::::::: */
- }
- break;
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
-
- replace_with_any: /* :::::::::::::::::::: */
-
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- break;
- }
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
-}
-
-/* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
- [COMMA expr] CLOSE_PAREN
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Collects token following implied-DO construct for callback function. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_5_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
- ffebld expr;
- bool terminate;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- terminate = TRUE;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- terminate = FALSE;
- break;
-
- default:
- assert ("bad context" == NULL);
- terminate = FALSE;
- break;
- }
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- expr = ffeexpr_stack_->expr;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
- sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- if (terminate)
- {
- ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
- --ffeexpr_level_;
- if (ffeexpr_level_ == 0)
- ffe_terminate_4 ();
- }
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
-
- Makes sure the end token is close-paren and swallows it, else issues
- an error message and doesn't swallow the token (passing it along instead).
- In either case wraps up subexpression construction by enclosing the
- ffebld expression in a %LOC. */
-
-static ffelexHandler
-ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
-
- /* First push the (%LOC) expression as an operand onto the expression
- stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_stack_->tokens[0];
- e->u.operand = ffebld_new_percent_loc (expr);
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeINTEGER,
- ffecom_pointer_kind (),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereFLEETING,
- FFETARGET_charactersizeNONE));
-#if 0 /* ~~ */
- e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
-#endif
- ffeexpr_exprstack_push_operand_ (e);
-
- /* Now, if the token is a close parenthese, we're in great shape so return
- the next handler. */
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- {
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return (ffelexHandler) ffeexpr_token_binary_;
- }
-
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_finish ();
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_binary_);
-}
-
-/* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
-
- Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
-
-static ffelexHandler
-ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
- ffebldOp op;
-
- /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
- such things until the lowest-level expression is reached. */
-
- op = ffebld_op (expr);
- if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
- || (op == FFEBLD_opPERCENT_DESCR))
- {
- if (ffebad_start (FFEBAD_NESTED_PERCENT))
- {
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
-
- do
- {
- expr = ffebld_left (expr);
- op = ffebld_op (expr);
- }
- while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
- || (op == FFEBLD_opPERCENT_DESCR));
- }
-
- /* Push the expression as an operand onto the expression stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_stack_->tokens[0];
- switch (ffeexpr_stack_->percent)
- {
- case FFEEXPR_percentVAL_:
- e->u.operand = ffebld_new_percent_val (expr);
- break;
-
- case FFEEXPR_percentREF_:
- e->u.operand = ffebld_new_percent_ref (expr);
- break;
-
- case FFEEXPR_percentDESCR_:
- e->u.operand = ffebld_new_percent_descr (expr);
- break;
-
- default:
- assert ("%lossage" == NULL);
- e->u.operand = expr;
- break;
- }
- ffebld_set_info (e->u.operand, ffebld_info (expr));
-#if 0 /* ~~ */
- e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
-#endif
- ffeexpr_exprstack_push_operand_ (e);
-
- /* Now, if the token is a close parenthese, we're in great shape so return
- the next handler. */
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
-
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_finish ();
- }
-
- ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_cb_end_notloc_1_);
-}
-
-/* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
- CLOSE_PAREN
-
- Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
-
-static ffelexHandler
-ffeexpr_cb_end_notloc_1_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
- break;
-
- default:
- if (ffebad_start (FFEBAD_INVALID_PERCENT))
- {
- ffebad_here (0,
- ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
- ffebad_finish ();
- }
-
- ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
- FFEBLD_opPERCENT_LOC);
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return
- (ffelexHandler) ffeexpr_token_binary_ (t);
-}
-
-/* Process DATA implied-DO iterator variables as this implied-DO level
- terminates. At this point, ffeexpr_level_ == 1 when we see the
- last right-paren in "DATA (A(I),I=1,10)/.../". */
-
-static ffesymbol
-ffeexpr_check_impctrl_ (ffesymbol s)
-{
- assert (s != NULL);
- assert (ffesymbol_sfdummyparent (s) != NULL);
-
- switch (ffesymbol_state (s))
- {
- case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
- be used as iterator at any level at or
- innermore than the outermost of the
- current level and the symbol's current
- level. */
- if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
- {
- ffesymbol_signal_change (s);
- ffesymbol_set_maxentrynum (s, ffeexpr_level_);
- ffesymbol_signal_unreported (s);
- }
- break;
-
- case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
- Error if at outermost level, else it can
- still become an iterator. */
- if ((ffeexpr_level_ == 1)
- && ffebad_start (FFEBAD_BAD_IMPDCL))
- {
- ffebad_string (ffesymbol_text (s));
- ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
- ffebad_finish ();
- }
- break;
-
- case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
- assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
- ffesymbol_signal_change (s);
- ffesymbol_set_state (s, FFESYMBOL_stateNONE);
- ffesymbol_signal_unreported (s);
- break;
-
- case FFESYMBOL_stateUNDERSTOOD:
- break; /* ANY. */
-
- default:
- assert ("Sasha Foo!!" == NULL);
- break;
- }
-
- return s;
-}
-
-/* Issue diagnostic if implied-DO variable appears in list of lhs
- expressions (as in "READ *, (I,I=1,10)"). */
-
-static void
-ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
- ffebld dovar, ffelexToken dovar_t)
-{
- ffebld item;
- ffesymbol dovar_sym;
- int itemnum;
-
- if (ffebld_op (dovar) != FFEBLD_opSYMTER)
- return; /* Presumably opANY. */
-
- dovar_sym = ffebld_symter (dovar);
-
- for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
- {
- if (((item = ffebld_head (list)) != NULL)
- && (ffebld_op (item) == FFEBLD_opSYMTER)
- && (ffebld_symter (item) == dovar_sym))
- {
- char itemno[20];
-
- sprintf (&itemno[0], "%d", itemnum);
- if (ffebad_start (FFEBAD_DOITER_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (list_t),
- ffelex_token_where_column (list_t));
- ffebad_here (1, ffelex_token_where_line (dovar_t),
- ffelex_token_where_column (dovar_t));
- ffebad_string (ffesymbol_text (dovar_sym));
- ffebad_string (itemno);
- ffebad_finish ();
- }
- }
- }
-}
-
-/* Decorate any SYMTERs referencing the DO variable with the "doiter"
- flag. */
-
-static void
-ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
-{
- ffesymbol dovar_sym;
-
- if (ffebld_op (dovar) != FFEBLD_opSYMTER)
- return; /* Presumably opANY. */
-
- dovar_sym = ffebld_symter (dovar);
-
- ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
-}
-
-/* Recursive function to update any expr so SYMTERs have "doiter" flag
- if they refer to the given variable. */
-
-static void
-ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
-{
- tail_recurse: /* :::::::::::::::::::: */
-
- if (expr == NULL)
- return;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- if (ffebld_symter (expr) == dovar)
- ffebld_symter_set_is_doiter (expr, TRUE);
- break;
-
- case FFEBLD_opITEM:
- ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
- expr = ffebld_trail (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- switch (ffebld_arity (expr))
- {
- case 2:
- ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
- expr = ffebld_right (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- case 1:
- expr = ffebld_left (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- return;
-}
-
-/* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
-
- if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
- // After zero or more PAREN_ contexts, an IF context exists */
-
-static ffeexprContext
-ffeexpr_context_outer_ (ffeexprStack_ s)
-{
- assert (s != NULL);
-
- for (;;)
- {
- switch (s->context)
- {
- case FFEEXPR_contextPAREN_:
- case FFEEXPR_contextPARENFILENUM_:
- case FFEEXPR_contextPARENFILEUNIT_:
- break;
-
- default:
- return s->context;
- }
- s = s->previous;
- assert (s != NULL);
- }
-}
-
-/* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
-
- ffeexprPercent_ p;
- ffelexToken t;
- p = ffeexpr_percent_(t);
-
- Returns the identifier for the name, or the NONE identifier. */
-
-static ffeexprPercent_
-ffeexpr_percent_ (ffelexToken t)
-{
- const char *p;
-
- switch (ffelex_token_length (t))
- {
- case 3:
- switch (*(p = ffelex_token_text (t)))
- {
- case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
- && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
- return FFEEXPR_percentLOC_;
- return FFEEXPR_percentNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
- && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
- return FFEEXPR_percentREF_;
- return FFEEXPR_percentNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
- && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
- return FFEEXPR_percentVAL_;
- return FFEEXPR_percentNONE_;
-
- default:
- no_match_3: /* :::::::::::::::::::: */
- return FFEEXPR_percentNONE_;
- }
-
- case 5:
- if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
- "descr", "Descr") == 0)
- return FFEEXPR_percentDESCR_;
- return FFEEXPR_percentNONE_;
-
- default:
- return FFEEXPR_percentNONE_;
- }
-}
-
-/* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
-
- See prototype.
-
- If combining the two basictype/kindtype pairs produces a COMPLEX with an
- unsupported kind type, complain and use the default kind type for
- COMPLEX. */
-
-void
-ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
- ffeinfoBasictype lbt, ffeinfoKindtype lkt,
- ffeinfoBasictype rbt, ffeinfoKindtype rkt,
- ffelexToken t)
-{
- ffeinfoBasictype nbt;
- ffeinfoKindtype nkt;
-
- nbt = ffeinfo_basictype_combine (lbt, rbt);
- if ((nbt == FFEINFO_basictypeCOMPLEX)
- && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
- && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
- {
- nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
- if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
- nkt = FFEINFO_kindtypeNONE; /* Force error. */
- switch (nkt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
-#endif
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
-#endif
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
-#endif
- break; /* Fine and dandy. */
-
- default:
- if (t != NULL)
- {
- ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
- ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- nbt = FFEINFO_basictypeNONE;
- nkt = FFEINFO_kindtypeNONE;
- break;
-
- case FFEINFO_kindtypeANY:
- nkt = FFEINFO_kindtypeREALDEFAULT;
- break;
- }
- }
- else
- { /* The normal stuff. */
- if (nbt == lbt)
- {
- if (nbt == rbt)
- nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
- else
- nkt = lkt;
- }
- else if (nbt == rbt)
- nkt = rkt;
- else
- { /* Let the caller do the complaining. */
- nbt = FFEINFO_basictypeNONE;
- nkt = FFEINFO_kindtypeNONE;
- }
- }
-
- /* Always a good idea to avoid aliasing problems. */
-
- *xnbt = nbt;
- *xnkt = nkt;
-}
-
-/* ffeexpr_token_first_lhs_ -- First state for lhs expression
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Record line and column of first token in expression, then invoke the
- initial-state lhs handler. */
-
-static ffelexHandler
-ffeexpr_token_first_lhs_ (ffelexToken t)
-{
- ffeexpr_stack_->first_token = ffelex_token_use (t);
-
- /* When changing the list of valid initial lhs tokens, check whether to
- update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
- READ (expr) <token> case -- it assumes it knows which tokens <token> can
- be to indicate an lhs (or implied DO), which right now is the set
- {NAME,OPEN_PAREN}.
-
- This comment also appears in ffeexpr_token_lhs_. */
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- ffe_init_4 ();
- ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextFILEEXTFUNC:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_lhs_1_;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeNAME:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILENAMELIST:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_namelist_;
-
- case FFEEXPR_contextFILEEXTFUNC:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_lhs_1_;
-
- default:
- break;
- }
- break;
-
- default:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEEXTFUNC:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_lhs_1_;
-
- default:
- break;
- }
- break;
- }
-
- return (ffelexHandler) ffeexpr_token_lhs_ (t);
-}
-
-/* ffeexpr_token_first_lhs_1_ -- NAME
-
- return ffeexpr_token_first_lhs_1_; // to lexer
-
- Handle NAME as an external function (USEROPEN= VXT extension to OPEN
- statement). */
-
-static ffelexHandler
-ffeexpr_token_first_lhs_1_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
- ffesymbol sy = NULL;
- ffebld expr;
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
-
- if ((ffelex_token_type (ft) != FFELEX_typeNAME)
- || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
- & FFESYMBOL_attrANY))
- {
- if ((ffelex_token_type (ft) != FFELEX_typeNAME)
- || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
- {
- ffebad_start (FFEBAD_EXPR_WRONG);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- expr = ffebld_new_any ();
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
- else
- {
- expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (expr, ffesymbol_info (sy));
- }
-
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
- sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
-
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_ -- First state for rhs expression
-
- Record line and column of first token in expression, then invoke the
- initial-state rhs handler.
-
- 19-Feb-91 JCB 1.1
- Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
- (i.e. only as in READ(*), not READ((*))). */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_ (ffelexToken t)
-{
- ffesymbol s;
-
- ffeexpr_stack_->first_token = ffelex_token_use (t);
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeASTERISK:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- /* Fall through. */
- case FFEEXPR_contextFILEUNIT:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextFILEFORMAT:
- case FFEEXPR_contextCHARACTERSIZE:
- if (ffeexpr_stack_->previous != NULL)
- break; /* Valid only on first level. */
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_1_;
-
- case FFEEXPR_contextPARENFILEUNIT_:
- if (ffeexpr_stack_->previous->previous != NULL)
- break; /* Valid only on second level. */
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_1_;
-
- case FFEEXPR_contextACTUALARG_:
- if (ffeexpr_stack_->previous->context
- != FFEEXPR_contextSUBROUTINEREF)
- {
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
- }
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_3_;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeOPEN_PAREN:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILENUMAMBIG:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextPARENFILENUM_,
- ffeexpr_cb_close_paren_ambig_);
-
- case FFEEXPR_contextFILEUNITAMBIG:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextPARENFILEUNIT_,
- ffeexpr_cb_close_paren_ambig_);
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEM_,
- ffeexpr_cb_close_paren_ci_);
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEMDF_,
- ffeexpr_cb_close_paren_ci_);
-
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeNUMBER:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- /* Fall through. */
- case FFEEXPR_contextFILEFORMAT:
- if (ffeexpr_stack_->previous != NULL)
- break; /* Valid only on first level. */
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_2_;
-
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeNAME:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEFORMATNML:
- assert (ffeexpr_stack_->exprstack == NULL);
- s = ffesymbol_lookup_local (t);
- if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
- return (ffelexHandler) ffeexpr_token_namelist_;
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typePERCENT:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextINDEXORACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- return (ffelexHandler) ffeexpr_token_first_rhs_5_;
-
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- break;
- }
-
- default:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- break;
- }
- break;
- }
-
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
-}
-
-/* ffeexpr_token_first_rhs_1_ -- ASTERISK
-
- return ffeexpr_token_first_rhs_1_; // to lexer
-
- Return STAR as expression. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_1_ (ffelexToken t)
-{
- ffebld expr;
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
-
- expr = ffebld_new_star ();
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_2_ -- NUMBER
-
- return ffeexpr_token_first_rhs_2_; // to lexer
-
- Return NULL as expression; NUMBER as first (and only) token, unless the
- current token is not a terminating token, in which case run normal
- expression handling. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_2_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- break;
-
- default:
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- return (ffelexHandler) (*next) (t);
- }
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
- sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, NULL, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_3_ -- ASTERISK
-
- return ffeexpr_token_first_rhs_3_; // to lexer
-
- Expect NUMBER, make LABTOK (with copy of token if not inhibited after
- confirming, else NULL). */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_3_ (ffelexToken t)
-{
- ffelexHandler next;
-
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- { /* An error, but let normal processing handle
- it. */
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- return (ffelexHandler) (*next) (t);
- }
-
- /* Special case: when we see "*10" as an argument to a subroutine
- reference, we confirm the current statement and, if not inhibited at
- this point, put a copy of the token into a LABTOK node. We do this
- instead of just resolving the label directly via ffelab and putting it
- into a LABTER simply to improve error reporting and consistency in
- ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
- doesn't have to worry about killing off any tokens when retracting. */
-
- ffest_confirmed ();
- if (ffest_is_inhibited ())
- ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
- else
- ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
- ffebld_set_info (ffeexpr_stack_->expr,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
-
- return (ffelexHandler) ffeexpr_token_first_rhs_4_;
-}
-
-/* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
-
- return ffeexpr_token_first_rhs_4_; // to lexer
-
- Collect/flush appropriate stuff, send token to callback function. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_4_ (ffelexToken t)
-{
- ffebld expr;
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
-
- expr = ffeexpr_stack_->expr;
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_5_ -- PERCENT
-
- Should be NAME, or pass through original mechanism. If NAME is LOC,
- pass through original mechanism, otherwise must be VAL, REF, or DESCR,
- in which case handle the argument (in parentheses), etc. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_5_ (ffelexToken t)
-{
- ffelexHandler next;
-
- if (ffelex_token_type (t) == FFELEX_typeNAME)
- {
- ffeexprPercent_ p = ffeexpr_percent_ (t);
-
- switch (p)
- {
- case FFEEXPR_percentNONE_:
- case FFEEXPR_percentLOC_:
- break; /* Treat %LOC as any other expression. */
-
- case FFEEXPR_percentVAL_:
- case FFEEXPR_percentREF_:
- case FFEEXPR_percentDESCR_:
- ffeexpr_stack_->percent = p;
- ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_first_rhs_6_;
-
- default:
- assert ("bad percent?!?" == NULL);
- break;
- }
- }
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
-
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- return (ffelexHandler) (*next) (t);
-}
-
-/* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
-
- Should be OPEN_PAREN, or pass through original mechanism. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_6_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken ft;
-
- if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
- {
- ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ffeexpr_stack_->context,
- ffeexpr_cb_end_notloc_);
- }
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
-
- ft = ffeexpr_stack_->tokens[0];
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- next = (ffelexHandler) (*next) (ft);
- ffelex_token_kill (ft);
- return (ffelexHandler) (*next) (t);
-}
-
-/* ffeexpr_token_namelist_ -- NAME
-
- return ffeexpr_token_namelist_; // to lexer
-
- Make sure NAME was a valid namelist object, wrap it in a SYMTER and
- return. */
-
-static ffelexHandler
-ffeexpr_token_namelist_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
- ffesymbol sy;
- ffebld expr;
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
-
- sy = ffesymbol_lookup_local (ft);
- if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
- {
- ffebad_start (FFEBAD_EXPR_WRONG);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- expr = ffebld_new_any ();
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
- else
- {
- expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (expr, ffesymbol_info (sy));
- }
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_expr_kill_ -- Kill an existing internal expression object
-
- ffeexprExpr_ e;
- ffeexpr_expr_kill_(e);
-
- Kills the ffewhere info, if necessary, then kills the object. */
-
-static void
-ffeexpr_expr_kill_ (ffeexprExpr_ e)
-{
- if (e->token != NULL)
- ffelex_token_kill (e->token);
- malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
-}
-
-/* ffeexpr_expr_new_ -- Make a new internal expression object
-
- ffeexprExpr_ e;
- e = ffeexpr_expr_new_();
-
- Allocates and initializes a new expression object, returns it. */
-
-static ffeexprExpr_
-ffeexpr_expr_new_ (void)
-{
- ffeexprExpr_ e;
-
- e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e));
- e->previous = NULL;
- e->type = FFEEXPR_exprtypeUNKNOWN_;
- e->token = NULL;
- return e;
-}
-
-/* Verify that call to global is valid, and register whatever
- new information about a global might be discoverable by looking
- at the call. */
-
-static void
-ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
-{
- int n_args;
- ffebld list;
- ffebld item;
- ffesymbol s;
-
- assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
- || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
-
- if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
- return;
-
- if (ffesymbol_retractable ())
- return;
-
- s = ffebld_symter (ffebld_left (*expr));
- if (ffesymbol_global (s) == NULL)
- return;
-
- for (n_args = 0, list = ffebld_right (*expr);
- list != NULL;
- list = ffebld_trail (list), ++n_args)
- ;
-
- if (ffeglobal_proc_ref_nargs (s, n_args, t))
- {
- ffeglobalArgSummary as;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- bool array;
- bool fail = FALSE;
-
- for (n_args = 0, list = ffebld_right (*expr);
- list != NULL;
- list = ffebld_trail (list), ++n_args)
- {
- item = ffebld_head (list);
- if (item != NULL)
- {
- bt = ffeinfo_basictype (ffebld_info (item));
- kt = ffeinfo_kindtype (ffebld_info (item));
- array = (ffeinfo_rank (ffebld_info (item)) > 0);
- switch (ffebld_op (item))
- {
- case FFEBLD_opLABTOK:
- case FFEBLD_opLABTER:
- as = FFEGLOBAL_argsummaryALTRTN;
- break;
-
-#if 0
- /* No, %LOC(foo) is just like any INTEGER(KIND=7)
- expression, so don't treat it specially. */
- case FFEBLD_opPERCENT_LOC:
- as = FFEGLOBAL_argsummaryPTR;
- break;
-#endif
-
- case FFEBLD_opPERCENT_VAL:
- as = FFEGLOBAL_argsummaryVAL;
- break;
-
- case FFEBLD_opPERCENT_REF:
- as = FFEGLOBAL_argsummaryREF;
- break;
-
- case FFEBLD_opPERCENT_DESCR:
- as = FFEGLOBAL_argsummaryDESCR;
- break;
-
- case FFEBLD_opFUNCREF:
-#if 0
- /* No, LOC(foo) is just like any INTEGER(KIND=7)
- expression, so don't treat it specially. */
- if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
- && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
- == FFEINTRIN_specLOC))
- {
- as = FFEGLOBAL_argsummaryPTR;
- break;
- }
-#endif
- /* Fall through. */
- default:
- if (ffebld_op (item) == FFEBLD_opSYMTER)
- {
- as = FFEGLOBAL_argsummaryNONE;
-
- switch (ffeinfo_kind (ffebld_info (item)))
- {
- case FFEINFO_kindFUNCTION:
- as = FFEGLOBAL_argsummaryFUNC;
- break;
-
- case FFEINFO_kindSUBROUTINE:
- as = FFEGLOBAL_argsummarySUBR;
- break;
-
- case FFEINFO_kindNONE:
- as = FFEGLOBAL_argsummaryPROC;
- break;
-
- default:
- break;
- }
-
- if (as != FFEGLOBAL_argsummaryNONE)
- break;
- }
-
- if (bt == FFEINFO_basictypeCHARACTER)
- as = FFEGLOBAL_argsummaryDESCR;
- else
- as = FFEGLOBAL_argsummaryREF;
- break;
- }
- }
- else
- {
- array = FALSE;
- as = FFEGLOBAL_argsummaryNONE;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- }
-
- if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
- fail = TRUE;
- }
- if (! fail)
- return;
- }
-
- *expr = ffebld_new_any ();
- ffebld_set_info (*expr, ffeinfo_new_any ());
-}
-
-/* Check whether rest of string is all decimal digits. */
-
-static bool
-ffeexpr_isdigits_ (const char *p)
-{
- for (; *p != '\0'; ++p)
- if (! ISDIGIT (*p))
- return FALSE;
- return TRUE;
-}
-
-/* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
-
- ffeexprExpr_ e;
- ffeexpr_exprstack_push_(e);
-
- Pushes the expression onto the stack without any analysis of the existing
- contents of the stack. */
-
-static void
-ffeexpr_exprstack_push_ (ffeexprExpr_ e)
-{
- e->previous = ffeexpr_stack_->exprstack;
- ffeexpr_stack_->exprstack = e;
-}
-
-/* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
-
- ffeexprExpr_ e;
- ffeexpr_exprstack_push_operand_(e);
-
- Pushes the expression already containing an operand (a constant, variable,
- or more complicated expression that has already been fully resolved) after
- analyzing the stack and checking for possible reduction (which will never
- happen here since the highest precedence operator is ** and it has right-
- to-left associativity). */
-
-static void
-ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
-{
- ffeexpr_exprstack_push_ (e);
-}
-
-/* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
-
- ffeexprExpr_ e;
- ffeexpr_exprstack_push_unary_(e);
-
- Pushes the expression already containing a unary operator. Reduction can
- never happen since unary operators are themselves always R-L; that is, the
- top of the expression stack is not an operand, in that it is either empty,
- has a binary operator at the top, or a unary operator at the top. In any
- of these cases, reduction is impossible. */
-
-static void
-ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
-{
- if ((ffe_is_pedantic ()
- || ffe_is_warn_surprising ())
- && (ffeexpr_stack_->exprstack != NULL)
- && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
- && (ffeexpr_stack_->exprstack->u.operator.prec
- <= FFEEXPR_operatorprecedenceLOWARITH_)
- && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
- {
- /* xgettext:no-c-format */
- ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
- ffe_is_pedantic ()
- ? FFEBAD_severityPEDANTIC
- : FFEBAD_severityWARNING);
- ffebad_here (0,
- ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
- ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
- ffebad_here (1,
- ffelex_token_where_line (e->token),
- ffelex_token_where_column (e->token));
- ffebad_finish ();
- }
-
- ffeexpr_exprstack_push_ (e);
-}
-
-/* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
-
- ffeexprExpr_ e;
- ffeexpr_exprstack_push_binary_(e);
-
- Pushes the expression already containing a binary operator after checking
- whether reduction is possible. If the stack is not empty, the top of the
- stack must be an operand or syntactic analysis has failed somehow. If
- the operand is preceded by a unary operator of higher (or equal and L-R
- associativity) precedence than the new binary operator, then reduce that
- preceding operator and its operand(s) before pushing the new binary
- operator. */
-
-static void
-ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
-{
- ffeexprExpr_ ce;
-
- if (ffe_is_warn_surprising ()
- /* These next two are always true (see assertions below). */
- && (ffeexpr_stack_->exprstack != NULL)
- && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
- /* If the previous operator is a unary minus, and the binary op
- is of higher precedence, might not do what user expects,
- e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
- yield "4". */
- && (ffeexpr_stack_->exprstack->previous != NULL)
- && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
- && (ffeexpr_stack_->exprstack->previous->u.operator.op
- == FFEEXPR_operatorSUBTRACT_)
- && (e->u.operator.prec
- < ffeexpr_stack_->exprstack->previous->u.operator.prec))
- {
- /* xgettext:no-c-format */
- ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
- ffebad_here (0,
- ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
- ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
- ffebad_here (1,
- ffelex_token_where_line (e->token),
- ffelex_token_where_column (e->token));
- ffebad_finish ();
- }
-
-again:
- assert (ffeexpr_stack_->exprstack != NULL);
- assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
- if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
- {
- assert (ce->type != FFEEXPR_exprtypeOPERAND_);
- if ((ce->u.operator.prec < e->u.operator.prec)
- || ((ce->u.operator.prec == e->u.operator.prec)
- && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
- {
- ffeexpr_reduce_ ();
- goto again; /* :::::::::::::::::::: */
- }
- }
-
- ffeexpr_exprstack_push_ (e);
-}
-
-/* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
-
- ffeexpr_reduce_();
-
- Converts operand binop operand or unop operand at top of stack to a
- single operand having the appropriate ffebld expression, and makes
- sure that the expression is proper (like not trying to add two character
- variables, not trying to concatenate two numbers). Also does the
- requisite type-assignment. */
-
-static void
-ffeexpr_reduce_ (void)
-{
- ffeexprExpr_ operand; /* This is B in -B or A+B. */
- ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
- ffeexprExpr_ operator; /* This is + in A+B. */
- ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
- ffebldConstant constnode; /* For checking magical numbers (where mag ==
- -mag). */
- ffebld expr;
- ffebld left_expr;
- bool submag = FALSE;
- bool bothlogical;
-
- operand = ffeexpr_stack_->exprstack;
- assert (operand != NULL);
- assert (operand->type == FFEEXPR_exprtypeOPERAND_);
- operator = operand->previous;
- assert (operator != NULL);
- assert (operator->type != FFEEXPR_exprtypeOPERAND_);
- if (operator->type == FFEEXPR_exprtypeUNARY_)
- {
- expr = operand->u.operand;
- switch (operator->u.operator.op)
- {
- case FFEEXPR_operatorADD_:
- reduced = ffebld_new_uplus (expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
- reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
- reduced = ffeexpr_collapse_uplus (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorSUBTRACT_:
- submag = TRUE; /* Ok to negate a magic number. */
- reduced = ffebld_new_uminus (expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
- reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
- reduced = ffeexpr_collapse_uminus (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorNOT_:
- reduced = ffebld_new_not (expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
- reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
- reduced = ffeexpr_collapse_not (reduced, operator->token);
- break;
-
- default:
- assert ("unexpected unary op" != NULL);
- reduced = NULL;
- break;
- }
- if (!submag
- && (ffebld_op (expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
- {
- ffetarget_integer_bad_magical (operand->token);
- }
- ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
- off stack. */
- ffeexpr_expr_kill_ (operand);
- operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
- save */
- operator->u.operand = reduced; /* the line/column ffewhere info. */
- ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
- stack. */
- }
- else
- {
- assert (operator->type == FFEEXPR_exprtypeBINARY_);
- left_operand = operator->previous;
- assert (left_operand != NULL);
- assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
- expr = operand->u.operand;
- left_expr = left_operand->u.operand;
- switch (operator->u.operator.op)
- {
- case FFEEXPR_operatorADD_:
- reduced = ffebld_new_add (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_add (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorSUBTRACT_:
- submag = TRUE; /* Just to pick the right error if magic
- number. */
- reduced = ffebld_new_subtract (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_subtract (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorMULTIPLY_:
- reduced = ffebld_new_multiply (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_multiply (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorDIVIDE_:
- reduced = ffebld_new_divide (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_divide (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorPOWER_:
- reduced = ffebld_new_power (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_power (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorCONCATENATE_:
- reduced = ffebld_new_concatenate (left_expr, expr);
- reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorLT_:
- reduced = ffebld_new_lt (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_lt (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorLE_:
- reduced = ffebld_new_le (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_le (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorEQ_:
- reduced = ffebld_new_eq (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_eq (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorNE_:
- reduced = ffebld_new_ne (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_ne (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorGT_:
- reduced = ffebld_new_gt (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_gt (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorGE_:
- reduced = ffebld_new_ge (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_ge (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorAND_:
- reduced = ffebld_new_and (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand, &bothlogical);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_and (reduced, operator->token);
- if (ffe_is_ugly_logint() && bothlogical)
- reduced = ffeexpr_convert (reduced, left_operand->token,
- operator->token,
- FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEEXPR_operatorOR_:
- reduced = ffebld_new_or (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand, &bothlogical);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_or (reduced, operator->token);
- if (ffe_is_ugly_logint() && bothlogical)
- reduced = ffeexpr_convert (reduced, left_operand->token,
- operator->token,
- FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEEXPR_operatorXOR_:
- reduced = ffebld_new_xor (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand, &bothlogical);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_xor (reduced, operator->token);
- if (ffe_is_ugly_logint() && bothlogical)
- reduced = ffeexpr_convert (reduced, left_operand->token,
- operator->token,
- FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEEXPR_operatorEQV_:
- reduced = ffebld_new_eqv (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand, NULL);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_eqv (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorNEQV_:
- reduced = ffebld_new_neqv (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand, NULL);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_neqv (reduced, operator->token);
- break;
-
- default:
- assert ("bad bin op" == NULL);
- reduced = expr;
- break;
- }
- if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
- {
- if ((left_operand->previous != NULL)
- && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
- && (left_operand->previous->u.operator.op
- == FFEEXPR_operatorSUBTRACT_))
- {
- if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
- ffetarget_integer_bad_magical_precedence (left_operand->token,
- left_operand->previous->token,
- operator->token);
- else
- ffetarget_integer_bad_magical_precedence_binary
- (left_operand->token,
- left_operand->previous->token,
- operator->token);
- }
- else
- ffetarget_integer_bad_magical (left_operand->token);
- }
- if ((ffebld_op (expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
- {
- if (submag)
- ffetarget_integer_bad_magical_binary (operand->token,
- operator->token);
- else
- ffetarget_integer_bad_magical (operand->token);
- }
- ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
- operands off stack. */
- ffeexpr_expr_kill_ (left_operand);
- ffeexpr_expr_kill_ (operand);
- operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
- save */
- operator->u.operand = reduced; /* the line/column ffewhere info. */
- ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
- stack. */
- }
-}
-
-/* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
-
- reduced = ffeexpr_reduced_bool1_(reduced,op,r);
-
- Makes sure the argument for reduced has basictype of
- LOGICAL or (ugly) INTEGER. If
- argument has where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
-{
- ffeinfo rinfo, ninfo;
- ffeinfoBasictype rbt;
- ffeinfoKindtype rkt;
- ffeinfoRank rrk;
- ffeinfoKind rkd;
- ffeinfoWhere rwh, nwh;
-
- rinfo = ffebld_info (ffebld_left (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if (((rbt == FFEINFO_basictypeLOGICAL)
- || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
- && (rrk == 0))
- {
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
- FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- return reduced;
- }
-
- if ((rbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_NOT_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_NOT_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
-
- reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- LOGICAL or (ugly) INTEGER. Determine common basictype and
- size for reduction (flag expression for combined hollerith/typeless
- situations for later determination of effective basictype). If both left
- and right arguments have where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING. Create CONVERT ops for args where
- needed. Convert typeless
- constants to the desired type/size explicitly.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh, nwh;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
-
- if (((nbt == FFEINFO_basictypeLOGICAL)
- || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
- && (lrk == 0) && (rrk == 0))
- {
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
- FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- return reduced;
- }
-
- if ((lbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
- {
- if ((rbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- }
- else if ((rbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lrk != 0)
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_BOOL_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_BOOL_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
-
- reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
- basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
- size of concatenation and assign that size to reduced. If both left and
- right arguments have where of CONSTANT, assign where CONSTANT to reduced,
- else assign where FLEETING.
-
- If these requirements cannot be met, generate error message using the
- info in l, op, and r arguments and assign basictype, size, kind, and where
- of ANY. */
-
-static ffebld
-ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd, nkd;
- ffeinfoWhere lwh, rwh, nwh;
- ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- lszk = ffeinfo_size (linfo); /* Known size. */
- lszm = ffebld_size_max (ffebld_left (reduced));
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- rszk = ffeinfo_size (rinfo); /* Known size. */
- rszm = ffebld_size_max (ffebld_right (reduced));
-
- if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
- && (lkt == rkt) && (lrk == 0) && (rrk == 0)
- && (((lszm != FFETARGET_charactersizeNONE)
- && (rszm != FFETARGET_charactersizeNONE))
- || (ffeexpr_context_outer_ (ffeexpr_stack_)
- == FFEEXPR_contextLET)
- || (ffeexpr_context_outer_ (ffeexpr_stack_)
- == FFEEXPR_contextSFUNCDEF)))
- {
- nbt = FFEINFO_basictypeCHARACTER;
- nkd = FFEINFO_kindENTITY;
- if ((lszk == FFETARGET_charactersizeNONE)
- || (rszk == FFETARGET_charactersizeNONE))
- nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
- stmt. */
- else
- nszk = lszk + rszk;
-
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- nkt = lkt;
- ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
- ffebld_set_info (reduced, ninfo);
- return reduced;
- }
-
- if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lbt != FFEINFO_basictypeCHARACTER)
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- else if (rbt != FFEINFO_basictypeCHARACTER)
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
- {
- const char *what;
-
- if (lrk != 0)
- what = "an array";
- else
- what = "of indeterminate length";
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string (what);
- ffebad_finish ();
- }
- }
- else
- {
- if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
- {
- const char *what;
-
- if (rrk != 0)
- what = "an array";
- else
- what = "of indeterminate length";
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string (what);
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
-
- reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
- size for reduction. If both left
- and right arguments have where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING. Create CONVERT ops for args where
- needed. Convert typeless
- constants to the desired type/size explicitly.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh, nwh;
- ffetargetCharacterSize lsz, rsz;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- lsz = ffebld_size_known (ffebld_left (reduced));
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- rsz = ffebld_size_known (ffebld_right (reduced));
-
- ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
-
- if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
- || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
- && (lrk == 0) && (rrk == 0))
- {
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- if ((lsz != FFETARGET_charactersizeNONE)
- && (rsz != FFETARGET_charactersizeNONE))
- lsz = rsz = (lsz > rsz) ? lsz : rsz;
-
- ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
- 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, nbt, nkt, 0, lsz,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, nbt, nkt, 0, rsz,
- FFEEXPR_contextLET));
- return reduced;
- }
-
- if ((lbt == FFEINFO_basictypeLOGICAL)
- && (rbt == FFEINFO_basictypeLOGICAL))
- {
- /* xgettext:no-c-format */
- if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
- FFEBAD_severityFATAL))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
- && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
- {
- if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
- && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- }
- else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
- && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lrk != 0)
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_EQOP_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_EQOP_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
-
- reduced = ffeexpr_reduced_math1_(reduced,op,r);
-
- Makes sure the argument for reduced has basictype of
- INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
- assign where CONSTANT to
- reduced, else assign where FLEETING.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
-{
- ffeinfo rinfo, ninfo;
- ffeinfoBasictype rbt;
- ffeinfoKindtype rkt;
- ffeinfoRank rrk;
- ffeinfoKind rkd;
- ffeinfoWhere rwh, nwh;
-
- rinfo = ffebld_info (ffebld_left (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
- || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
- {
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
- FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- return reduced;
- }
-
- if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
- && (rbt != FFEINFO_basictypeCOMPLEX))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_MATH_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_MATH_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
-
- reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- INTEGER, REAL, or COMPLEX. Determine common basictype and
- size for reduction (flag expression for combined hollerith/typeless
- situations for later determination of effective basictype). If both left
- and right arguments have where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING. Create CONVERT ops for args where
- needed. Convert typeless
- constants to the desired type/size explicitly.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh, nwh;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
-
- if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
- || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
- {
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
- FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- return reduced;
- }
-
- if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
- && (lbt != FFEINFO_basictypeCOMPLEX))
- {
- if ((rbt != FFEINFO_basictypeINTEGER)
- && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_MATH_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- }
- else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
- && (rbt != FFEINFO_basictypeCOMPLEX))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_MATH_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lrk != 0)
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_MATH_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_MATH_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
-
- reduced = ffeexpr_reduced_power_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- INTEGER, REAL, or COMPLEX. Determine common basictype and
- size for reduction (flag expression for combined hollerith/typeless
- situations for later determination of effective basictype). If both left
- and right arguments have where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING. Create CONVERT ops for args where
- needed. Note that real**int or complex**int
- comes out as int = real**int etc with no conversions.
-
- If these requirements cannot be met, generate error message using the
- info in l, op, and r arguments and assign basictype, size, kind, and where
- of ANY. */
-
-static ffebld
-ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh, nwh;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if ((rbt == FFEINFO_basictypeINTEGER)
- && ((lbt == FFEINFO_basictypeREAL)
- || (lbt == FFEINFO_basictypeCOMPLEX)))
- {
- nbt = lbt;
- nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
- if (nkt != FFEINFO_kindtypeREALDEFAULT)
- {
- nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
- if (nkt != FFEINFO_kindtypeREALDOUBLE)
- nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
- }
- if (rkt == FFEINFO_kindtypeINTEGER4)
- {
- /* xgettext:no-c-format */
- ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
- FFEBAD_severityWARNING);
- ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
- {
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token,
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- rkt = FFEINFO_kindtypeINTEGERDEFAULT;
- }
- }
- else
- {
- ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
-
-#if 0 /* INTEGER4**INTEGER4 works now. */
- if ((nbt == FFEINFO_basictypeINTEGER)
- && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
- nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
-#endif
- if (((nbt == FFEINFO_basictypeREAL)
- || (nbt == FFEINFO_basictypeCOMPLEX))
- && (nkt != FFEINFO_kindtypeREALDEFAULT))
- {
- nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
- if (nkt != FFEINFO_kindtypeREALDOUBLE)
- nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
- }
- /* else Gonna turn into an error below. */
- }
-
- if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
- || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
- {
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
- FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- if (rbt != FFEINFO_basictypeINTEGER)
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- return reduced;
- }
-
- if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
- && (lbt != FFEINFO_basictypeCOMPLEX))
- {
- if ((rbt != FFEINFO_basictypeINTEGER)
- && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_MATH_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- }
- else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
- && (rbt != FFEINFO_basictypeCOMPLEX))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_MATH_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lrk != 0)
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_MATH_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_MATH_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
-
- reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- INTEGER, REAL, or CHARACTER. Determine common basictype and
- size for reduction. If both left
- and right arguments have where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING. Create CONVERT ops for args where
- needed. Convert typeless
- constants to the desired type/size explicitly.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh, nwh;
- ffetargetCharacterSize lsz, rsz;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- lsz = ffebld_size_known (ffebld_left (reduced));
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- rsz = ffebld_size_known (ffebld_right (reduced));
-
- ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
-
- if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
- || (nbt == FFEINFO_basictypeCHARACTER))
- && (lrk == 0) && (rrk == 0))
- {
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- if ((lsz != FFETARGET_charactersizeNONE)
- && (rsz != FFETARGET_charactersizeNONE))
- lsz = rsz = (lsz > rsz) ? lsz : rsz;
-
- ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
- 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, nbt, nkt, 0, lsz,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, nbt, nkt, 0, rsz,
- FFEEXPR_contextLET));
- return reduced;
- }
-
- if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
- && (lbt != FFEINFO_basictypeCHARACTER))
- {
- if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
- && (rbt != FFEINFO_basictypeCHARACTER))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- }
- else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
- && (rbt != FFEINFO_basictypeCHARACTER))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lrk != 0)
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_RELOP_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_RELOP_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
-
- reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
-
- Sigh. */
-
-static ffebld
-ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
-{
- ffeinfo rinfo;
- ffeinfoBasictype rbt;
- ffeinfoKindtype rkt;
- ffeinfoRank rrk;
- ffeinfoKind rkd;
- ffeinfoWhere rwh;
-
- rinfo = ffebld_info (ffebld_left (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- r->token, op->token, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- rinfo = ffebld_info (ffebld_left (reduced));
- rbt = FFEINFO_basictypeINTEGER;
- rkt = FFEINFO_kindtypeINTEGERDEFAULT;
- rrk = 0;
- rkd = FFEINFO_kindENTITY;
- rwh = ffeinfo_where (rinfo);
- }
-
- if (rbt == FFEINFO_basictypeLOGICAL)
- {
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- r->token, op->token, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- }
-
- return reduced;
-}
-
-/* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
-
- reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
-
- Sigh. */
-
-static ffebld
-ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
-{
- ffeinfo rinfo;
- ffeinfoBasictype rbt;
- ffeinfoKindtype rkt;
- ffeinfoRank rrk;
- ffeinfoKind rkd;
- ffeinfoWhere rwh;
-
- rinfo = ffebld_info (ffebld_left (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
- FFEINFO_kindtypeLOGICALDEFAULT,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- rinfo = ffebld_info (ffebld_left (reduced));
- rbt = FFEINFO_basictypeLOGICAL;
- rkt = FFEINFO_kindtypeLOGICALDEFAULT;
- rrk = 0;
- rkd = FFEINFO_kindENTITY;
- rwh = ffeinfo_where (rinfo);
- }
-
- return reduced;
-}
-
-/* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
-
- reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
-
- Sigh. */
-
-static ffebld
-ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo;
- ffeinfoBasictype lbt, rbt;
- ffeinfoKindtype lkt, rkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if ((lbt == FFEINFO_basictypeTYPELESS)
- || (lbt == FFEINFO_basictypeHOLLERITH))
- {
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, FFEINFO_basictypeINTEGER, 0,
- FFEINFO_kindtypeINTEGERDEFAULT,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- linfo = ffebld_info (ffebld_left (reduced));
- rinfo = ffebld_info (ffebld_right (reduced));
- lbt = rbt = FFEINFO_basictypeINTEGER;
- lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
- lrk = rrk = 0;
- lkd = rkd = FFEINFO_kindENTITY;
- lwh = ffeinfo_where (linfo);
- rwh = ffeinfo_where (rinfo);
- }
- else
- {
- ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
- l->token, ffebld_right (reduced), r->token,
- FFEEXPR_contextLET));
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- }
- }
- else
- {
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
- r->token, ffebld_left (reduced), l->token,
- FFEEXPR_contextLET));
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- }
- /* else Leave it alone. */
- }
-
- if (lbt == FFEINFO_basictypeLOGICAL)
- {
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- }
-
- if (rbt == FFEINFO_basictypeLOGICAL)
- {
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- }
-
- return reduced;
-}
-
-/* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
-
- reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
-
- Sigh. */
-
-static ffebld
-ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r, bool *bothlogical)
-{
- ffeinfo linfo, rinfo;
- ffeinfoBasictype lbt, rbt;
- ffeinfoKindtype lkt, rkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if ((lbt == FFEINFO_basictypeTYPELESS)
- || (lbt == FFEINFO_basictypeHOLLERITH))
- {
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- linfo = ffebld_info (ffebld_left (reduced));
- rinfo = ffebld_info (ffebld_right (reduced));
- lbt = rbt = FFEINFO_basictypeLOGICAL;
- lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
- lrk = rrk = 0;
- lkd = rkd = FFEINFO_kindENTITY;
- lwh = ffeinfo_where (linfo);
- rwh = ffeinfo_where (rinfo);
- }
- else
- {
- ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
- l->token, ffebld_right (reduced), r->token,
- FFEEXPR_contextLET));
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- }
- }
- else
- {
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
- r->token, ffebld_left (reduced), l->token,
- FFEEXPR_contextLET));
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- }
- /* else Leave it alone. */
- }
-
- if (lbt == FFEINFO_basictypeLOGICAL)
- {
- ffebld_set_left (reduced,
- ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token,
- FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- }
-
- if (rbt == FFEINFO_basictypeLOGICAL)
- {
- ffebld_set_right (reduced,
- ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token,
- FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- }
-
- if (bothlogical != NULL)
- *bothlogical = (lbt == FFEINFO_basictypeLOGICAL
- && rbt == FFEINFO_basictypeLOGICAL);
-
- return reduced;
-}
-
-/* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
- is found.
-
- The idea is to process the tokens as they would be done by normal
- expression processing, with the key things being telling the lexer
- when hollerith/character constants are about to happen, until the
- true closing token is found. */
-
-static ffelexHandler
-ffeexpr_find_close_paren_ (ffelexToken t,
- ffelexHandler after)
-{
- ffeexpr_find_.after = after;
- ffeexpr_find_.level = 1;
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
-}
-
-static ffelexHandler
-ffeexpr_nil_finished_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- if (--ffeexpr_find_.level == 0)
- return (ffelexHandler) ffeexpr_find_.after;
- return (ffelexHandler) ffeexpr_nil_binary_;
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLON:
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- default:
- if (--ffeexpr_find_.level == 0)
- return (ffelexHandler) ffeexpr_find_.after (t);
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_rhs_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeQUOTE:
- if (ffe_is_vxt ())
- return (ffelexHandler) ffeexpr_nil_quote_;
- ffelex_set_expecting_hollerith (-1, '\"',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffeexpr_nil_apostrophe_;
-
- case FFELEX_typeAPOSTROPHE:
- ffelex_set_expecting_hollerith (-1, '\'',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffeexpr_nil_apostrophe_;
-
- case FFELEX_typePERCENT:
- return (ffelexHandler) ffeexpr_nil_percent_;
-
- case FFELEX_typeOPEN_PAREN:
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFELEX_typePLUS:
- case FFELEX_typeMINUS:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFELEX_typePERIOD:
- return (ffelexHandler) ffeexpr_nil_period_;
-
- case FFELEX_typeNUMBER:
- ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
- if (ffeexpr_hollerith_count_ > 0)
- ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
- '\0',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffeexpr_nil_number_;
-
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- return (ffelexHandler) ffeexpr_nil_name_rhs_;
-
- case FFELEX_typeASTERISK:
- case FFELEX_typeSLASH:
- case FFELEX_typePOWER:
- case FFELEX_typeCONCAT:
- case FFELEX_typeREL_EQ:
- case FFELEX_typeREL_NE:
- case FFELEX_typeREL_LE:
- case FFELEX_typeREL_GE:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_finished_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_period_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffestr_other (t);
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherNone:
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
-
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- case FFESTR_otherNOT:
- return (ffelexHandler) ffeexpr_nil_end_period_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_swallow_period_;
- }
- break; /* Nothing really reaches here. */
-
- case FFELEX_typeNUMBER:
- return (ffelexHandler) ffeexpr_nil_real_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_end_period_ (ffelexToken t)
-{
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherNOT:
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-
- default:
- assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
- exit (0);
- return NULL;
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_swallow_period_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-static ffelexHandler
-ffeexpr_nil_real_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (((ffelex_token_type (t) != FFELEX_typeNAME)
- && (ffelex_token_type (t) != FFELEX_typeNAMES))
- || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q')))
- && ffeexpr_isdigits_ (++p)))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- if (*p == '\0')
- return (ffelexHandler) ffeexpr_nil_real_exponent_;
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_real_exponent_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
-}
-
-static ffelexHandler
-ffeexpr_nil_real_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (ffeexpr_hollerith_count_ > 0)
- ffelex_set_expecting_hollerith (0, '\0',
- ffewhere_line_unknown (),
- ffewhere_column_unknown ());
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q'))
- && ffeexpr_isdigits_ (++p))
- {
- if (*p == '\0')
- {
- ffeexpr_find_.t = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_nil_number_exponent_;
- }
- return (ffelexHandler) ffeexpr_nil_binary_;
- }
- break;
-
- case FFELEX_typePERIOD:
- ffeexpr_find_.t = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_nil_number_period_;
-
- case FFELEX_typeHOLLERITH:
- return (ffelexHandler) ffeexpr_nil_binary_;
-
- default:
- break;
- }
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_number_exponent_ (ffelexToken t)
-{
- ffelexHandler nexthandler;
-
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- nexthandler
- = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_number_period_ (ffelexToken t)
-{
- ffelexHandler nexthandler;
- char d;
- const char *p;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q'))
- && ffeexpr_isdigits_ (++p))
- {
- if (*p == '\0')
- return (ffelexHandler) ffeexpr_nil_number_per_exp_;
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_binary_;
- }
- nexthandler
- = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
-
- case FFELEX_typeNUMBER:
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_number_real_;
-
- default:
- break;
- }
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_number_per_exp_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- ffelexHandler nexthandler;
-
- nexthandler
- = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_real_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (((ffelex_token_type (t) != FFELEX_typeNAME)
- && (ffelex_token_type (t) != FFELEX_typeNAMES))
- || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q')))
- && ffeexpr_isdigits_ (++p)))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- if (*p == '\0')
- return (ffelexHandler) ffeexpr_nil_number_real_exp_;
-
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_real_exp_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
-}
-
-static ffelexHandler
-ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typePLUS:
- case FFELEX_typeMINUS:
- case FFELEX_typeASTERISK:
- case FFELEX_typeSLASH:
- case FFELEX_typePOWER:
- case FFELEX_typeCONCAT:
- case FFELEX_typeOPEN_ANGLE:
- case FFELEX_typeCLOSE_ANGLE:
- case FFELEX_typeREL_EQ:
- case FFELEX_typeREL_NE:
- case FFELEX_typeREL_GE:
- case FFELEX_typeREL_LE:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFELEX_typePERIOD:
- return (ffelexHandler) ffeexpr_nil_binary_period_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_finished_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_period_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffestr_other (t);
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- case FFESTR_otherNOT:
- return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_binary_end_per_;
- }
- break; /* Nothing really reaches here. */
-
- default:
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_end_per_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_sw_per_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_quote_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_apostrophe_ (ffelexToken t)
-{
- assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
- return (ffelexHandler) ffeexpr_nil_apos_char_;
-}
-
-static ffelexHandler
-ffeexpr_nil_apos_char_ (ffelexToken t)
-{
- char c;
-
- if ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- {
- if ((ffelex_token_length (t) == 1)
- && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
- 'B', 'b')
- || ffesrc_char_match_init (c, 'O', 'o')
- || ffesrc_char_match_init (c, 'X', 'x')
- || ffesrc_char_match_init (c, 'Z', 'z')))
- return (ffelexHandler) ffeexpr_nil_binary_;
- }
- if ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_substrp_ (t);
-}
-
-static ffelexHandler
-ffeexpr_nil_name_rhs_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeQUOTE:
- case FFELEX_typeAPOSTROPHE:
- ffelex_set_hexnum (TRUE);
- return (ffelexHandler) ffeexpr_nil_name_apos_;
-
- case FFELEX_typeOPEN_PAREN:
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_name_apos_ (ffelexToken t)
-{
- if (ffelex_token_type (t) == FFELEX_typeNAME)
- return (ffelexHandler) ffeexpr_nil_name_apos_name_;
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-}
-
-static ffelexHandler
-ffeexpr_nil_name_apos_name_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeAPOSTROPHE:
- case FFELEX_typeQUOTE:
- return (ffelexHandler) ffeexpr_nil_finished_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_finished_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_percent_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_stack_->percent = ffeexpr_percent_ (t);
- ffeexpr_find_.t = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_nil_percent_name_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- }
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_percent_name_ (ffelexToken t)
-{
- ffelexHandler nexthandler;
-
- if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
- {
- nexthandler
- = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffelex_token_kill (ffeexpr_find_.t);
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-static ffelexHandler
-ffeexpr_nil_substrp_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-/* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
-
- ffelexToken t;
- return ffeexpr_finished_(t);
-
- Reduces expression stack to one (or zero) elements by repeatedly reducing
- the top operator on the stack (or, if the top element on the stack is
- itself an operator, issuing an error message and discarding it). Calls
- finishing routine with the expression, returning the ffelexHandler it
- returns to the caller. */
-
-static ffelexHandler
-ffeexpr_finished_ (ffelexToken t)
-{
- ffeexprExpr_ operand; /* This is B in -B or A+B. */
- ffebld expr;
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffebldConstant constnode; /* For detecting magical number. */
- ffelexToken ft; /* Temporary copy of first token in
- expression. */
- ffelexHandler next;
- ffeinfo info;
- bool error = FALSE;
-
- while (((operand = ffeexpr_stack_->exprstack) != NULL)
- && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
- {
- if (operand->type == FFEEXPR_exprtypeOPERAND_)
- ffeexpr_reduce_ ();
- else
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
- ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
- ffebad_finish ();
- }
- ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
- operator. */
- ffeexpr_expr_kill_ (operand);
- }
- }
-
- assert ((operand == NULL) || (operand->previous == NULL));
-
- ffebld_pool_pop ();
- if (operand == NULL)
- expr = NULL;
- else
- {
- expr = operand->u.operand;
- info = ffebld_info (expr);
- if ((ffebld_op (expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
- {
- ffetarget_integer_bad_magical (operand->token);
- }
- ffeexpr_expr_kill_ (operand);
- ffeexpr_stack_->exprstack = NULL;
- }
-
- ft = ffeexpr_stack_->first_token;
-
-again: /* :::::::::::::::::::: */
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextLET:
- case FFEEXPR_contextSFUNCDEF:
- error = (expr == NULL)
- || (ffeinfo_rank (info) != 0);
- break;
-
- case FFEEXPR_contextPAREN_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- break;
- }
- break;
-
- case FFEEXPR_contextPARENFILENUM_:
- if (ffelex_token_type (t) != FFELEX_typeCOMMA)
- ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextPARENFILEUNIT_:
- if (ffelex_token_type (t) != FFELEX_typeCOMMA)
- ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- if (!ffe_is_ugly_args ()
- && ffebad_start (FFEBAD_ACTUALARG))
- {
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- break;
-
- default:
- break;
- }
- error = (expr != NULL) && (ffeinfo_rank (info) != 0);
- break;
-
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
-#if 0 /* Should never get here. */
- expr = ffeexpr_convert (expr, ft, ft,
- FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
-#else
- assert ("why hollerith/typeless in actualarg_?" == NULL);
-#endif
- break;
-
- default:
- break;
- }
- switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- case FFEBLD_opPERCENT_LOC:
- case FFEBLD_opPERCENT_VAL:
- case FFEBLD_opPERCENT_REF:
- case FFEBLD_opPERCENT_DESCR:
- error = FALSE;
- break;
-
- default:
- error = (expr != NULL) && (ffeinfo_rank (info) != 0);
- break;
- }
- {
- ffesymbol s;
- ffeinfoWhere where;
- ffeinfoKind kind;
-
- if (!error
- && (expr != NULL)
- && (ffebld_op (expr) == FFEBLD_opSYMTER)
- && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
- (where == FFEINFO_whereINTRINSIC)
- || (where == FFEINFO_whereGLOBAL)
- || ((where == FFEINFO_whereDUMMY)
- && ((kind = ffesymbol_kind (s)),
- (kind == FFEINFO_kindFUNCTION)
- || (kind == FFEINFO_kindSUBROUTINE))))
- && !ffesymbol_explicitwhere (s))
- {
- ffebad_start (where == FFEINFO_whereINTRINSIC
- ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- ffesymbol_signal_change (s);
- ffesymbol_set_explicitwhere (s, TRUE);
- ffesymbol_signal_unreported (s);
- }
- }
- break;
-
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeINTEGER:
- /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
- unmolested. Leave it to downstream to handle kinds. */
- break;
-
- default:
- error = TRUE;
- break;
- }
- break; /* expr==NULL ok for substring; element case
- caught by callback. */
-
- case FFEEXPR_contextRETURN:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextDO:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- error = !ffe_is_ugly_logint ();
- if (!ffeexpr_stack_->is_rhs)
- break; /* Don't convert lhs variable. */
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- ffeinfo_kindtype (ffebld_info (expr)), 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- if (!ffeexpr_stack_->is_rhs)
- {
- error = TRUE;
- break; /* Don't convert lhs variable. */
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- break;
-
- default:
- error = TRUE;
- break;
- }
- if (!ffeexpr_stack_->is_rhs
- && (ffebld_op (expr) != FFEBLD_opSYMTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextDOWHILE:
- case FFEEXPR_contextIF:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeLOGICAL:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextASSIGN:
- case FFEEXPR_contextAGOTO:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
- break;
-
- case FFEINFO_basictypeLOGICAL:
- error = !ffe_is_ugly_logint ()
- || (ffeinfo_kindtype (info) != ffecom_label_kind ());
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffebld_op (expr) != FFEBLD_opSYMTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextCGOTO:
- case FFEEXPR_contextFORMAT:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextARITHIF:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextSTOP:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
- || (ffebld_conter_orig (expr) != NULL)))
- error = TRUE;
- break;
-
- case FFEEXPR_contextINCLUDE:
- error = (expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
- || (ffebld_op (expr) != FFEBLD_opCONTER)
- || (ffebld_conter_orig (expr) != NULL);
- break;
-
- case FFEEXPR_contextSELECTCASE:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeCHARACTER:
- case FFEINFO_basictypeLOGICAL:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextCASE:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeCHARACTER:
- case FFEINFO_basictypeLOGICAL:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextDIMLISTCOMMON:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextEQVINDEX_:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextPARAMETER:
- if (ffeexpr_stack_->is_rhs)
- error = (expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffebld_op (expr) != FFEBLD_opCONTER);
- else
- error = (expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffebld_op (expr) != FFEBLD_opSYMTER);
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextIMPDOCTRL_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- if (!ffeexpr_stack_->is_rhs
- && (ffebld_op (expr) != FFEBLD_opSYMTER))
- error = TRUE;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- if (! ffe_is_ugly_logint ())
- error = TRUE;
- if (! ffeexpr_stack_->is_rhs)
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- ffeinfo_kindtype (info), 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- break;
-
- case FFEINFO_basictypeREAL:
- if (!ffeexpr_stack_->is_rhs
- && ffe_is_warn_surprising ()
- && !error)
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string (ffelex_token_text (ft));
- ffebad_finish ();
- }
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextDATAIMPDOCTRL_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- if (ffeexpr_stack_->is_rhs)
- {
- if ((ffebld_op (expr) != FFEBLD_opCONTER)
- && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
- error = TRUE;
- }
- else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
- error = TRUE;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- if (! ffeexpr_stack_->is_rhs)
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- ffeinfo_kindtype (info), 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- if (ffeexpr_stack_->is_rhs
- && (ffeinfo_kindtype (ffebld_info (expr))
- != FFEINFO_kindtypeINTEGERDEFAULT))
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeREAL:
- if (!ffeexpr_stack_->is_rhs
- && ffe_is_warn_surprising ()
- && !error)
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string (ffelex_token_text (ft));
- ffebad_finish ();
- }
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextIMPDOITEM_:
- if (ffelex_token_type (t) == FFELEX_typeEQUALS)
- {
- ffeexpr_stack_->is_rhs = FALSE;
- ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
- goto again; /* :::::::::::::::::::: */
- }
- /* Fall through. */
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextFILEVXTCODE:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- break;
- }
- error = (expr == NULL)
- || ((ffeinfo_rank (info) != 0)
- && ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
- || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
- == FFEBLD_opSTAR))); /* Bad if null expr, or if
- array that is not a SYMTER
- (can't happen yet, I
- think) or has a NULL or
- STAR (assumed) array
- size. */
- break;
-
- case FFEEXPR_contextIMPDOITEMDF_:
- if (ffelex_token_type (t) == FFELEX_typeEQUALS)
- {
- ffeexpr_stack_->is_rhs = FALSE;
- ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
- goto again; /* :::::::::::::::::::: */
- }
- /* Fall through. */
- case FFEEXPR_contextIOLISTDF:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- break;
- }
- error
- = (expr == NULL)
- || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
- && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
- || ((ffeinfo_rank (info) != 0)
- && ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
- || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
- == FFEBLD_opSTAR))); /* Bad if null expr,
- non-default-kindtype
- character expr, or if
- array that is not a SYMTER
- (can't happen yet, I
- think) or has a NULL or
- STAR (assumed) array
- size. */
- break;
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- error = (expr == NULL)
- || (ffebld_op (expr) != FFEBLD_opARRAYREF)
- || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
- && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
- break;
-
- case FFEEXPR_contextDATAIMPDOINDEX_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
- && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
- error = TRUE;
- break;
-
- case FFEEXPR_contextDATA:
- if (expr == NULL)
- error = TRUE;
- else if (ffeexpr_stack_->is_rhs)
- error = (ffebld_op (expr) != FFEBLD_opCONTER);
- else if (ffebld_op (expr) == FFEBLD_opSYMTER)
- error = FALSE;
- else
- error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
- break;
-
- case FFEEXPR_contextINITVAL:
- error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
- break;
-
- case FFEEXPR_contextEQUIVALENCE:
- if (expr == NULL)
- error = TRUE;
- else if (ffebld_op (expr) == FFEBLD_opSYMTER)
- error = FALSE;
- else
- error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
- break;
-
- case FFEEXPR_contextFILEASSOC:
- case FFEEXPR_contextFILEINT:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- /* Maybe this should be supported someday, but, right now,
- g77 can't generate a call to libf2c to write to an
- integer other than the default size. */
- error = ((! ffeexpr_stack_->is_rhs)
- && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILEDFINT:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILELOG:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILECHAR:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeCHARACTER:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILENUMCHAR:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeCHARACTER:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextFILEDFCHAR:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeCHARACTER:
- error
- = (ffeinfo_kindtype (info)
- != FFEINFO_kindtypeCHARACTERDEFAULT);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if (!ffeexpr_stack_->is_rhs
- && (ffebld_op (expr) == FFEBLD_opSUBSTR))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- if ((error = (ffeinfo_rank (info) != 0)))
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if ((error = (ffeinfo_rank (info) != 0)))
- break;
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- if ((error = (ffeinfo_rank (info) != 0)))
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffebld_op (expr))
- { /* As if _lhs had been called instead of
- _rhs. */
- case FFEBLD_opSYMTER:
- error
- = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
- break;
-
- case FFEBLD_opSUBSTR:
- error = (ffeinfo_where (ffebld_info (expr))
- == FFEINFO_whereCONSTANT_SUBOBJECT);
- break;
-
- case FFEBLD_opARRAYREF:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if (!error
- && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
- || ((ffeinfo_rank (info) != 0)
- && ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
- || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
- == FFEBLD_opSTAR))))) /* Bad if
- non-default-kindtype
- character expr, or if
- array that is not a SYMTER
- (can't happen yet, I
- think), or has a NULL or
- STAR (assumed) array
- size. */
- error = TRUE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextFILEFORMAT:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (expr == NULL)
- || ((ffeinfo_rank (info) != 0) ?
- ffe_is_pedantic () /* F77 C5. */
- : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
- || (ffebld_op (expr) != FFEBLD_opSYMTER);
- break;
-
- case FFEINFO_basictypeLOGICAL:
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- /* F77 C5 -- must be an array of hollerith. */
- error
- = ffe_is_pedantic ()
- || (ffeinfo_rank (info) == 0);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
- || ((ffeinfo_rank (info) != 0)
- && ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
- || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
- == FFEBLD_opSTAR)))) /* Bad if
- non-default-kindtype
- character expr, or if
- array that is not a SYMTER
- (can't happen yet, I
- think), or has a NULL or
- STAR (assumed) array
- size. */
- error = TRUE;
- else
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextLOC_:
- /* See also ffeintrin_check_loc_. */
- if ((expr == NULL)
- || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
- || ((ffebld_op (expr) != FFEBLD_opSYMTER)
- && (ffebld_op (expr) != FFEBLD_opSUBSTR)
- && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
- error = TRUE;
- break;
-
- default:
- error = FALSE;
- break;
- }
-
- if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
- {
- ffebad_start (FFEBAD_EXPR_WRONG);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- expr = ffebld_new_any ();
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
-
- callback = ffeexpr_stack_->callback;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
- sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
-
- ffebld expr;
- expr = ffeexpr_finished_ambig_(expr);
-
- Replicates a bit of ffeexpr_finished_'s task when in a context
- of UNIT or FORMAT. */
-
-static ffebld
-ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
-{
- ffeinfo info = ffebld_info (expr);
- bool error;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
- if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
- {
- error = FALSE;
- break;
- }
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = (ffeinfo_rank (info) != 0);
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffebld_op (expr))
- { /* As if _lhs had been called instead of
- _rhs. */
- case FFEBLD_opSYMTER:
- error
- = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
- break;
-
- case FFEBLD_opSUBSTR:
- error = (ffeinfo_where (ffebld_info (expr))
- == FFEINFO_whereCONSTANT_SUBOBJECT);
- break;
-
- case FFEBLD_opARRAYREF:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- default:
- assert ("bad context" == NULL);
- error = TRUE;
- break;
- }
-
- if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
- {
- ffebad_start (FFEBAD_EXPR_WRONG);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- expr = ffebld_new_any ();
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
-
- return expr;
-}
-
-/* ffeexpr_token_lhs_ -- Initial state for lhs expression
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Basically a smaller version of _rhs_; keep them both in sync, of course. */
-
-static ffelexHandler
-ffeexpr_token_lhs_ (ffelexToken t)
-{
-
- /* When changing the list of valid initial lhs tokens, check whether to
- update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
- READ (expr) <token> case -- it assumes it knows which tokens <token> can
- be to indicate an lhs (or implied DO), which right now is the set
- {NAME,OPEN_PAREN}.
-
- This comment also appears in ffeexpr_token_first_lhs_. */
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_name_lhs_;
-
- default:
- return (ffelexHandler) ffeexpr_finished_ (t);
- }
-}
-
-/* ffeexpr_token_rhs_ -- Initial state for rhs expression
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- The initial state and the post-binary-operator state are the same and
- both handled here, with the expression stack used to distinguish
- between them. Binary operators are invalid here; unary operators,
- constants, subexpressions, and name references are valid. */
-
-static ffelexHandler
-ffeexpr_token_rhs_ (ffelexToken t)
-{
- ffeexprExpr_ e;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeQUOTE:
- if (ffe_is_vxt ())
- {
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_quote_;
- }
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- ffelex_set_expecting_hollerith (-1, '\"',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- /* Don't have to unset this one. */
- return (ffelexHandler) ffeexpr_token_apostrophe_;
-
- case FFELEX_typeAPOSTROPHE:
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- ffelex_set_expecting_hollerith (-1, '\'',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- /* Don't have to unset this one. */
- return (ffelexHandler) ffeexpr_token_apostrophe_;
-
- case FFELEX_typePERCENT:
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_percent_;
-
- case FFELEX_typeOPEN_PAREN:
- ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextPAREN_,
- ffeexpr_cb_close_paren_c_);
-
- case FFELEX_typePLUS:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeUNARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorADD_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
- e->u.operator.as = FFEEXPR_operatorassociativityADD_;
- ffeexpr_exprstack_push_unary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeMINUS:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeUNARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
- e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
- ffeexpr_exprstack_push_unary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typePERIOD:
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_period_;
-
- case FFELEX_typeNUMBER:
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
- if (ffeexpr_hollerith_count_ > 0)
- ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
- '\0',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffeexpr_token_number_;
-
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextINDEXORACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- return (ffelexHandler) ffeexpr_token_name_arg_;
-
- default:
- return (ffelexHandler) ffeexpr_token_name_rhs_;
- }
-
- case FFELEX_typeASTERISK:
- case FFELEX_typeSLASH:
- case FFELEX_typePOWER:
- case FFELEX_typeCONCAT:
- case FFELEX_typeREL_EQ:
- case FFELEX_typeREL_NE:
- case FFELEX_typeREL_LE:
- case FFELEX_typeREL_GE:
- if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- return (ffelexHandler) ffeexpr_token_rhs_;
-
-#if 0
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCLOSE_ANGLE:
- case FFELEX_typeCLOSE_PAREN:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
-#endif
- default:
- return (ffelexHandler) ffeexpr_finished_ (t);
- }
-}
-
-/* ffeexpr_token_period_ -- Rhs PERIOD
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle a period detected at rhs (expecting unary op or operand) state.
- Must begin a floating-point value (as in .12) or a dot-dot name, of
- which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
- valid names represent binary operators, which are invalid here because
- there isn't an operand at the top of the stack. */
-
-static ffelexHandler
-ffeexpr_token_period_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffestr_other (t);
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherNone:
- if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
-
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- case FFESTR_otherNOT:
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_end_period_;
-
- default:
- if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_swallow_period_;
- }
- break; /* Nothing really reaches here. */
-
- case FFELEX_typeNUMBER:
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_real_;
-
- default:
- if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
- }
-}
-
-/* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
- or operator) state. If period isn't found, issue a diagnostic but
- pretend we saw one. ffeexpr_current_dotdot_ must already contained the
- dotdot representation of the name in between the two PERIOD tokens. */
-
-static ffelexHandler
-ffeexpr_token_end_period_ (ffelexToken t)
-{
- ffeexprExpr_ e;
-
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- {
- if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
- ffebad_finish ();
- }
- }
-
- ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
- token. */
-
- e = ffeexpr_expr_new_ ();
- e->token = ffeexpr_tokens_[0];
-
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherNOT:
- e->type = FFEEXPR_exprtypeUNARY_;
- e->u.operator.op = FFEEXPR_operatorNOT_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
- e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
- ffeexpr_exprstack_push_unary_ (e);
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFESTR_otherTRUE:
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand
- = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
- ffeexpr_exprstack_push_operand_ (e);
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- return (ffelexHandler) ffeexpr_token_binary_;
-
- case FFESTR_otherFALSE:
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand
- = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
- ffeexpr_exprstack_push_operand_ (e);
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- return (ffelexHandler) ffeexpr_token_binary_;
-
- default:
- assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
- exit (0);
- return NULL;
- }
-}
-
-/* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- A diagnostic has already been issued; just swallow a period if there is
- one, then continue with ffeexpr_token_rhs_. */
-
-static ffelexHandler
-ffeexpr_token_swallow_period_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
-
- return (ffelexHandler) ffeexpr_token_rhs_;
-}
-
-/* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- After a period and a string of digits, check next token for possible
- exponent designation (D, E, or Q as first/only character) and continue
- real-number handling accordingly. Else form basic real constant, push
- onto expression stack, and enter binary state using current token (which,
- if it is a name not beginning with D, E, or Q, will certainly result
- in an error, but that's not for this routine to deal with). */
-
-static ffelexHandler
-ffeexpr_token_real_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (((ffelex_token_type (t) != FFELEX_typeNAME)
- && (ffelex_token_type (t) != FFELEX_typeNAMES))
- || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q')))
- && ffeexpr_isdigits_ (++p)))
- {
-#if 0
- /* This code has been removed because it seems inconsistent to
- produce a diagnostic in this case, but not all of the other
- ones that look for an exponent and cannot recognize one. */
- if (((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
- {
- char bad[2];
-
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- bad[0] = *(p - 1);
- bad[1] = '\0';
- ffebad_string (bad);
- ffebad_finish ();
- }
-#endif
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- /* Just exponent character by itself? In which case, PLUS or MINUS must
- surely be next, followed by a NUMBER token. */
-
- if (*p == '\0')
- {
- ffeexpr_tokens_[2] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_real_exponent_;
- }
-
- ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- t, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Ensures this token is PLUS or MINUS, preserves it, goes to final state
- for real number (exponent digits). Else issues diagnostic, assumes a
- zero exponent field for number, passes token on to binary state as if
- previous token had been "E0" instead of "E", for example. */
-
-static ffelexHandler
-ffeexpr_token_real_exponent_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
- ffelex_token_where_column (ffeexpr_tokens_[2]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- ffeexpr_tokens_[3] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_real_exp_sign_;
-}
-
-/* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Make sure token is a NUMBER, make a real constant out of all we have and
- push it onto the expression stack. Else issue diagnostic and pretend
- exponent field was a zero. */
-
-static ffelexHandler
-ffeexpr_token_real_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
- ffelex_token_where_column (ffeexpr_tokens_[2]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[3]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
- ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
- ffeexpr_tokens_[3], t);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[3]);
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_number_ -- Rhs NUMBER
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- If the token is a period, we may have a floating-point number, or an
- integer followed by a dotdot binary operator. If the token is a name
- beginning with D, E, or Q, we definitely have a floating-point number.
- If the token is a hollerith constant, that's what we've got, so push
- it onto the expression stack and continue with the binary state.
-
- Otherwise, we have an integer followed by something the binary state
- should be able to swallow. */
-
-static ffelexHandler
-ffeexpr_token_number_ (ffelexToken t)
-{
- ffeexprExpr_ e;
- ffeinfo ni;
- char d;
- const char *p;
-
- if (ffeexpr_hollerith_count_ > 0)
- ffelex_set_expecting_hollerith (0, '\0',
- ffewhere_line_unknown (),
- ffewhere_column_unknown ());
-
- /* See if we've got a floating-point number here. */
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q'))
- && ffeexpr_isdigits_ (++p))
- {
-
- /* Just exponent character by itself? In which case, PLUS or MINUS
- must surely be next, followed by a NUMBER token. */
-
- if (*p == '\0')
- {
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_number_exponent_;
- }
- ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
- NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_binary_;
- }
- break;
-
- case FFELEX_typePERIOD:
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_number_period_;
-
- case FFELEX_typeHOLLERITH:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
- ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- ffelex_token_length (t));
- ffebld_set_info (e->u.operand, ni);
- ffeexpr_exprstack_push_operand_ (e);
- return (ffelexHandler) ffeexpr_token_binary_;
-
- default:
- break;
- }
-
- /* Nothing specific we were looking for, so make an integer and pass the
- current token to the binary state. */
-
- ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
- NULL, NULL, NULL);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
-}
-
-/* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Ensures this token is PLUS or MINUS, preserves it, goes to final state
- for real number (exponent digits). Else treats number as integer, passes
- name to binary, passes current token to subsequent handler. */
-
-static ffelexHandler
-ffeexpr_token_number_exponent_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- ffeexprExpr_ e;
- ffelexHandler nexthandler;
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
- (ffeexpr_tokens_[0]));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
- ffeexpr_exprstack_push_operand_ (e);
- nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffeexpr_tokens_[2] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_number_exp_sign_;
-}
-
-/* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Make sure token is a NUMBER, make a real constant out of all we have and
- push it onto the expression stack. Else issue diagnostic and pretend
- exponent field was a zero. */
-
-static ffelexHandler
-ffeexpr_token_number_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
- ffelex_token_where_column (ffeexpr_tokens_[1]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
- ffeexpr_tokens_[0], NULL, NULL,
- ffeexpr_tokens_[1], ffeexpr_tokens_[2],
- NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
- ffeexpr_tokens_[0], NULL, NULL,
- ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle a period detected following a number at rhs state. Must begin a
- floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
-
-static ffelexHandler
-ffeexpr_token_number_period_ (ffelexToken t)
-{
- ffeexprExpr_ e;
- ffelexHandler nexthandler;
- const char *p;
- char d;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q'))
- && ffeexpr_isdigits_ (++p))
- {
-
- /* Just exponent character by itself? In which case, PLUS or MINUS
- must surely be next, followed by a NUMBER token. */
-
- if (*p == '\0')
- {
- ffeexpr_tokens_[2] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_number_per_exp_;
- }
- ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
- ffeexpr_tokens_[1], NULL, t, NULL,
- NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) ffeexpr_token_binary_;
- }
- /* A name not representing an exponent, so assume it will be something
- like EQ, make an integer from the number, pass the period to binary
- state and the current token to the resulting state. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
- (ffeexpr_tokens_[0]));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- ffeexpr_exprstack_push_operand_ (e);
- nexthandler = (ffelexHandler) ffeexpr_token_binary_
- (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) (*nexthandler) (t);
-
- case FFELEX_typeNUMBER:
- ffeexpr_tokens_[2] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_number_real_;
-
- default:
- break;
- }
-
- /* Nothing specific we were looking for, so make a real number and pass the
- period and then the current token to the binary state. */
-
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- NULL, NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
-}
-
-/* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Ensures this token is PLUS or MINUS, preserves it, goes to final state
- for real number (exponent digits). Else treats number as real, passes
- name to binary, passes current token to subsequent handler. */
-
-static ffelexHandler
-ffeexpr_token_number_per_exp_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- ffelexHandler nexthandler;
-
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- NULL, NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffeexpr_tokens_[3] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
-}
-
-/* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- After a number, period, and number, check next token for possible
- exponent designation (D, E, or Q as first/only character) and continue
- real-number handling accordingly. Else form basic real constant, push
- onto expression stack, and enter binary state using current token (which,
- if it is a name not beginning with D, E, or Q, will certainly result
- in an error, but that's not for this routine to deal with). */
-
-static ffelexHandler
-ffeexpr_token_number_real_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (((ffelex_token_type (t) != FFELEX_typeNAME)
- && (ffelex_token_type (t) != FFELEX_typeNAMES))
- || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q')))
- && ffeexpr_isdigits_ (++p)))
- {
-#if 0
- /* This code has been removed because it seems inconsistent to
- produce a diagnostic in this case, but not all of the other
- ones that look for an exponent and cannot recognize one. */
- if (((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
- {
- char bad[2];
-
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- bad[0] = *(p - 1);
- bad[1] = '\0';
- ffebad_string (bad);
- ffebad_finish ();
- }
-#endif
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- ffeexpr_tokens_[2], NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- /* Just exponent character by itself? In which case, PLUS or MINUS must
- surely be next, followed by a NUMBER token. */
-
- if (*p == '\0')
- {
- ffeexpr_tokens_[3] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_number_real_exp_;
- }
-
- ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- ffeexpr_tokens_[2], t, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Make sure token is a NUMBER, make a real constant out of all we have and
- push it onto the expression stack. Else issue diagnostic and pretend
- exponent field was a zero. */
-
-static ffelexHandler
-ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
- ffelex_token_where_column (ffeexpr_tokens_[2]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- NULL, NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[3]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
- ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
- ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[3]);
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Ensures this token is PLUS or MINUS, preserves it, goes to final state
- for real number (exponent digits). Else issues diagnostic, assumes a
- zero exponent field for number, passes token on to binary state as if
- previous token had been "E0" instead of "E", for example. */
-
-static ffelexHandler
-ffeexpr_token_number_real_exp_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
- ffelex_token_where_column (ffeexpr_tokens_[3]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- ffeexpr_tokens_[2], NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[3]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- ffeexpr_tokens_[4] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
-}
-
-/* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
- PLUS/MINUS
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Make sure token is a NUMBER, make a real constant out of all we have and
- push it onto the expression stack. Else issue diagnostic and pretend
- exponent field was a zero. */
-
-static ffelexHandler
-ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
- ffelex_token_where_column (ffeexpr_tokens_[3]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- ffeexpr_tokens_[2], NULL, NULL, NULL);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[3]);
- ffelex_token_kill (ffeexpr_tokens_[4]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-
- ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
- ffeexpr_tokens_[0], ffeexpr_tokens_[1],
- ffeexpr_tokens_[2], ffeexpr_tokens_[3],
- ffeexpr_tokens_[4], t);
-
- ffelex_token_kill (ffeexpr_tokens_[0]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- ffelex_token_kill (ffeexpr_tokens_[3]);
- ffelex_token_kill (ffeexpr_tokens_[4]);
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_binary_ -- Handle binary operator possibility
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- The possibility of a binary operator is handled here, meaning the previous
- token was an operand. */
-
-static ffelexHandler
-ffeexpr_token_binary_ (ffelexToken t)
-{
- ffeexprExpr_ e;
-
- if (!ffeexpr_stack_->is_rhs)
- return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typePLUS:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorADD_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
- e->u.operator.as = FFEEXPR_operatorassociativityADD_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeMINUS:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
- e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeASTERISK:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- return (ffelexHandler) ffeexpr_finished_ (t);
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
- e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeSLASH:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- return (ffelexHandler) ffeexpr_finished_ (t);
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorDIVIDE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
- e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typePOWER:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorPOWER_;
- e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
- e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeCONCAT:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
- e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeOPEN_ANGLE:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFORMAT:
- ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- break;
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorLT_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
- e->u.operator.as = FFEEXPR_operatorassociativityLT_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeCLOSE_ANGLE:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFORMAT:
- return ffeexpr_finished_ (t);
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorGT_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
- e->u.operator.as = FFEEXPR_operatorassociativityGT_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeREL_EQ:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFORMAT:
- ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- break;
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorEQ_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
- e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeREL_NE:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFORMAT:
- ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- break;
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorNE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
- e->u.operator.as = FFEEXPR_operatorassociativityNE_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeREL_LE:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFORMAT:
- ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- break;
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorLE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
- e->u.operator.as = FFEEXPR_operatorassociativityLE_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typeREL_GE:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFORMAT:
- ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- break;
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorGE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
- e->u.operator.as = FFEEXPR_operatorassociativityGE_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_;
-
- case FFELEX_typePERIOD:
- ffeexpr_tokens_[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_binary_period_;
-
-#if 0
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typeCLOSE_PAREN:
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
-#endif
- default:
- return (ffelexHandler) ffeexpr_finished_ (t);
- }
-}
-
-/* ffeexpr_token_binary_period_ -- Binary PERIOD
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle a period detected at binary (expecting binary op or end) state.
- Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
- valid. */
-
-static ffelexHandler
-ffeexpr_token_binary_period_ (ffelexToken t)
-{
- ffeexprExpr_ operand;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffestr_other (t);
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- case FFESTR_otherNOT:
- if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
- {
- operand = ffeexpr_stack_->exprstack;
- assert (operand != NULL);
- assert (operand->type == FFEEXPR_exprtypeOPERAND_);
- ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
- ffebad_here (1, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_binary_sw_per_;
-
- default:
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_binary_end_per_;
- }
- break; /* Nothing really reaches here. */
-
- default:
- if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-}
-
-/* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Expecting a period to close a dot-dot at binary (binary op
- or operator) state. If period isn't found, issue a diagnostic but
- pretend we saw one. ffeexpr_current_dotdot_ must already contained the
- dotdot representation of the name in between the two PERIOD tokens. */
-
-static ffelexHandler
-ffeexpr_token_binary_end_per_ (ffelexToken t)
-{
- ffeexprExpr_ e;
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffeexpr_tokens_[0];
-
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherAND:
- e->u.operator.op = FFEEXPR_operatorAND_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
- e->u.operator.as = FFEEXPR_operatorassociativityAND_;
- break;
-
- case FFESTR_otherOR:
- e->u.operator.op = FFEEXPR_operatorOR_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
- e->u.operator.as = FFEEXPR_operatorassociativityOR_;
- break;
-
- case FFESTR_otherXOR:
- e->u.operator.op = FFEEXPR_operatorXOR_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
- e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
- break;
-
- case FFESTR_otherEQV:
- e->u.operator.op = FFEEXPR_operatorEQV_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
- e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
- break;
-
- case FFESTR_otherNEQV:
- e->u.operator.op = FFEEXPR_operatorNEQV_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
- e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
- break;
-
- case FFESTR_otherLT:
- e->u.operator.op = FFEEXPR_operatorLT_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
- e->u.operator.as = FFEEXPR_operatorassociativityLT_;
- break;
-
- case FFESTR_otherLE:
- e->u.operator.op = FFEEXPR_operatorLE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
- e->u.operator.as = FFEEXPR_operatorassociativityLE_;
- break;
-
- case FFESTR_otherEQ:
- e->u.operator.op = FFEEXPR_operatorEQ_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
- e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
- break;
-
- case FFESTR_otherNE:
- e->u.operator.op = FFEEXPR_operatorNE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
- e->u.operator.as = FFEEXPR_operatorassociativityNE_;
- break;
-
- case FFESTR_otherGT:
- e->u.operator.op = FFEEXPR_operatorGT_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
- e->u.operator.as = FFEEXPR_operatorassociativityGT_;
- break;
-
- case FFESTR_otherGE:
- e->u.operator.op = FFEEXPR_operatorGE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
- e->u.operator.as = FFEEXPR_operatorassociativityGE_;
- break;
-
- default:
- if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
- ffebad_finish ();
- }
- e->u.operator.op = FFEEXPR_operatorEQ_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
- e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
- break;
- }
-
- ffeexpr_exprstack_push_binary_ (e);
-
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- {
- if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
- }
-
- ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
- return (ffelexHandler) ffeexpr_token_rhs_;
-}
-
-/* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- A diagnostic has already been issued; just swallow a period if there is
- one, then continue with ffeexpr_token_binary_. */
-
-static ffelexHandler
-ffeexpr_token_binary_sw_per_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_token_binary_ (t);
-
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_quote_ -- Rhs QUOTE
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Expecting a NUMBER that we'll treat as an octal integer. */
-
-static ffelexHandler
-ffeexpr_token_quote_ (ffelexToken t)
-{
- ffeexprExpr_ e;
- ffebld anyexpr;
-
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- {
- if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
- }
-
- /* This is kind of a kludge to prevent any whining about magical numbers
- that start out as these octal integers, so "20000000000 (on a 32-bit
- 2's-complement machine) by itself won't produce an error. */
-
- anyexpr = ffebld_new_any ();
- ffebld_set_info (anyexpr, ffeinfo_new_any ());
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- e->u.operand = ffebld_new_conter_with_orig
- (ffebld_constant_new_integeroctal (t), anyexpr);
- ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
- ffeexpr_exprstack_push_operand_ (e);
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle an open-apostrophe, which begins either a character ('char-const'),
- typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
- 'hex-const'X) constant. */
-
-static ffelexHandler
-ffeexpr_token_apostrophe_ (ffelexToken t)
-{
- assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
- if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
- {
- ffebad_start (FFEBAD_NULL_CHAR_CONST);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_apos_char_;
-}
-
-/* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Close-apostrophe is implicit; if this token is NAME, it is a possible
- typeless-constant radix specifier. */
-
-static ffelexHandler
-ffeexpr_token_apos_char_ (ffelexToken t)
-{
- ffeexprExpr_ e;
- ffeinfo ni;
- char c;
- ffetargetCharacterSize size;
-
- if ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- {
- if ((ffelex_token_length (t) == 1)
- && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
- 'b')
- || ffesrc_char_match_init (c, 'O', 'o')
- || ffesrc_char_match_init (c, 'X', 'x')
- || ffesrc_char_match_init (c, 'Z', 'z')))
- {
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- switch (c)
- {
- case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
- e->u.operand = ffebld_new_conter
- (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
- size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
- break;
-
- case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
- e->u.operand = ffebld_new_conter
- (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
- size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
- break;
-
- case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
- e->u.operand = ffebld_new_conter
- (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
- size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
- break;
-
- case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
- e->u.operand = ffebld_new_conter
- (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
- size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
- break;
-
- default:
- no_match: /* :::::::::::::::::::: */
- assert ("not BOXZ!" == NULL);
- size = 0;
- break;
- }
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
- ffeexpr_exprstack_push_operand_ (e);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) ffeexpr_token_binary_;
- }
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
- (ffeexpr_tokens_[1]));
- ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- ffelex_token_length (ffeexpr_tokens_[1]));
- ffebld_set_info (e->u.operand, ni);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffeexpr_exprstack_push_operand_ (e);
- if ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- {
- if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
- {
- ffebad_string (ffelex_token_text (t));
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_finish ();
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeBINARY_;
- e->token = ffelex_token_use (t);
- e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
- e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
- e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
- ffeexpr_exprstack_push_binary_ (e);
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
- }
- ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
- return (ffelexHandler) ffeexpr_token_substrp_ (t);
-}
-
-/* ffeexpr_token_name_lhs_ -- Lhs NAME
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle a name followed by open-paren, period (RECORD.MEMBER), percent
- (RECORD%MEMBER), or nothing at all. */
-
-static ffelexHandler
-ffeexpr_token_name_lhs_ (ffelexToken t)
-{
- ffeexprExpr_ e;
- ffeexprParenType_ paren_type;
- ffesymbol s;
- ffebld expr;
- ffeinfo info;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextASSIGN:
- case FFEEXPR_contextAGOTO:
- case FFEEXPR_contextFILEUNIT_DF:
- goto just_name; /* :::::::::::::::::::: */
-
- default:
- break;
- }
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffelex_token_use (ffeexpr_tokens_[0]);
- s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
- &paren_type);
-
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereLOCAL:
- if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
- ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
- break;
-
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereGLOBAL:
- if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
- ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
- break;
-
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereRESULT:
- break;
-
- case FFEINFO_whereNONE:
- case FFEINFO_whereANY:
- break;
-
- default:
- ffesymbol_error (s, ffeexpr_tokens_[0]);
- break;
- }
-
- if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
- {
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- }
- else
- {
- e->u.operand = ffebld_new_symter (s,
- ffesymbol_generic (s),
- ffesymbol_specific (s),
- ffesymbol_implementation (s));
- ffebld_set_info (e->u.operand, ffesymbol_info (s));
- }
- ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
- ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
- switch (paren_type)
- {
- case FFEEXPR_parentypeSUBROUTINE_:
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextACTUALARG_,
- ffeexpr_token_arguments_);
-
- case FFEEXPR_parentypeARRAY_:
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- ffeexpr_stack_->bound_list = ffesymbol_dims (s);
- ffeexpr_stack_->rank = 0;
- ffeexpr_stack_->constant = TRUE;
- ffeexpr_stack_->immediate = TRUE;
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATAIMPDOITEM_:
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextDATAIMPDOINDEX_,
- ffeexpr_token_elements_);
-
- case FFEEXPR_contextEQUIVALENCE:
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextEQVINDEX_,
- ffeexpr_token_elements_);
-
- default:
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextINDEX_,
- ffeexpr_token_elements_);
- }
-
- case FFEEXPR_parentypeSUBSTRING_:
- e->u.operand = ffeexpr_collapse_symter (e->u.operand,
- ffeexpr_tokens_[0]);
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextINDEX_,
- ffeexpr_token_substring_);
-
- case FFEEXPR_parentypeEQUIVALENCE_:
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- ffeexpr_stack_->bound_list = ffesymbol_dims (s);
- ffeexpr_stack_->rank = 0;
- ffeexpr_stack_->constant = TRUE;
- ffeexpr_stack_->immediate = TRUE;
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextEQVINDEX_,
- ffeexpr_token_equivalence_);
-
- case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
- case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
- ffesymbol_error (s, ffeexpr_tokens_[0]);
- /* Fall through. */
- case FFEEXPR_parentypeANY_:
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextACTUALARG_,
- ffeexpr_token_anything_);
-
- default:
- assert ("bad paren type" == NULL);
- break;
- }
-
- case FFELEX_typeEQUALS: /* As in "VAR=". */
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextIMPDOITEM_: /* within
- "(,VAR=start,end[,incr])". */
- case FFEEXPR_contextIMPDOITEMDF_:
- ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
- break;
-
- default:
- break;
- }
- break;
-
-#if 0
- case FFELEX_typePERIOD:
- case FFELEX_typePERCENT:
- assert ("FOO%, FOO. not yet supported!~~" == NULL);
- break;
-#endif
-
- default:
- break;
- }
-
-just_name: /* :::::::::::::::::::: */
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
- (ffeexpr_stack_->context
- == FFEEXPR_contextSUBROUTINEREF));
-
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereCONSTANT:
- if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
- || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
- ffesymbol_error (s, ffeexpr_tokens_[0]);
- break;
-
- case FFEINFO_whereIMMEDIATE:
- if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
- && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
- ffesymbol_error (s, ffeexpr_tokens_[0]);
- break;
-
- case FFEINFO_whereLOCAL:
- if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
- ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
- break;
-
- case FFEINFO_whereINTRINSIC:
- if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
- ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
- break;
-
- default:
- break;
- }
-
- if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
- {
- expr = ffebld_new_any ();
- info = ffeinfo_new_any ();
- ffebld_set_info (expr, info);
- }
- else
- {
- expr = ffebld_new_symter (s,
- ffesymbol_generic (s),
- ffesymbol_specific (s),
- ffesymbol_implementation (s));
- info = ffesymbol_info (s);
- ffebld_set_info (expr, info);
- if (ffesymbol_is_doiter (s))
- {
- ffebad_start (FFEBAD_DOITER);
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffest_ffebad_here_doiter (1, s);
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- }
- expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
- }
-
- if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
- {
- if (ffebld_op (expr) == FFEBLD_opANY)
- {
- expr = ffebld_new_any ();
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
- else
- {
- expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
- if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
- ffeintrin_fulfill_generic (&expr, &info, e->token);
- else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
- ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
- else
- ffeexpr_fulfill_call_ (&expr, e->token);
-
- if (ffebld_op (expr) != FFEBLD_opANY)
- ffebld_set_info (expr,
- ffeinfo_new (ffeinfo_basictype (info),
- ffeinfo_kindtype (info),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereFLEETING,
- ffeinfo_size (info)));
- else
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
- }
-
- e->u.operand = expr;
- ffeexpr_exprstack_push_operand_ (e);
- return (ffelexHandler) ffeexpr_finished_ (t);
-}
-
-/* ffeexpr_token_name_arg_ -- Rhs NAME
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle first token in an actual-arg (or possible actual-arg) context
- being a NAME, and use second token to refine the context. */
-
-static ffelexHandler
-ffeexpr_token_name_arg_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- case FFELEX_typeCOMMA:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
- break;
-
- default:
- break;
- }
- break;
-
- default:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context
- = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context in _name_arg_" == NULL);
- break;
- }
- break;
- }
-
- return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
-}
-
-/* ffeexpr_token_name_rhs_ -- Rhs NAME
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle a name followed by open-paren, apostrophe (O'octal-const',
- Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
-
- 26-Nov-91 JCB 1.2
- When followed by apostrophe or quote, set lex hexnum flag on so
- [0-9] as first char of next token seen as starting a potentially
- hex number (NAME).
- 04-Oct-91 JCB 1.1
- In case of intrinsic, decorate its SYMTER with the type info for
- the specific intrinsic. */
-
-static ffelexHandler
-ffeexpr_token_name_rhs_ (ffelexToken t)
-{
- ffeexprExpr_ e;
- ffeexprParenType_ paren_type;
- ffesymbol s;
- bool sfdef;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeQUOTE:
- case FFELEX_typeAPOSTROPHE:
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- ffelex_set_hexnum (TRUE);
- return (ffelexHandler) ffeexpr_token_name_apos_;
-
- case FFELEX_typeOPEN_PAREN:
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffelex_token_use (ffeexpr_tokens_[0]);
- s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
- &paren_type);
- if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
- e->u.operand = ffebld_new_any ();
- else
- e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
- ffesymbol_specific (s),
- ffesymbol_implementation (s));
- ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
- ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- sfdef = TRUE;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- assert ("weird context!" == NULL);
- sfdef = FALSE;
- break;
-
- default:
- sfdef = FALSE;
- break;
- }
- switch (paren_type)
- {
- case FFEEXPR_parentypeFUNCTION_:
- ffebld_set_info (e->u.operand, ffesymbol_info (s));
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
- { /* A statement function. */
- ffeexpr_stack_->num_args
- = ffebld_list_length
- (ffeexpr_stack_->next_dummy
- = ffesymbol_dummyargs (s));
- ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
- }
- else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
- && !ffe_is_pedantic_not_90 ()
- && ((ffesymbol_implementation (s)
- == FFEINTRIN_impICHAR)
- || (ffesymbol_implementation (s)
- == FFEINTRIN_impIACHAR)
- || (ffesymbol_implementation (s)
- == FFEINTRIN_impLEN)))
- { /* Allow arbitrary concatenations. */
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- sfdef
- ? FFEEXPR_contextSFUNCDEF
- : FFEEXPR_contextLET,
- ffeexpr_token_arguments_);
- }
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- sfdef
- ? FFEEXPR_contextSFUNCDEFACTUALARG_
- : FFEEXPR_contextACTUALARG_,
- ffeexpr_token_arguments_);
-
- case FFEEXPR_parentypeARRAY_:
- ffebld_set_info (e->u.operand,
- ffesymbol_info (ffebld_symter (e->u.operand)));
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- ffeexpr_stack_->bound_list = ffesymbol_dims (s);
- ffeexpr_stack_->rank = 0;
- ffeexpr_stack_->constant = TRUE;
- ffeexpr_stack_->immediate = TRUE;
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- sfdef
- ? FFEEXPR_contextSFUNCDEFINDEX_
- : FFEEXPR_contextINDEX_,
- ffeexpr_token_elements_);
-
- case FFEEXPR_parentypeSUBSTRING_:
- ffebld_set_info (e->u.operand,
- ffesymbol_info (ffebld_symter (e->u.operand)));
- e->u.operand = ffeexpr_collapse_symter (e->u.operand,
- ffeexpr_tokens_[0]);
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- sfdef
- ? FFEEXPR_contextSFUNCDEFINDEX_
- : FFEEXPR_contextINDEX_,
- ffeexpr_token_substring_);
-
- case FFEEXPR_parentypeFUNSUBSTR_:
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- sfdef
- ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
- : FFEEXPR_contextINDEXORACTUALARG_,
- ffeexpr_token_funsubstr_);
-
- case FFEEXPR_parentypeANY_:
- ffebld_set_info (e->u.operand, ffesymbol_info (s));
- return
- (ffelexHandler)
- ffeexpr_rhs (ffeexpr_stack_->pool,
- sfdef
- ? FFEEXPR_contextSFUNCDEFACTUALARG_
- : FFEEXPR_contextACTUALARG_,
- ffeexpr_token_anything_);
-
- default:
- assert ("bad paren type" == NULL);
- break;
- }
-
- case FFELEX_typeEQUALS: /* As in "VAR=". */
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
- case FFEEXPR_contextIMPDOITEMDF_:
- ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
- ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- default:
- break;
- }
- break;
-
-#if 0
- case FFELEX_typePERIOD:
- case FFELEX_typePERCENT:
- ~~Support these two someday, though not required
- assert ("FOO%, FOO. not yet supported!~~" == NULL);
- break;
-#endif
-
- default:
- break;
- }
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextINDEXORACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- assert ("strange context" == NULL);
- break;
-
- default:
- break;
- }
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
- if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
- {
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- }
- else
- {
- e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
- ffesymbol_specific (s),
- ffesymbol_implementation (s));
- if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
- ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
- else
- { /* Decorate the SYMTER with the actual type
- of the intrinsic. */
- ffebld_set_info (e->u.operand, ffeinfo_new
- (ffeintrin_basictype (ffesymbol_specific (s)),
- ffeintrin_kindtype (ffesymbol_specific (s)),
- 0,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- FFETARGET_charactersizeNONE));
- }
- if (ffesymbol_is_doiter (s))
- ffebld_symter_set_is_doiter (e->u.operand, TRUE);
- e->u.operand = ffeexpr_collapse_symter (e->u.operand,
- ffeexpr_tokens_[0]);
- }
- ffeexpr_exprstack_push_operand_ (e);
- return (ffelexHandler) ffeexpr_token_binary_ (t);
-}
-
-/* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Expecting a NAME token, analyze the previous NAME token to see what kind,
- if any, typeless constant we've got.
-
- 01-Sep-90 JCB 1.1
- Expect a NAME instead of CHARACTER in this situation. */
-
-static ffelexHandler
-ffeexpr_token_name_apos_ (ffelexToken t)
-{
- ffeexprExpr_ e;
-
- ffelex_set_hexnum (FALSE);
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffeexpr_tokens_[2] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_name_apos_name_;
-
- default:
- break;
- }
-
- if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
- {
- ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffelex_token_kill (ffeexpr_tokens_[1]);
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- e->token = ffeexpr_tokens_[0];
- ffeexpr_exprstack_push_operand_ (e);
-
- return (ffelexHandler) ffeexpr_token_binary_ (t);
-}
-
-/* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Expecting an APOSTROPHE token, analyze the previous NAME token to see
- what kind, if any, typeless constant we've got. */
-
-static ffelexHandler
-ffeexpr_token_name_apos_name_ (ffelexToken t)
-{
- ffeexprExpr_ e;
- char c;
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
-
- if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
- && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
- && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
- 'B', 'b')
- || ffesrc_char_match_init (c, 'O', 'o')
- || ffesrc_char_match_init (c, 'X', 'x')
- || ffesrc_char_match_init (c, 'Z', 'z')))
- {
- ffetargetCharacterSize size;
-
- if (!ffe_is_typeless_boz ()) {
-
- switch (c)
- {
- case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
- (ffeexpr_tokens_[2]));
- break;
-
- case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
- (ffeexpr_tokens_[2]));
- break;
-
- case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
- (ffeexpr_tokens_[2]));
- break;
-
- case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
- (ffeexpr_tokens_[2]));
- break;
-
- default:
- no_imatch: /* :::::::::::::::::::: */
- assert ("not BOXZ!" == NULL);
- abort ();
- }
-
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- ffeexpr_exprstack_push_operand_ (e);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) ffeexpr_token_binary_;
- }
-
- switch (c)
- {
- case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
- (ffeexpr_tokens_[2]));
- size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
- break;
-
- case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
- (ffeexpr_tokens_[2]));
- size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
- break;
-
- case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
- (ffeexpr_tokens_[2]));
- size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
- break;
-
- case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
- (ffeexpr_tokens_[2]));
- size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
- break;
-
- default:
- no_match: /* :::::::::::::::::::: */
- assert ("not BOXZ!" == NULL);
- e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
- (ffeexpr_tokens_[2]));
- size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
- break;
- }
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
- ffeexpr_exprstack_push_operand_ (e);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
- return (ffelexHandler) ffeexpr_token_binary_;
- }
-
- if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
- {
- ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[2]);
-
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- e->token = ffeexpr_tokens_[0];
- ffeexpr_exprstack_push_operand_ (e);
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeAPOSTROPHE:
- case FFELEX_typeQUOTE:
- return (ffelexHandler) ffeexpr_token_binary_;
-
- default:
- return (ffelexHandler) ffeexpr_token_binary_ (t);
- }
-}
-
-/* ffeexpr_token_percent_ -- Rhs PERCENT
-
- Handle a percent sign possibly followed by "LOC". If followed instead
- by "VAL", "REF", or "DESCR", issue an error message and substitute
- "LOC". If followed by something else, treat the percent sign as a
- spurious incorrect token and reprocess the token via _rhs_. */
-
-static ffelexHandler
-ffeexpr_token_percent_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_stack_->percent = ffeexpr_percent_ (t);
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_percent_name_;
-
- default:
- if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
- }
-}
-
-/* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
-
- Make sure the token is OPEN_PAREN and prepare for the one-item list of
- LHS expressions. Else display an error message. */
-
-static ffelexHandler
-ffeexpr_token_percent_name_ (ffelexToken t)
-{
- ffelexHandler nexthandler;
-
- if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
- {
- if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_tokens_[0]);
- nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
- ffelex_token_kill (ffeexpr_tokens_[1]);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- switch (ffeexpr_stack_->percent)
- {
- default:
- if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
- ffebad_finish ();
- }
- ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
- /* Fall through. */
- case FFEEXPR_percentLOC_:
- ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
- ffelex_token_kill (ffeexpr_tokens_[1]);
- ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextLOC_,
- ffeexpr_cb_end_loc_);
- }
-}
-
-/* ffeexpr_make_float_const_ -- Make a floating-point constant
-
- See prototype.
-
- Pass 'E', 'D', or 'Q' for exponent letter. */
-
-static void
-ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
- ffelexToken decimal, ffelexToken fraction,
- ffelexToken exponent, ffelexToken exponent_sign,
- ffelexToken exponent_digits)
-{
- ffeexprExpr_ e;
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- if (integer != NULL)
- e->token = ffelex_token_use (integer);
- else
- {
- assert (decimal != NULL);
- e->token = ffelex_token_use (decimal);
- }
-
- switch (exp_letter)
- {
-#if !FFETARGET_okREALQUAD
- case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
- if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
- {
- ffebad_here (0, ffelex_token_where_line (e->token),
- ffelex_token_where_column (e->token));
- ffebad_finish ();
- }
- goto match_d; /* The FFESRC_CASE_* macros don't
- allow fall-through! */
-#endif
-
- case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
- (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
- break;
-
- case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
- (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
- ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
- break;
-
-#if FFETARGET_okREALQUAD
- case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
- e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
- (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
- 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
- break;
-#endif
-
- case 'I': /* Make an integer. */
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
- (ffeexpr_tokens_[0]));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-
- default:
- no_match: /* :::::::::::::::::::: */
- assert ("Lost the exponent letter!" == NULL);
- }
-
- ffeexpr_exprstack_push_operand_ (e);
-}
-
-/* Just like ffesymbol_declare_local, except performs any implicit info
- assignment necessary. */
-
-static ffesymbol
-ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
-{
- ffesymbol s;
- ffeinfoKind k;
- bool bad;
-
- s = ffesymbol_declare_local (t, maybe_intrin);
-
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- /* Special-case these since they can involve a different concept
- of "state" (in the stmtfunc name space). */
- {
- case FFEEXPR_contextDATAIMPDOINDEX_:
- case FFEEXPR_contextDATAIMPDOCTRL_:
- if (ffeexpr_context_outer_ (ffeexpr_stack_)
- == FFEEXPR_contextDATAIMPDOINDEX_)
- s = ffeexpr_sym_impdoitem_ (s, t);
- else
- if (ffeexpr_stack_->is_rhs)
- s = ffeexpr_sym_impdoitem_ (s, t);
- else
- s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
- bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
- || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
- && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
- if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
- ffesymbol_error (s, t);
- return s;
-
- default:
- break;
- }
-
- switch ((ffesymbol_sfdummyparent (s) == NULL)
- ? ffesymbol_state (s)
- : FFESYMBOL_stateUNDERSTOOD)
- {
- case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
- context. */
- if (!ffest_seen_first_exec ())
- goto seen; /* :::::::::::::::::::: */
- /* Fall through. */
- case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextSUBROUTINEREF:
- s = ffeexpr_sym_lhs_call_ (s, t);
- break;
-
- case FFEEXPR_contextFILEEXTFUNC:
- s = ffeexpr_sym_lhs_extfunc_ (s, t);
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- /* Fall through. */
- case FFEEXPR_contextACTUALARG_:
- s = ffeexpr_sym_rhs_actualarg_ (s, t);
- break;
-
- case FFEEXPR_contextDATA:
- if (ffeexpr_stack_->is_rhs)
- s = ffeexpr_sym_rhs_let_ (s, t);
- else
- s = ffeexpr_sym_lhs_data_ (s, t);
- break;
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- s = ffeexpr_sym_lhs_data_ (s, t);
- break;
-
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- /* Fall through. */
- case FFEEXPR_contextLET:
- case FFEEXPR_contextPAREN_:
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextASSIGN:
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextDO:
- case FFEEXPR_contextDOWHILE:
- case FFEEXPR_contextAGOTO:
- case FFEEXPR_contextCGOTO:
- case FFEEXPR_contextIF:
- case FFEEXPR_contextARITHIF:
- case FFEEXPR_contextFORMAT:
- case FFEEXPR_contextSTOP:
- case FFEEXPR_contextRETURN:
- case FFEEXPR_contextSELECTCASE:
- case FFEEXPR_contextCASE:
- case FFEEXPR_contextFILEASSOC:
- case FFEEXPR_contextFILEINT:
- case FFEEXPR_contextFILEDFINT:
- case FFEEXPR_contextFILELOG:
- case FFEEXPR_contextFILENUM:
- case FFEEXPR_contextFILENUMAMBIG:
- case FFEEXPR_contextFILECHAR:
- case FFEEXPR_contextFILENUMCHAR:
- case FFEEXPR_contextFILEDFCHAR:
- case FFEEXPR_contextFILEKEY:
- case FFEEXPR_contextFILEUNIT:
- case FFEEXPR_contextFILEUNIT_DF:
- case FFEEXPR_contextFILEUNITAMBIG:
- case FFEEXPR_contextFILEFORMAT:
- case FFEEXPR_contextFILENAMELIST:
- case FFEEXPR_contextFILEVXTCODE:
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- case FFEEXPR_contextIMPDOCTRL_:
- case FFEEXPR_contextLOC_:
- if (ffeexpr_stack_->is_rhs)
- s = ffeexpr_sym_rhs_let_ (s, t);
- else
- s = ffeexpr_sym_lhs_let_ (s, t);
- break;
-
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextEQUIVALENCE:
- case FFEEXPR_contextINCLUDE:
- case FFEEXPR_contextPARAMETER:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextDIMLISTCOMMON:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextINITVAL:
- case FFEEXPR_contextEQVINDEX_:
- break; /* Will turn into errors below. */
-
- default:
- ffesymbol_error (s, t);
- break;
- }
- /* Fall through. */
- case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
- understood: /* :::::::::::::::::::: */
- k = ffesymbol_kind (s);
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextSUBROUTINEREF:
- bad = ((k != FFEINFO_kindSUBROUTINE)
- && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
- || (k != FFEINFO_kindNONE)));
- break;
-
- case FFEEXPR_contextFILEEXTFUNC:
- bad = (k != FFEINFO_kindFUNCTION)
- || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextACTUALARG_:
- switch (k)
- {
- case FFEINFO_kindENTITY:
- bad = FALSE;
- break;
-
- case FFEINFO_kindFUNCTION:
- case FFEINFO_kindSUBROUTINE:
- bad
- = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
- && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
- && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
- || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
- break;
-
- case FFEINFO_kindNONE:
- if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
- {
- bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
- break;
- }
-
- /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
- and in the former case, attrsTYPE is set, so we
- see this as an error as we should, since CHAR*(*)
- cannot be actually referenced in a main/block data
- program unit. */
-
- if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE))
- == FFESYMBOL_attrsEXTERNAL)
- bad = FALSE;
- else
- bad = TRUE;
- break;
-
- default:
- bad = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextDATA:
- if (ffeexpr_stack_->is_rhs)
- bad = (k != FFEINFO_kindENTITY)
- || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
- else
- bad = (k != FFEINFO_kindENTITY)
- || ((ffesymbol_where (s) != FFEINFO_whereNONE)
- && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
- && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
- break;
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- bad = TRUE; /* Unadorned item never valid. */
- break;
-
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextLET:
- case FFEEXPR_contextPAREN_:
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextASSIGN:
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextDO:
- case FFEEXPR_contextDOWHILE:
- case FFEEXPR_contextAGOTO:
- case FFEEXPR_contextCGOTO:
- case FFEEXPR_contextIF:
- case FFEEXPR_contextARITHIF:
- case FFEEXPR_contextFORMAT:
- case FFEEXPR_contextSTOP:
- case FFEEXPR_contextRETURN:
- case FFEEXPR_contextSELECTCASE:
- case FFEEXPR_contextCASE:
- case FFEEXPR_contextFILEASSOC:
- case FFEEXPR_contextFILEINT:
- case FFEEXPR_contextFILEDFINT:
- case FFEEXPR_contextFILELOG:
- case FFEEXPR_contextFILENUM:
- case FFEEXPR_contextFILENUMAMBIG:
- case FFEEXPR_contextFILECHAR:
- case FFEEXPR_contextFILENUMCHAR:
- case FFEEXPR_contextFILEDFCHAR:
- case FFEEXPR_contextFILEKEY:
- case FFEEXPR_contextFILEUNIT:
- case FFEEXPR_contextFILEUNIT_DF:
- case FFEEXPR_contextFILEUNITAMBIG:
- case FFEEXPR_contextFILEFORMAT:
- case FFEEXPR_contextFILENAMELIST:
- case FFEEXPR_contextFILEVXTCODE:
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- case FFEEXPR_contextIMPDOCTRL_:
- case FFEEXPR_contextLOC_:
- bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
- X(A);EXTERNAL A;CALL
- Y(A);B=A", for example. */
- break;
-
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextEQUIVALENCE:
- case FFEEXPR_contextPARAMETER:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextDIMLISTCOMMON:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextINITVAL:
- case FFEEXPR_contextEQVINDEX_:
- bad = (k != FFEINFO_kindENTITY)
- || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
- break;
-
- case FFEEXPR_contextINCLUDE:
- bad = TRUE;
- break;
-
- default:
- bad = TRUE;
- break;
- }
- if (bad && (k != FFEINFO_kindANY))
- ffesymbol_error (s, t);
- return s;
-
- case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
- seen: /* :::::::::::::::::::: */
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextPARAMETER:
- if (ffeexpr_stack_->is_rhs)
- ffesymbol_error (s, t);
- else
- s = ffeexpr_sym_lhs_parameter_ (s, t);
- break;
-
- case FFEEXPR_contextDATA:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- if (ffeexpr_stack_->is_rhs)
- ffesymbol_error (s, t);
- else
- s = ffeexpr_sym_lhs_data_ (s, t);
- goto understood; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- s = ffeexpr_sym_lhs_data_ (s, t);
- goto understood; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextEQUIVALENCE:
- s = ffeexpr_sym_lhs_equivalence_ (s, t);
- break;
-
- case FFEEXPR_contextDIMLIST:
- s = ffeexpr_sym_rhs_dimlist_ (s, t);
- break;
-
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextDIMLISTCOMMON:
- case FFEEXPR_contextINITVAL:
- case FFEEXPR_contextEQVINDEX_:
- ffesymbol_error (s, t);
- break;
-
- case FFEEXPR_contextINCLUDE:
- ffesymbol_error (s, t);
- break;
-
- case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- s = ffeexpr_sym_rhs_actualarg_ (s, t);
- goto understood; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- assert (ffeexpr_stack_->is_rhs);
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- s = ffeexpr_sym_rhs_let_ (s, t);
- goto understood; /* :::::::::::::::::::: */
-
- default:
- ffesymbol_error (s, t);
- break;
- }
- return s;
-
- default:
- assert ("bad symbol state" == NULL);
- return NULL;
- break;
- }
-}
-
-/* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
- Could be found via the "statement-function" name space (in which case
- it should become an iterator) or the local name space (in which case
- it should be either a named constant, or a variable that will have an
- sfunc name space sibling that should become an iterator). */
-
-static ffesymbol
-ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffesymbolState ss;
- ffesymbolState ns;
- ffeinfoKind kind;
- ffeinfoWhere where;
-
- ss = ffesymbol_state (sp);
-
- if (ffesymbol_sfdummyparent (sp) != NULL)
- { /* Have symbol in sfunc name space. */
- switch (ss)
- {
- case FFESYMBOL_stateNONE: /* Used as iterator already. */
- if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
- ffesymbol_error (sp, t); /* Can't use dead iterator. */
- else
- { /* Can use dead iterator because we're at at
- least an innermore (higher-numbered) level
- than the iterator's outermost
- (lowest-numbered) level. */
- ffesymbol_signal_change (sp);
- ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
- ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
- ffesymbol_signal_unreported (sp);
- }
- break;
-
- case FFESYMBOL_stateSEEN: /* Seen already in this or other
- implied-DO. Set symbol level
- number to outermost value, as that
- tells us we can see it as iterator
- at that level at the innermost. */
- if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
- {
- ffesymbol_signal_change (sp);
- ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
- ffesymbol_signal_unreported (sp);
- }
- break;
-
- case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
- assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
- ffesymbol_error (sp, t); /* (,,,I=I,10). */
- break;
-
- case FFESYMBOL_stateUNDERSTOOD:
- break; /* ANY. */
-
- default:
- assert ("Foo Bar!!" == NULL);
- break;
- }
-
- return sp;
- }
-
- /* Got symbol in local name space, so we haven't seen it in impdo yet.
- First, if it is brand-new and we're in executable statements, set the
- attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
- Second, if it is now a constant (PARAMETER), then just return it, it
- can't be an implied-do iterator. If it is understood, complain if it is
- not a valid variable, but make the inner name space iterator anyway and
- return that. If it is not understood, improve understanding of the
- symbol accordingly, complain accordingly, in either case make the inner
- name space iterator and return that. */
-
- sa = ffesymbol_attrs (sp);
-
- if (ffesymbol_state_is_specable (ss)
- && ffest_seen_first_exec ())
- {
- assert (sa == FFESYMBOL_attrsetNONE);
- ffesymbol_signal_change (sp);
- ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
- ffesymbol_resolve_intrin (sp);
- if (ffeimplic_establish_symbol (sp))
- ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
- else
- ffesymbol_error (sp, t);
-
- /* After the exec transition, the state will either be UNCERTAIN (could
- be a dummy or local var) or UNDERSTOOD (local var, because this is a
- PROGRAM/BLOCKDATA program unit). */
-
- sp = ffecom_sym_exec_transition (sp);
- sa = ffesymbol_attrs (sp);
- ss = ffesymbol_state (sp);
- }
-
- ns = ss;
- kind = ffesymbol_kind (sp);
- where = ffesymbol_where (sp);
-
- if (ss == FFESYMBOL_stateUNDERSTOOD)
- {
- if (kind != FFEINFO_kindENTITY)
- ffesymbol_error (sp, t);
- if (where == FFEINFO_whereCONSTANT)
- return sp;
- }
- else
- {
- /* Enhance understanding of local symbol. This used to imply exec
- transition, but that doesn't seem necessary, since the local symbol
- doesn't actually get put into an ffebld tree here -- we just learn
- more about it, just like when we see a local symbol's name in the
- dummy-arg list of a statement function. */
-
- if (ss != FFESYMBOL_stateUNCERTAIN)
- {
- /* Figure out what kind of object we've got based on previous
- declarations of or references to the object. */
-
- ns = FFESYMBOL_stateSEEN;
-
- if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsANY
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsRESULT
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsSFARG;
- else
- na = FFESYMBOL_attrsetNONE;
- }
- else
- { /* stateUNCERTAIN. */
- na = sa | FFESYMBOL_attrsSFARG;
- ns = FFESYMBOL_stateUNDERSTOOD;
-
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- if (sa & FFESYMBOL_attrsEXTERNAL)
- {
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- na = FFESYMBOL_attrsetNONE;
- }
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- kind = FFEINFO_kindENTITY;
- }
- else if (sa & FFESYMBOL_attrsARRAY)
- {
- assert (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsTYPE)));
-
- na = FFESYMBOL_attrsetNONE;
- }
- else if (sa & FFESYMBOL_attrsSFARG)
- {
- assert (!(sa & ~(FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- ns = FFESYMBOL_stateUNCERTAIN;
- }
- else if (sa & FFESYMBOL_attrsTYPE)
- {
- assert (!(sa & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG))); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsTYPE
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG)));
-
- kind = FFEINFO_kindENTITY;
-
- if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
- na = FFESYMBOL_attrsetNONE;
- else if (ffest_is_entry_valid ())
- ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
- else
- where = FFEINFO_whereLOCAL;
- }
- else
- na = FFESYMBOL_attrsetNONE; /* Error. */
- }
-
- /* Now see what we've got for a new object: NONE means a new error
- cropped up; ANY means an old error to be ignored; otherwise,
- everything's ok, update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (sp, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (sp); /* May need to back up to previous
- version. */
- if (!ffeimplic_establish_symbol (sp))
- ffesymbol_error (sp, t);
- else
- {
- ffesymbol_set_info (sp,
- ffeinfo_new (ffesymbol_basictype (sp),
- ffesymbol_kindtype (sp),
- ffesymbol_rank (sp),
- kind,
- where,
- ffesymbol_size (sp)));
- ffesymbol_set_attrs (sp, na);
- ffesymbol_set_state (sp, ns);
- ffesymbol_resolve_intrin (sp);
- if (!ffesymbol_state_is_specable (ns))
- sp = ffecom_sym_learned (sp);
- ffesymbol_signal_unreported (sp); /* For debugging purposes. */
- }
- }
- }
-
- /* Here we create the sfunc-name-space symbol representing what should
- become an iterator in this name space at this or an outermore (lower-
- numbered) expression level, else the implied-DO construct is in error. */
-
- s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
- also sets sfa_dummy_parent to
- parent symbol. */
- assert (sp == ffesymbol_sfdummyparent (s));
-
- ffesymbol_signal_change (s);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_maxentrynum (s, ffeexpr_level_);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereIMMEDIATE,
- FFETARGET_charactersizeNONE));
- ffesymbol_signal_unreported (s);
-
- if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
- && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
- ffesymbol_error (s, t);
-
- return s;
-}
-
-/* Have FOO in CALL FOO. Local name space, executable context only. */
-
-static ffesymbol
-ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
- ffeintrinGen gen;
- ffeintrinSpec spec;
- ffeintrinImp imp;
- bool error = FALSE;
-
- assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
-
- na = sa = ffesymbol_attrs (s);
-
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (sa & FFESYMBOL_attrsEXTERNAL)
- {
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- if (sa & FFESYMBOL_attrsTYPE)
- error = TRUE;
- else
- /* Not TYPE. */
- {
- kind = FFEINFO_kindSUBROUTINE;
-
- if (sa & FFESYMBOL_attrsDUMMY)
- ; /* Not TYPE. */
- else if (sa & FFESYMBOL_attrsACTUALARG)
- ; /* Not DUMMY or TYPE. */
- else /* Not ACTUALARG, DUMMY, or TYPE. */
- where = FFEINFO_whereGLOBAL;
- }
- }
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- if (sa & FFESYMBOL_attrsTYPE)
- error = TRUE;
- else
- kind = FFEINFO_kindSUBROUTINE;
- }
- else if (sa & FFESYMBOL_attrsARRAY)
- {
- assert (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsTYPE)));
-
- error = TRUE;
- }
- else if (sa & FFESYMBOL_attrsSFARG)
- {
- assert (!(sa & ~(FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- error = TRUE;
- }
- else if (sa & FFESYMBOL_attrsTYPE)
- {
- assert (!(sa & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG))); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsTYPE
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG)));
-
- error = TRUE;
- }
- else if (sa == FFESYMBOL_attrsetNONE)
- {
- assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
-
- if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
- &gen, &spec, &imp))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- ffesymbol_set_generic (s, gen);
- ffesymbol_set_specific (s, spec);
- ffesymbol_set_implementation (s, imp);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindSUBROUTINE,
- FFEINFO_whereINTRINSIC,
- FFETARGET_charactersizeNONE));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- ffesymbol_reference (s, t, FALSE);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
-
- return s;
- }
-
- kind = FFEINFO_kindSUBROUTINE;
- where = FFEINFO_whereGLOBAL;
- }
- else
- error = TRUE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (error)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind, /* SUBROUTINE. */
- where, /* GLOBAL or DUMMY. */
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- ffesymbol_reference (s, t, FALSE);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* Have FOO in DATA FOO/.../. Local name space and executable context
- only. (This will change in the future when DATA FOO may be followed
- by COMMON FOO or even INTEGER FOO(10), etc.) */
-
-static ffesymbol
-ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
- bool error = FALSE;
-
- assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
-
- na = sa = ffesymbol_attrs (s);
-
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (sa & FFESYMBOL_attrsEXTERNAL)
- {
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- error = TRUE;
- }
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- error = TRUE;
- }
- else if (sa & FFESYMBOL_attrsARRAY)
- {
- assert (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsTYPE)));
-
- if (sa & FFESYMBOL_attrsADJUSTABLE)
- error = TRUE;
- where = FFEINFO_whereLOCAL;
- }
- else if (sa & FFESYMBOL_attrsSFARG)
- {
- assert (!(sa & ~(FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- where = FFEINFO_whereLOCAL;
- }
- else if (sa & FFESYMBOL_attrsTYPE)
- {
- assert (!(sa & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG))); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsTYPE
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG)));
-
- if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
- error = TRUE;
- else
- {
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereLOCAL;
- }
- }
- else if (sa == FFESYMBOL_attrsetNONE)
- {
- assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereLOCAL;
- }
- else
- error = TRUE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (error)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- if (!ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return s;
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind, /* ENTITY. */
- where, /* LOCAL. */
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
- EQUIVALENCE (...,BAR(FOO),...). */
-
-static ffesymbol
-ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
-
- na = sa = ffesymbol_attrs (s);
- kind = FFEINFO_kindENTITY;
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsEQUIV;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Don't know why we're bothering to set kind and where in this code, but
- added the following to make it complete, in case it's really important.
- Generally this is left up to symbol exec transition. */
-
- if (where == FFEINFO_whereNONE)
- {
- if (na & (FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsCOMMON))
- where = FFEINFO_whereCOMMON;
- else if (na & FFESYMBOL_attrsSAVE)
- where = FFEINFO_whereLOCAL;
- }
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind, /* Always ENTITY. */
- where, /* NONE, COMMON, or LOCAL. */
- ffesymbol_size (s)));
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_resolve_intrin (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
-
- Note that I think this should be considered semantically similar to
- doing CALL XYZ(FOO), in that it should be considered like an
- ACTUALARG context. In particular, without EXTERNAL being specified,
- it should not be allowed. */
-
-static ffesymbol
-ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
- bool needs_type = FALSE;
- bool error = FALSE;
-
- assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
-
- na = sa = ffesymbol_attrs (s);
-
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (sa & FFESYMBOL_attrsEXTERNAL)
- {
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- if (sa & FFESYMBOL_attrsTYPE)
- where = FFEINFO_whereGLOBAL;
- else
- /* Not TYPE. */
- {
- kind = FFEINFO_kindFUNCTION;
- needs_type = TRUE;
-
- if (sa & FFESYMBOL_attrsDUMMY)
- ; /* Not TYPE. */
- else if (sa & FFESYMBOL_attrsACTUALARG)
- ; /* Not DUMMY or TYPE. */
- else /* Not ACTUALARG, DUMMY, or TYPE. */
- where = FFEINFO_whereGLOBAL;
- }
- }
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- kind = FFEINFO_kindFUNCTION;
- if (!(sa & FFESYMBOL_attrsTYPE))
- needs_type = TRUE;
- }
- else if (sa & FFESYMBOL_attrsARRAY)
- {
- assert (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsTYPE)));
-
- error = TRUE;
- }
- else if (sa & FFESYMBOL_attrsSFARG)
- {
- assert (!(sa & ~(FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- error = TRUE;
- }
- else if (sa & FFESYMBOL_attrsTYPE)
- {
- assert (!(sa & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG))); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsTYPE
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG)));
-
- if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
- error = TRUE;
- else
- {
- kind = FFEINFO_kindFUNCTION;
- where = FFEINFO_whereGLOBAL;
- }
- }
- else if (sa == FFESYMBOL_attrsetNONE)
- {
- assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
- kind = FFEINFO_kindFUNCTION;
- where = FFEINFO_whereGLOBAL;
- needs_type = TRUE;
- }
- else
- error = TRUE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (error)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- if (needs_type && !ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return s;
- }
- if (!ffesymbol_explicitwhere (s))
- {
- ffebad_start (FFEBAD_NEED_EXTERNAL);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- ffesymbol_set_explicitwhere (s, TRUE);
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind, /* FUNCTION. */
- where, /* GLOBAL or DUMMY. */
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- ffesymbol_reference (s, t, FALSE);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* Have FOO in DATA (stuff,FOO=1,10)/.../. */
-
-static ffesymbol
-ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolState ss;
-
- /* If the symbol isn't in the sfunc name space, pretend as though we saw a
- reference to it already within the imp-DO construct at this level, so as
- to get a symbol that is in the sfunc name space. But this is an
- erroneous construct, and should be caught elsewhere. */
-
- if (ffesymbol_sfdummyparent (s) == NULL)
- {
- s = ffeexpr_sym_impdoitem_ (s, t);
- if (ffesymbol_sfdummyparent (s) == NULL)
- { /* PARAMETER FOO...DATA (A(I),FOO=...). */
- ffesymbol_error (s, t);
- return s;
- }
- }
-
- ss = ffesymbol_state (s);
-
- switch (ss)
- {
- case FFESYMBOL_stateNONE: /* Used as iterator already. */
- if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
- ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
- this; F77 allows it but it is a stupid
- feature. */
- else
- { /* Can use dead iterator because we're at at
- least a innermore (higher-numbered) level
- than the iterator's outermost
- (lowest-numbered) level. This should be
- diagnosed later, because it means an item
- in this list didn't reference this
- iterator. */
-#if 1
- ffesymbol_error (s, t); /* For now, complain. */
-#else /* Someday will detect all cases where initializer doesn't reference
- all applicable iterators, in which case reenable this code. */
- ffesymbol_signal_change (s);
- ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
- ffesymbol_set_maxentrynum (s, ffeexpr_level_);
- ffesymbol_signal_unreported (s);
-#endif
- }
- break;
-
- case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
- If seen in outermore level, can't be an
- iterator here, so complain. If not seen
- at current level, complain for now,
- because that indicates something F90
- rejects (though we currently don't detect
- all such cases for now). */
- if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
- {
- ffesymbol_signal_change (s);
- ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, t);
- break;
-
- case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
- assert ("DATA implied-DO control var seen twice!!" == NULL);
- ffesymbol_error (s, t);
- break;
-
- case FFESYMBOL_stateUNDERSTOOD:
- break; /* ANY. */
-
- default:
- assert ("Foo Bletch!!" == NULL);
- break;
- }
-
- return s;
-}
-
-/* Have FOO in PARAMETER (FOO=...). */
-
-static ffesymbol
-ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
-
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (sa & ~(FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsTYPE))
- {
- if (!(sa & FFESYMBOL_attrsANY))
- ffesymbol_error (s, t);
- }
- else
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- if (!ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return s;
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
- embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
-
-static ffesymbol
-ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
- ffesymbolState ns;
- bool needs_type = FALSE;
-
- assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
-
- na = sa = ffesymbol_attrs (s);
-
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- ns = FFESYMBOL_stateUNDERSTOOD;
-
- if (sa & FFESYMBOL_attrsEXTERNAL)
- {
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- if (sa & FFESYMBOL_attrsTYPE)
- where = FFEINFO_whereGLOBAL;
- else
- /* Not TYPE. */
- {
- ns = FFESYMBOL_stateUNCERTAIN;
-
- if (sa & FFESYMBOL_attrsDUMMY)
- assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
- else if (sa & FFESYMBOL_attrsACTUALARG)
- ; /* Not DUMMY or TYPE. */
- else
- /* Not ACTUALARG, DUMMY, or TYPE. */
- {
- assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
- na |= FFESYMBOL_attrsACTUALARG;
- where = FFEINFO_whereGLOBAL;
- }
- }
- }
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- kind = FFEINFO_kindENTITY;
- if (!(sa & FFESYMBOL_attrsTYPE))
- needs_type = TRUE;
- }
- else if (sa & FFESYMBOL_attrsARRAY)
- {
- assert (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsTYPE)));
-
- where = FFEINFO_whereLOCAL;
- }
- else if (sa & FFESYMBOL_attrsSFARG)
- {
- assert (!(sa & ~(FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- where = FFEINFO_whereLOCAL;
- }
- else if (sa & FFESYMBOL_attrsTYPE)
- {
- assert (!(sa & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG))); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsTYPE
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG)));
-
- if (sa & FFESYMBOL_attrsANYLEN)
- ns = FFESYMBOL_stateNONE;
- else
- {
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereLOCAL;
- }
- }
- else if (sa == FFESYMBOL_attrsetNONE)
- {
- /* New state is left empty because there isn't any state flag to
- set for this case, and it's UNDERSTOOD after all. */
- assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereLOCAL;
- needs_type = TRUE;
- }
- else
- ns = FFESYMBOL_stateNONE; /* Error. */
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (ns == FFESYMBOL_stateNONE)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- if (needs_type && !ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return s;
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind,
- where,
- ffesymbol_size (s)));
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, ns);
- s = ffecom_sym_learned (s);
- ffesymbol_reference (s, t, FALSE);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
- a reference to FOO. */
-
-static ffesymbol
-ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
-
- na = sa = ffesymbol_attrs (s);
- kind = FFEINFO_kindENTITY;
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsADJUSTS;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Since this symbol definitely is going into an expression (the
- dimension-list for some dummy array, presumably), figure out WHERE if
- possible. */
-
- if (where == FFEINFO_whereNONE)
- {
- if (na & (FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST))
- where = FFEINFO_whereCOMMON;
- else if (na & FFESYMBOL_attrsDUMMY)
- where = FFEINFO_whereDUMMY;
- }
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- if (!ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return s;
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind, /* Always ENTITY. */
- where, /* NONE, COMMON, or DUMMY. */
- ffesymbol_size (s)));
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_resolve_intrin (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
- XYZ = BAR(FOO), as such cases are handled elsewhere. */
-
-static ffesymbol
-ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
- bool error = FALSE;
-
- assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
-
- na = sa = ffesymbol_attrs (s);
-
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (sa & FFESYMBOL_attrsEXTERNAL)
- {
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- error = TRUE;
- }
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- kind = FFEINFO_kindENTITY;
- }
- else if (sa & FFESYMBOL_attrsARRAY)
- {
- assert (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsTYPE)));
-
- where = FFEINFO_whereLOCAL;
- }
- else if (sa & FFESYMBOL_attrsSFARG)
- {
- assert (!(sa & ~(FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- where = FFEINFO_whereLOCAL;
- }
- else if (sa & FFESYMBOL_attrsTYPE)
- {
- assert (!(sa & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG))); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsTYPE
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG)));
-
- if (sa & FFESYMBOL_attrsANYLEN)
- error = TRUE;
- else
- {
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereLOCAL;
- }
- }
- else if (sa == FFESYMBOL_attrsetNONE)
- {
- assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereLOCAL;
- }
- else
- error = TRUE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (error)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- if (!ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return s;
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind, /* ENTITY. */
- where, /* LOCAL. */
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
-
- ffelexToken t;
- bool maybe_intrin;
- ffeexprParenType_ paren_type;
- ffesymbol s;
- s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
-
- Just like ffesymbol_declare_local, except performs any implicit info
- assignment necessary, and it returns the type of the parenthesized list
- (list of function args, list of array args, or substring spec). */
-
-static ffesymbol
-ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
- ffeexprParenType_ *paren_type)
-{
- ffesymbol s;
- ffesymbolState st; /* Effective state. */
- ffeinfoKind k;
- bool bad;
-
- if (maybe_intrin && ffesrc_check_symbol ())
- { /* Knock off some easy cases. */
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextSUBROUTINEREF:
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOINDEX_:
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextLET:
- case FFEEXPR_contextPAREN_:
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextDO:
- case FFEEXPR_contextDOWHILE:
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextCGOTO:
- case FFEEXPR_contextIF:
- case FFEEXPR_contextARITHIF:
- case FFEEXPR_contextFORMAT:
- case FFEEXPR_contextSTOP:
- case FFEEXPR_contextRETURN:
- case FFEEXPR_contextSELECTCASE:
- case FFEEXPR_contextCASE:
- case FFEEXPR_contextFILEASSOC:
- case FFEEXPR_contextFILEINT:
- case FFEEXPR_contextFILEDFINT:
- case FFEEXPR_contextFILELOG:
- case FFEEXPR_contextFILENUM:
- case FFEEXPR_contextFILENUMAMBIG:
- case FFEEXPR_contextFILECHAR:
- case FFEEXPR_contextFILENUMCHAR:
- case FFEEXPR_contextFILEDFCHAR:
- case FFEEXPR_contextFILEKEY:
- case FFEEXPR_contextFILEUNIT:
- case FFEEXPR_contextFILEUNIT_DF:
- case FFEEXPR_contextFILEUNITAMBIG:
- case FFEEXPR_contextFILEFORMAT:
- case FFEEXPR_contextFILENAMELIST:
- case FFEEXPR_contextFILEVXTCODE:
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- case FFEEXPR_contextIMPDOCTRL_:
- case FFEEXPR_contextDATAIMPDOCTRL_:
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextPARAMETER:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextDIMLISTCOMMON:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextINITVAL:
- case FFEEXPR_contextEQVINDEX_:
- break; /* These could be intrinsic invocations. */
-
- case FFEEXPR_contextAGOTO:
- case FFEEXPR_contextFILEFORMATNML:
- case FFEEXPR_contextALLOCATE:
- case FFEEXPR_contextDEALLOCATE:
- case FFEEXPR_contextHEAPSTAT:
- case FFEEXPR_contextNULLIFY:
- case FFEEXPR_contextINCLUDE:
- case FFEEXPR_contextDATAIMPDOITEM_:
- case FFEEXPR_contextLOC_:
- case FFEEXPR_contextINDEXORACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- case FFEEXPR_contextPARENFILENUM_:
- case FFEEXPR_contextPARENFILEUNIT_:
- maybe_intrin = FALSE;
- break; /* Can't be intrinsic invocation. */
-
- default:
- assert ("blah! blah! waaauuggh!" == NULL);
- break;
- }
- }
-
- s = ffesymbol_declare_local (t, maybe_intrin);
-
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- /* Special-case these since they can involve a different concept
- of "state" (in the stmtfunc name space). */
- {
- case FFEEXPR_contextDATAIMPDOINDEX_:
- case FFEEXPR_contextDATAIMPDOCTRL_:
- if (ffeexpr_context_outer_ (ffeexpr_stack_)
- == FFEEXPR_contextDATAIMPDOINDEX_)
- s = ffeexpr_sym_impdoitem_ (s, t);
- else
- if (ffeexpr_stack_->is_rhs)
- s = ffeexpr_sym_impdoitem_ (s, t);
- else
- s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
- if (ffesymbol_kind (s) != FFEINFO_kindANY)
- ffesymbol_error (s, t);
- return s;
-
- default:
- break;
- }
-
- switch ((ffesymbol_sfdummyparent (s) == NULL)
- ? ffesymbol_state (s)
- : FFESYMBOL_stateUNDERSTOOD)
- {
- case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
- context. */
- if (!ffest_seen_first_exec ())
- goto seen; /* :::::::::::::::::::: */
- /* Fall through. */
- case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextSUBROUTINEREF:
- s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
- FOO(...)". */
- break;
-
- case FFEEXPR_contextDATA:
- if (ffeexpr_stack_->is_rhs)
- s = ffeexpr_sym_rhs_let_ (s, t);
- else
- s = ffeexpr_sym_lhs_data_ (s, t);
- break;
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- s = ffeexpr_sym_lhs_data_ (s, t);
- break;
-
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- /* Fall through. */
- case FFEEXPR_contextLET:
- case FFEEXPR_contextPAREN_:
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextDO:
- case FFEEXPR_contextDOWHILE:
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextCGOTO:
- case FFEEXPR_contextIF:
- case FFEEXPR_contextARITHIF:
- case FFEEXPR_contextFORMAT:
- case FFEEXPR_contextSTOP:
- case FFEEXPR_contextRETURN:
- case FFEEXPR_contextSELECTCASE:
- case FFEEXPR_contextCASE:
- case FFEEXPR_contextFILEASSOC:
- case FFEEXPR_contextFILEINT:
- case FFEEXPR_contextFILEDFINT:
- case FFEEXPR_contextFILELOG:
- case FFEEXPR_contextFILENUM:
- case FFEEXPR_contextFILENUMAMBIG:
- case FFEEXPR_contextFILECHAR:
- case FFEEXPR_contextFILENUMCHAR:
- case FFEEXPR_contextFILEDFCHAR:
- case FFEEXPR_contextFILEKEY:
- case FFEEXPR_contextFILEUNIT:
- case FFEEXPR_contextFILEUNIT_DF:
- case FFEEXPR_contextFILEUNITAMBIG:
- case FFEEXPR_contextFILEFORMAT:
- case FFEEXPR_contextFILENAMELIST:
- case FFEEXPR_contextFILEVXTCODE:
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- case FFEEXPR_contextIMPDOCTRL_:
- case FFEEXPR_contextLOC_:
- if (ffeexpr_stack_->is_rhs)
- s = ffeexpr_paren_rhs_let_ (s, t);
- else
- s = ffeexpr_paren_lhs_let_ (s, t);
- break;
-
- case FFEEXPR_contextASSIGN:
- case FFEEXPR_contextAGOTO:
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextEQUIVALENCE:
- case FFEEXPR_contextINCLUDE:
- case FFEEXPR_contextPARAMETER:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextDIMLISTCOMMON:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextINITVAL:
- case FFEEXPR_contextEQVINDEX_:
- break; /* Will turn into errors below. */
-
- default:
- ffesymbol_error (s, t);
- break;
- }
- /* Fall through. */
- case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
- understood: /* :::::::::::::::::::: */
-
- /* State might have changed, update it. */
- st = ((ffesymbol_sfdummyparent (s) == NULL)
- ? ffesymbol_state (s)
- : FFESYMBOL_stateUNDERSTOOD);
-
- k = ffesymbol_kind (s);
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextSUBROUTINEREF:
- bad = ((k != FFEINFO_kindSUBROUTINE)
- && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
- || (k != FFEINFO_kindNONE)));
- break;
-
- case FFEEXPR_contextDATA:
- if (ffeexpr_stack_->is_rhs)
- bad = (k != FFEINFO_kindENTITY)
- || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
- else
- bad = (k != FFEINFO_kindENTITY)
- || ((ffesymbol_where (s) != FFEINFO_whereNONE)
- && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
- && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
- break;
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
- || ((ffesymbol_where (s) != FFEINFO_whereNONE)
- && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
- && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
- break;
-
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextLET:
- case FFEEXPR_contextPAREN_:
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextDO:
- case FFEEXPR_contextDOWHILE:
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextCGOTO:
- case FFEEXPR_contextIF:
- case FFEEXPR_contextARITHIF:
- case FFEEXPR_contextFORMAT:
- case FFEEXPR_contextSTOP:
- case FFEEXPR_contextRETURN:
- case FFEEXPR_contextSELECTCASE:
- case FFEEXPR_contextCASE:
- case FFEEXPR_contextFILEASSOC:
- case FFEEXPR_contextFILEINT:
- case FFEEXPR_contextFILEDFINT:
- case FFEEXPR_contextFILELOG:
- case FFEEXPR_contextFILENUM:
- case FFEEXPR_contextFILENUMAMBIG:
- case FFEEXPR_contextFILECHAR:
- case FFEEXPR_contextFILENUMCHAR:
- case FFEEXPR_contextFILEDFCHAR:
- case FFEEXPR_contextFILEKEY:
- case FFEEXPR_contextFILEUNIT:
- case FFEEXPR_contextFILEUNIT_DF:
- case FFEEXPR_contextFILEUNITAMBIG:
- case FFEEXPR_contextFILEFORMAT:
- case FFEEXPR_contextFILENAMELIST:
- case FFEEXPR_contextFILEVXTCODE:
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- case FFEEXPR_contextIMPDOCTRL_:
- case FFEEXPR_contextLOC_:
- bad = FALSE; /* Let paren-switch handle the cases. */
- break;
-
- case FFEEXPR_contextASSIGN:
- case FFEEXPR_contextAGOTO:
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextEQUIVALENCE:
- case FFEEXPR_contextPARAMETER:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextDIMLISTCOMMON:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextINITVAL:
- case FFEEXPR_contextEQVINDEX_:
- bad = (k != FFEINFO_kindENTITY)
- || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
- break;
-
- case FFEEXPR_contextINCLUDE:
- bad = TRUE;
- break;
-
- default:
- bad = TRUE;
- break;
- }
-
- switch (bad ? FFEINFO_kindANY : k)
- {
- case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
- if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
- {
- if (ffeexpr_context_outer_ (ffeexpr_stack_)
- == FFEEXPR_contextSUBROUTINEREF)
- *paren_type = FFEEXPR_parentypeSUBROUTINE_;
- else
- *paren_type = FFEEXPR_parentypeFUNCTION_;
- break;
- }
- if (st == FFESYMBOL_stateUNDERSTOOD)
- {
- bad = TRUE;
- *paren_type = FFEEXPR_parentypeANY_;
- }
- else
- *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
- break;
-
- case FFEINFO_kindFUNCTION:
- *paren_type = FFEEXPR_parentypeFUNCTION_;
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereLOCAL:
- bad = TRUE; /* Attempt to recurse! */
- break;
-
- case FFEINFO_whereCONSTANT:
- bad = ((ffesymbol_sfexpr (s) == NULL)
- || (ffebld_op (ffesymbol_sfexpr (s))
- == FFEBLD_opANY)); /* Attempt to recurse! */
- break;
-
- default:
- break;
- }
- break;
-
- case FFEINFO_kindSUBROUTINE:
- if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
- || (ffeexpr_stack_->previous != NULL))
- {
- bad = TRUE;
- *paren_type = FFEEXPR_parentypeANY_;
- break;
- }
-
- *paren_type = FFEEXPR_parentypeSUBROUTINE_;
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereLOCAL:
- case FFEINFO_whereCONSTANT:
- bad = TRUE; /* Attempt to recurse! */
- break;
-
- default:
- break;
- }
- break;
-
- case FFEINFO_kindENTITY:
- if (ffesymbol_rank (s) == 0)
- {
- if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
- *paren_type = FFEEXPR_parentypeSUBSTRING_;
- else
- {
- bad = TRUE;
- *paren_type = FFEEXPR_parentypeANY_;
- }
- }
- else
- *paren_type = FFEEXPR_parentypeARRAY_;
- break;
-
- default:
- case FFEINFO_kindANY:
- bad = TRUE;
- *paren_type = FFEEXPR_parentypeANY_;
- break;
- }
-
- if (bad)
- {
- if (k == FFEINFO_kindANY)
- ffest_shutdown ();
- else
- ffesymbol_error (s, t);
- }
-
- return s;
-
- case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
- seen: /* :::::::::::::::::::: */
- bad = TRUE;
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextPARAMETER:
- if (ffeexpr_stack_->is_rhs)
- ffesymbol_error (s, t);
- else
- s = ffeexpr_sym_lhs_parameter_ (s, t);
- break;
-
- case FFEEXPR_contextDATA:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- if (ffeexpr_stack_->is_rhs)
- ffesymbol_error (s, t);
- else
- s = ffeexpr_sym_lhs_data_ (s, t);
- goto understood; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- s = ffeexpr_sym_lhs_data_ (s, t);
- goto understood; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextEQUIVALENCE:
- s = ffeexpr_sym_lhs_equivalence_ (s, t);
- bad = FALSE;
- break;
-
- case FFEEXPR_contextDIMLIST:
- s = ffeexpr_sym_rhs_dimlist_ (s, t);
- bad = FALSE;
- break;
-
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextDIMLISTCOMMON:
- case FFEEXPR_contextINITVAL:
- case FFEEXPR_contextEQVINDEX_:
- break;
-
- case FFEEXPR_contextINCLUDE:
- break;
-
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- assert (ffeexpr_stack_->is_rhs);
- s = ffecom_sym_exec_transition (s);
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- goto understood; /* :::::::::::::::::::: */
- s = ffeexpr_paren_rhs_let_ (s, t);
- goto understood; /* :::::::::::::::::::: */
-
- default:
- break;
- }
- k = ffesymbol_kind (s);
- switch (bad ? FFEINFO_kindANY : k)
- {
- case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
- *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
- break;
-
- case FFEINFO_kindFUNCTION:
- *paren_type = FFEEXPR_parentypeFUNCTION_;
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereLOCAL:
- bad = TRUE; /* Attempt to recurse! */
- break;
-
- case FFEINFO_whereCONSTANT:
- bad = ((ffesymbol_sfexpr (s) == NULL)
- || (ffebld_op (ffesymbol_sfexpr (s))
- == FFEBLD_opANY)); /* Attempt to recurse! */
- break;
-
- default:
- break;
- }
- break;
-
- case FFEINFO_kindSUBROUTINE:
- *paren_type = FFEEXPR_parentypeANY_;
- bad = TRUE; /* Cannot possibly be in
- contextSUBROUTINEREF. */
- break;
-
- case FFEINFO_kindENTITY:
- if (ffesymbol_rank (s) == 0)
- {
- if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
- *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
- else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
- *paren_type = FFEEXPR_parentypeSUBSTRING_;
- else
- {
- bad = TRUE;
- *paren_type = FFEEXPR_parentypeANY_;
- }
- }
- else
- *paren_type = FFEEXPR_parentypeARRAY_;
- break;
-
- default:
- case FFEINFO_kindANY:
- bad = TRUE;
- *paren_type = FFEEXPR_parentypeANY_;
- break;
- }
-
- if (bad)
- {
- if (k == FFEINFO_kindANY)
- ffest_shutdown ();
- else
- ffesymbol_error (s, t);
- }
-
- return s;
-
- default:
- assert ("bad symbol state" == NULL);
- return NULL;
- }
-}
-
-/* Have FOO in XYZ = ...FOO(...).... Executable context only. */
-
-static ffesymbol
-ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
-{
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeinfoKind kind;
- ffeinfoWhere where;
- ffeintrinGen gen;
- ffeintrinSpec spec;
- ffeintrinImp imp;
- bool maybe_ambig = FALSE;
- bool error = FALSE;
-
- assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
-
- na = sa = ffesymbol_attrs (s);
-
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (sa & FFESYMBOL_attrsEXTERNAL)
- {
- assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- if (sa & FFESYMBOL_attrsTYPE)
- where = FFEINFO_whereGLOBAL;
- else
- /* Not TYPE. */
- {
- kind = FFEINFO_kindFUNCTION;
-
- if (sa & FFESYMBOL_attrsDUMMY)
- ; /* Not TYPE. */
- else if (sa & FFESYMBOL_attrsACTUALARG)
- ; /* Not DUMMY or TYPE. */
- else /* Not ACTUALARG, DUMMY, or TYPE. */
- where = FFEINFO_whereGLOBAL;
- }
- }
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsTYPE)));
-
- kind = FFEINFO_kindFUNCTION;
- maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
- could be ENTITY w/substring ref. */
- }
- else if (sa & FFESYMBOL_attrsARRAY)
- {
- assert (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsTYPE)));
-
- where = FFEINFO_whereLOCAL;
- }
- else if (sa & FFESYMBOL_attrsSFARG)
- {
- assert (!(sa & ~(FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)));
-
- where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
- know it's a local var. */
- }
- else if (sa & FFESYMBOL_attrsTYPE)
- {
- assert (!(sa & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG))); /* Handled above. */
- assert (!(sa & ~(FFESYMBOL_attrsTYPE
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG)));
-
- if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
- &gen, &spec, &imp))
- {
- if (!(sa & FFESYMBOL_attrsANYLEN)
- && (ffeimplic_peek_symbol_type (s, NULL)
- == FFEINFO_basictypeCHARACTER))
- return s; /* Haven't learned anything yet. */
-
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- ffesymbol_set_generic (s, gen);
- ffesymbol_set_specific (s, spec);
- ffesymbol_set_implementation (s, imp);
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindFUNCTION,
- FFEINFO_whereINTRINSIC,
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- ffesymbol_reference (s, t, FALSE);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
-
- return s;
- }
- if (sa & FFESYMBOL_attrsANYLEN)
- error = TRUE; /* Error, since the only way we can,
- given CHARACTER*(*) FOO, accept
- FOO(...) is for FOO to be a dummy
- arg or constant, but it can't
- become either now. */
- else if (sa & FFESYMBOL_attrsADJUSTABLE)
- {
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereLOCAL;
- }
- else
- {
- kind = FFEINFO_kindFUNCTION;
- where = FFEINFO_whereGLOBAL;
- maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
- could be ENTITY/LOCAL w/substring ref. */
- }
- }
- else if (sa == FFESYMBOL_attrsetNONE)
- {
- assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
-
- if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
- &gen, &spec, &imp))
- {
- if (ffeimplic_peek_symbol_type (s, NULL)
- == FFEINFO_basictypeCHARACTER)
- return s; /* Haven't learned anything yet. */
-
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- ffesymbol_set_generic (s, gen);
- ffesymbol_set_specific (s, spec);
- ffesymbol_set_implementation (s, imp);
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindFUNCTION,
- FFEINFO_whereINTRINSIC,
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- s = ffecom_sym_learned (s);
- ffesymbol_reference (s, t, FALSE);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- return s;
- }
-
- kind = FFEINFO_kindFUNCTION;
- where = FFEINFO_whereGLOBAL;
- maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
- could be ENTITY/LOCAL w/substring ref. */
- }
- else
- error = TRUE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (error)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_signal_change (s); /* May need to back up to previous
- version. */
- if (!ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return s;
- }
- if (maybe_ambig
- && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
- return s; /* Still not sure, let caller deal with it
- based on (...). */
-
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind,
- where,
- ffesymbol_size (s)));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- s = ffecom_sym_learned (s);
- ffesymbol_reference (s, t, FALSE);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- }
-
- return s;
-}
-
-/* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
-
-static ffelexHandler
-ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ procedure;
- ffebld reduced;
- ffeinfo info;
- ffeexprContext ctx;
- bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
-
- procedure = ffeexpr_stack_->exprstack;
- info = ffebld_info (procedure->u.operand);
-
- /* Is there an expression to add? If the expression is nil,
- it might still be an argument. It is if:
-
- - The current token is comma, or
-
- - The -fugly-comma flag was specified *and* the procedure
- being invoked is external.
-
- Otherwise, if neither of the above is the case, just
- ignore this (nil) expression. */
-
- if ((expr != NULL)
- || (ffelex_token_type (t) == FFELEX_typeCOMMA)
- || (ffe_is_ugly_comma ()
- && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
- {
- /* This expression, even if nil, is apparently intended as an argument. */
-
- /* Internal procedure (CONTAINS, or statement function)? */
-
- if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
- {
- if ((expr == NULL)
- && ffebad_start (FFEBAD_NULL_ARGUMENT))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_here (1, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- if (expr == NULL)
- ;
- else
- {
- if (ffeexpr_stack_->next_dummy == NULL)
- { /* Report later which was the first extra argument. */
- if (ffeexpr_stack_->tokens[1] == NULL)
- {
- ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
- ffeexpr_stack_->num_args = 0;
- }
- ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
- }
- else
- {
- if ((ffeinfo_rank (ffebld_info (expr)) != 0)
- && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
- {
- ffebad_here (0,
- ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_here (1, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
- (ffebld_symter (ffebld_head
- (ffeexpr_stack_->next_dummy)))));
- ffebad_finish ();
- }
- else
- {
- expr = ffeexpr_convert_expr (expr, ft,
- ffebld_head (ffeexpr_stack_->next_dummy),
- ffeexpr_stack_->tokens[0],
- FFEEXPR_contextLET);
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- }
- --ffeexpr_stack_->num_args; /* Count down # of args. */
- ffeexpr_stack_->next_dummy
- = ffebld_trail (ffeexpr_stack_->next_dummy);
- }
- }
- }
- else
- {
- if ((expr == NULL)
- && ffe_is_pedantic ()
- && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_here (1, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- }
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_context;
- break;
-
- default:
- ctx = FFEEXPR_contextACTUALARG_;
- break;
- }
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
- ffeexpr_token_arguments_);
-
- default:
- break;
- }
-
- if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
- && (ffeexpr_stack_->next_dummy != NULL))
- { /* Too few arguments. */
- if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
- {
- char num[10];
-
- sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
-
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_string (num);
- ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
- (ffebld_head (ffeexpr_stack_->next_dummy)))));
- ffebad_finish ();
- }
- for (;
- ffeexpr_stack_->next_dummy != NULL;
- ffeexpr_stack_->next_dummy
- = ffebld_trail (ffeexpr_stack_->next_dummy))
- {
- expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
- ffebld_set_info (expr, ffeinfo_new_any ());
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- }
- }
-
- if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
- && (ffeexpr_stack_->tokens[1] != NULL))
- { /* Too many arguments to statement function. */
- if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
- {
- char num[10];
-
- sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
-
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_string (num);
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
-
- if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
- {
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- }
- else
- {
- if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
- reduced = ffebld_new_funcref (procedure->u.operand,
- ffeexpr_stack_->expr);
- else
- reduced = ffebld_new_subrref (procedure->u.operand,
- ffeexpr_stack_->expr);
- if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
- ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
- else if (ffebld_symter_specific (procedure->u.operand)
- != FFEINTRIN_specNONE)
- ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
- ffeexpr_stack_->tokens[0]);
- else
- ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
-
- if (ffebld_op (reduced) != FFEBLD_opANY)
- ffebld_set_info (reduced,
- ffeinfo_new (ffeinfo_basictype (info),
- ffeinfo_kindtype (info),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereFLEETING,
- ffeinfo_size (info)));
- else
- ffebld_set_info (reduced, ffeinfo_new_any ());
- }
- if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
- reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
- ffeexpr_stack_->exprstack = procedure->previous; /* Pops
- not-quite-operand off
- stack. */
- procedure->u.operand = reduced; /* Save the line/column ffewhere
- info. */
- ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- {
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
-
- /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
- Z is DOUBLE COMPLEX), and a command-line option doesn't already
- establish interpretation, probably complain. */
-
- if (check_intrin
- && !ffe_is_90 ()
- && !ffe_is_ugly_complex ())
- {
- /* If the outer expression is REAL(me...), issue diagnostic
- only if next token isn't the close-paren for REAL(me). */
-
- if ((ffeexpr_stack_->previous != NULL)
- && (ffeexpr_stack_->previous->exprstack != NULL)
- && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
- && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
- && (ffebld_op (reduced) == FFEBLD_opSYMTER)
- && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
- return (ffelexHandler) ffeexpr_token_intrincheck_;
-
- /* Diagnose the ambiguity now. */
-
- if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
- {
- ffebad_string (ffeintrin_name_implementation
- (ffebld_symter_implementation
- (ffebld_left
- (ffeexpr_stack_->exprstack->u.operand))));
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
- ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
- ffebad_finish ();
- }
- }
- return (ffelexHandler) ffeexpr_token_substrp_;
- }
-
- if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_substrp_);
-}
-
-/* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
-
- Return a pointer to this array to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle expression and COMMA or CLOSE_PAREN. */
-
-static ffelexHandler
-ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ array;
- ffebld reduced;
- ffeinfo info;
- ffeinfoWhere where;
- ffetargetIntegerDefault val;
- ffetargetIntegerDefault lval = 0;
- ffetargetIntegerDefault uval = 0;
- ffebld lbound;
- ffebld ubound;
- bool lcheck;
- bool ucheck;
-
- array = ffeexpr_stack_->exprstack;
- info = ffebld_info (array->u.operand);
-
- if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
- (ffelex_token_type(t) ==
- FFELEX_typeCOMMA)) */ )
- {
- if (ffebad_start (FFEBAD_NULL_ELEMENT))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_here (1, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
- if (ffeexpr_stack_->rank < ffeinfo_rank (info))
- { /* Don't bother if we're going to complain
- later! */
- expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
- }
-
- if (expr == NULL)
- ;
- else if (ffeinfo_rank (info) == 0)
- { /* In EQUIVALENCE context, ffeinfo_rank(info)
- may == 0. */
- ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
- feature. */
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- }
- else
- {
- ++ffeexpr_stack_->rank;
- if (ffeexpr_stack_->rank > ffeinfo_rank (info))
- { /* Report later which was the first extra
- element. */
- if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
- ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
- }
- else
- {
- switch (ffeinfo_where (ffebld_info (expr)))
- {
- case FFEINFO_whereCONSTANT:
- break;
-
- case FFEINFO_whereIMMEDIATE:
- ffeexpr_stack_->constant = FALSE;
- break;
-
- default:
- ffeexpr_stack_->constant = FALSE;
- ffeexpr_stack_->immediate = FALSE;
- break;
- }
- if (ffebld_op (expr) == FFEBLD_opCONTER
- && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
- {
- val = ffebld_constant_integerdefault (ffebld_conter (expr));
-
- lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
- if (lbound == NULL)
- {
- lcheck = TRUE;
- lval = 1;
- }
- else if (ffebld_op (lbound) == FFEBLD_opCONTER)
- {
- lcheck = TRUE;
- lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
- }
- else
- lcheck = FALSE;
-
- ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
- assert (ubound != NULL);
- if (ffebld_op (ubound) == FFEBLD_opCONTER)
- {
- ucheck = TRUE;
- uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
- }
- else
- ucheck = FALSE;
-
- if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
- {
- ffebad_start (FFEBAD_RANGE_ARRAY);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- }
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
- }
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- switch (ffeexpr_context_outer_ (ffeexpr_stack_))
- {
- case FFEEXPR_contextDATAIMPDOITEM_:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextDATAIMPDOINDEX_,
- ffeexpr_token_elements_);
-
- case FFEEXPR_contextEQUIVALENCE:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextEQVINDEX_,
- ffeexpr_token_elements_);
-
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextSFUNCDEFINDEX_,
- ffeexpr_token_elements_);
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- assert ("bad context" == NULL);
- break;
-
- default:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextINDEX_,
- ffeexpr_token_elements_);
- }
-
- default:
- break;
- }
-
- if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
- && (ffeinfo_rank (info) != 0))
- {
- char num[10];
-
- if (ffeexpr_stack_->rank < ffeinfo_rank (info))
- {
- if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
- {
- sprintf (num, "%d",
- (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
-
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1,
- ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_string (num);
- ffebad_finish ();
- }
- }
- else
- {
- if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
- {
- sprintf (num, "%d",
- (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
-
- ffebad_here (0,
- ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_here (1,
- ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_string (num);
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- }
- while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
- {
- expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
- ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0, FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- }
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
-
- if (ffebld_op (array->u.operand) == FFEBLD_opANY)
- {
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- }
- else
- {
- reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
- if (ffeexpr_stack_->constant)
- where = FFEINFO_whereFLEETING_CADDR;
- else if (ffeexpr_stack_->immediate)
- where = FFEINFO_whereFLEETING_IADDR;
- else
- where = FFEINFO_whereFLEETING;
- ffebld_set_info (reduced,
- ffeinfo_new (ffeinfo_basictype (info),
- ffeinfo_kindtype (info),
- 0,
- FFEINFO_kindENTITY,
- where,
- ffeinfo_size (info)));
- reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
- }
-
- ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
- stack. */
- array->u.operand = reduced; /* Save the line/column ffewhere info. */
- ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
-
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeCHARACTER:
- ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
- break;
-
- case FFEINFO_basictypeNONE:
- ffeexpr_is_substr_ok_ = TRUE;
- assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
- break;
-
- default:
- ffeexpr_is_substr_ok_ = FALSE;
- break;
- }
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- {
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- return (ffelexHandler) ffeexpr_token_substrp_;
- }
-
- if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_substrp_);
-}
-
-/* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
-
- Return a pointer to this array to the lexer (ffelex), which will
- invoke it for the next token.
-
- If token is COLON, pass off to _substr_, else init list and pass off
- to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
- ? marks the token, and where FOO's rank/type has not yet been established,
- meaning we could be in a list of indices or in a substring
- specification. */
-
-static ffelexHandler
-ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- return ffeexpr_token_substring_ (ft, expr, t);
-
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return ffeexpr_token_elements_ (ft, expr, t);
-}
-
-/* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle expression (which may be null) and COLON. */
-
-static ffelexHandler
-ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ string;
- ffeinfo info;
- ffetargetIntegerDefault i;
- ffeexprContext ctx;
- ffetargetCharacterSize size;
-
- string = ffeexpr_stack_->exprstack;
- info = ffebld_info (string->u.operand);
- size = ffebld_size_max (string->u.operand);
-
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- {
- if ((expr != NULL)
- && (ffebld_op (expr) == FFEBLD_opCONTER)
- && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
- < 1)
- || ((size != FFETARGET_charactersizeNONE) && (i > size))))
- {
- ffebad_start (FFEBAD_RANGE_SUBSTR);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- ffeexpr_stack_->expr = expr;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- ctx = FFEEXPR_contextSFUNCDEFINDEX_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_context;
- break;
-
- default:
- ctx = FFEEXPR_contextINDEX_;
- break;
- }
-
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
- ffeexpr_token_substring_1_);
- }
-
- if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
-
- ffeexpr_stack_->expr = NULL;
- return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
-}
-
-/* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Handle expression (which might be null) and CLOSE_PAREN. */
-
-static ffelexHandler
-ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
-{
- ffeexprExpr_ string;
- ffebld reduced;
- ffebld substrlist;
- ffebld first = ffeexpr_stack_->expr;
- ffebld strop;
- ffeinfo info;
- ffeinfoWhere lwh;
- ffeinfoWhere rwh;
- ffeinfoWhere where;
- ffeinfoKindtype first_kt;
- ffeinfoKindtype last_kt;
- ffetargetIntegerDefault first_val;
- ffetargetIntegerDefault last_val;
- ffetargetCharacterSize size;
- ffetargetCharacterSize strop_size_max;
- bool first_known;
-
- string = ffeexpr_stack_->exprstack;
- strop = string->u.operand;
- info = ffebld_info (strop);
-
- if (first == NULL
- || (ffebld_op (first) == FFEBLD_opCONTER
- && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
- { /* The starting point is known. */
- first_val = (first == NULL) ? 1
- : ffebld_constant_integerdefault (ffebld_conter (first));
- first_known = TRUE;
- }
- else
- { /* Assume start of the entity. */
- first_val = 1;
- first_known = FALSE;
- }
-
- if (last != NULL
- && (ffebld_op (last) == FFEBLD_opCONTER
- && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
- { /* The ending point is known. */
- last_val = ffebld_constant_integerdefault (ffebld_conter (last));
-
- if (first_known)
- { /* The beginning point is a constant. */
- if (first_val <= last_val)
- size = last_val - first_val + 1;
- else
- {
- if (0 && ffe_is_90 ())
- size = 0;
- else
- {
- size = 1;
- ffebad_start (FFEBAD_ZERO_SIZE);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- }
- }
- else
- size = FFETARGET_charactersizeNONE;
-
- strop_size_max = ffebld_size_max (strop);
-
- if ((strop_size_max != FFETARGET_charactersizeNONE)
- && (last_val > strop_size_max))
- { /* Beyond maximum possible end of string. */
- ffebad_start (FFEBAD_RANGE_SUBSTR);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- }
- else
- size = FFETARGET_charactersizeNONE; /* The size is not known. */
-
-#if 0 /* Don't do this, or "is size of target
- known?" would no longer be easily
- answerable. To see if there is a max
- size, use ffebld_size_max; to get only the
- known size, else NONE, use
- ffebld_size_known; use ffebld_size if
- values are sure to be the same (not
- opSUBSTR or opCONCATENATE or known to have
- known length). By getting rid of this
- "useful info" stuff, we don't end up
- blank-padding the constant in the
- assignment "A(I:J)='XYZ'" to the known
- length of A. */
- if (size == FFETARGET_charactersizeNONE)
- size = strop_size_max; /* Assume we use the entire string. */
-#endif
-
- substrlist
- = ffebld_new_item
- (first,
- ffebld_new_item
- (last,
- NULL
- )
- )
- ;
-
- if (first == NULL)
- lwh = FFEINFO_whereCONSTANT;
- else
- lwh = ffeinfo_where (ffebld_info (first));
- if (last == NULL)
- rwh = FFEINFO_whereCONSTANT;
- else
- rwh = ffeinfo_where (ffebld_info (last));
-
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- where = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- where = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- where = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- where = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- where = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- where = FFEINFO_whereFLEETING;
- break;
- }
-
- if (first == NULL)
- first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
- else
- first_kt = ffeinfo_kindtype (ffebld_info (first));
- if (last == NULL)
- last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
- else
- last_kt = ffeinfo_kindtype (ffebld_info (last));
-
- switch (where)
- {
- case FFEINFO_whereCONSTANT:
- switch (ffeinfo_where (info))
- {
- case FFEINFO_whereCONSTANT:
- break;
-
- case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
- where = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- where = FFEINFO_whereFLEETING_CADDR;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (ffeinfo_where (info))
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
- break;
-
- default:
- where = FFEINFO_whereFLEETING_IADDR;
- break;
- }
- break;
-
- default:
- switch (ffeinfo_where (info))
- {
- case FFEINFO_whereCONSTANT:
- where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
- break;
-
- case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
- default:
- where = FFEINFO_whereFLEETING;
- break;
- }
- break;
- }
-
- if (ffebld_op (strop) == FFEBLD_opANY)
- {
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- }
- else
- {
- reduced = ffebld_new_substr (strop, substrlist);
- ffebld_set_info (reduced, ffeinfo_new
- (FFEINFO_basictypeCHARACTER,
- ffeinfo_kindtype (info),
- 0,
- FFEINFO_kindENTITY,
- where,
- size));
- reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
- }
-
- ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
- stack. */
- string->u.operand = reduced; /* Save the line/column ffewhere info. */
- ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- {
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
- return (ffelexHandler) ffeexpr_token_substrp_;
- }
-
- if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_substrp_);
-}
-
-/* ffeexpr_token_substrp_ -- Rhs <character entity>
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
- issue error message if flag (serves as argument) is set. Else, just
- forward token to binary_. */
-
-static ffelexHandler
-ffeexpr_token_substrp_ (ffelexToken t)
-{
- ffeexprContext ctx;
-
- if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
- return (ffelexHandler) ffeexpr_token_binary_ (t);
-
- ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextSFUNCDEF:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- ctx = FFEEXPR_contextSFUNCDEFINDEX_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_context;
- break;
-
- default:
- ctx = FFEEXPR_contextINDEX_;
- break;
- }
-
- if (!ffeexpr_is_substr_ok_)
- {
- if (ffebad_start (FFEBAD_BAD_SUBSTR))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
- ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
- ffebad_finish ();
- }
-
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
- ffeexpr_token_anything_);
- }
-
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
- ffeexpr_token_substring_);
-}
-
-static ffelexHandler
-ffeexpr_token_intrincheck_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
- {
- ffebad_string (ffeintrin_name_implementation
- (ffebld_symter_implementation
- (ffebld_left
- (ffeexpr_stack_->exprstack->u.operand))));
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
- ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
- ffebad_finish ();
- }
-
- return (ffelexHandler) ffeexpr_token_substrp_ (t);
-}
-
-/* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- If COLON, do everything we would have done since _parenthesized_ if
- we had known NAME represented a kindENTITY instead of a kindFUNCTION.
- If not COLON, do likewise for kindFUNCTION instead. */
-
-static ffelexHandler
-ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeinfoWhere where;
- ffesymbol s;
- ffesymbolAttrs sa;
- ffebld symter = ffeexpr_stack_->exprstack->u.operand;
- bool needs_type;
- ffeintrinGen gen;
- ffeintrinSpec spec;
- ffeintrinImp imp;
-
- s = ffebld_symter (symter);
- sa = ffesymbol_attrs (s);
- where = ffesymbol_where (s);
-
- /* We get here only if we don't already know enough about FOO when seeing a
- FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
- "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
- Else FOO is a function, either intrinsic or external. If intrinsic, it
- wouldn't necessarily be CHARACTER type, so unless it has already been
- declared DUMMY, it hasn't had its type established yet. It can't be
- CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
-
- assert (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsTYPE)));
-
- needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
-
- ffesymbol_signal_change (s); /* Probably already done, but in case.... */
-
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- { /* Definitely an ENTITY (char substring). */
- if (needs_type && !ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
- return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
- }
-
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- FFEINFO_kindENTITY,
- (where == FFEINFO_whereNONE)
- ? FFEINFO_whereLOCAL
- : where,
- ffesymbol_size (s)));
- ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
-
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
-
- ffeexpr_stack_->exprstack->u.operand
- = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
-
- return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
- }
-
- /* The "stuff" isn't a substring notation, so we now know the overall
- reference is to a function. */
-
- if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
- FALSE, &gen, &spec, &imp))
- {
- ffebld_symter_set_generic (symter, gen);
- ffebld_symter_set_specific (symter, spec);
- ffebld_symter_set_implementation (symter, imp);
- ffesymbol_set_generic (s, gen);
- ffesymbol_set_specific (s, spec);
- ffesymbol_set_implementation (s, imp);
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindFUNCTION,
- FFEINFO_whereINTRINSIC,
- ffesymbol_size (s)));
- }
- else
- { /* Not intrinsic, now needs CHAR type. */
- if (!ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
- return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
- }
-
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- FFEINFO_kindFUNCTION,
- (where == FFEINFO_whereNONE)
- ? FFEINFO_whereGLOBAL
- : where,
- ffesymbol_size (s)));
- }
-
- ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
-
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_resolve_intrin (s);
- s = ffecom_sym_learned (s);
- ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
- ffesymbol_signal_unreported (s); /* For debugging purposes. */
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
-}
-
-/* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
-
- Handle basically any expression, looking for CLOSE_PAREN. */
-
-static ffelexHandler
-ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
- ffelexToken t)
-{
- ffeexprExpr_ e = ffeexpr_stack_->exprstack;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLON:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextACTUALARG_,
- ffeexpr_token_anything_);
-
- default:
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- ffeexpr_is_substr_ok_ = FALSE;
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_token_substrp_;
- return (ffelexHandler) ffeexpr_token_substrp_ (t);
- }
-}
-
-/* Terminate module. */
-
-void
-ffeexpr_terminate_2 (void)
-{
- assert (ffeexpr_stack_ == NULL);
- assert (ffeexpr_level_ == 0);
-}
+++ /dev/null
-/* expr.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 1996 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- expr.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_EXPR_H
-#define GCC_F_EXPR_H
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFEEXPR_contextLET,
- FFEEXPR_contextASSIGN,
- FFEEXPR_contextIOLIST,
- FFEEXPR_contextPARAMETER,
- FFEEXPR_contextSUBROUTINEREF,
- FFEEXPR_contextDATA,
- FFEEXPR_contextIF,
- FFEEXPR_contextARITHIF,
- FFEEXPR_contextDO,
- FFEEXPR_contextDOWHILE,
- FFEEXPR_contextFORMAT,
- FFEEXPR_contextAGOTO,
- FFEEXPR_contextCGOTO,
- FFEEXPR_contextCHARACTERSIZE,
- FFEEXPR_contextEQUIVALENCE,
- FFEEXPR_contextSTOP,
- FFEEXPR_contextRETURN,
- FFEEXPR_contextSFUNCDEF,
- FFEEXPR_contextINCLUDE,
- FFEEXPR_contextWHERE,
- FFEEXPR_contextSELECTCASE,
- FFEEXPR_contextCASE,
- FFEEXPR_contextDIMLIST,
- FFEEXPR_contextDIMLISTCOMMON, /* Dim list in COMMON stmt. */
- FFEEXPR_contextFILEASSOC, /* ASSOCIATEVARIABLE=. */
- FFEEXPR_contextFILEINT, /* IOSTAT=. */
- FFEEXPR_contextFILEDFINT, /* NEXTREC=. */
- FFEEXPR_contextFILELOG, /* NAMED=. */
- FFEEXPR_contextFILENUM, /* Numerical expression. */
- FFEEXPR_contextFILECHAR, /* Character expression. */
- FFEEXPR_contextFILENUMCHAR, /* READ KEYxyz=. */
- FFEEXPR_contextFILEDFCHAR, /* Default kind character expression. */
- FFEEXPR_contextFILEKEY, /* OPEN KEY=. */
- FFEEXPR_contextFILEEXTFUNC, /* USEROPEN=. */
- FFEEXPR_contextFILEUNIT, /* READ/WRITE UNIT=. */
- FFEEXPR_contextFILEUNIT_DF, /* DEFINE FILE unit (no "(" after it). */
- FFEEXPR_contextFILEFORMATNML, /* [FMT=] or [NML=]. */
- FFEEXPR_contextFILEFORMAT, /* FMT=. */
- FFEEXPR_contextFILENAMELIST,/* NML=. */
- FFEEXPR_contextFILENUMAMBIG,/* BACKSPACE, ENDFILE, REWIND, UNLOCK...
- where at e.g. BACKSPACE(, if COMMA seen
- before ), it is ok. */
- FFEEXPR_contextFILEUNITAMBIG, /* READ(, if COMMA seen before ), ok. */
- FFEEXPR_contextFILEVXTCODE, /* ENCODE/DECODE third arg (scalar/array). */
- FFEEXPR_contextALLOCATE, /* ALLOCATE objects (weird). */
- FFEEXPR_contextDEALLOCATE, /* DEALLOCATE objects (weird). */
- FFEEXPR_contextHEAPSTAT, /* ALLOCATE/DEALLOCATE STAT= variable. */
- FFEEXPR_contextKINDTYPE, /* KIND=. */
- FFEEXPR_contextINITVAL, /* R426 =initialization-expr. */
- FFEEXPR_contextNULLIFY, /* Pointer names only (F90) or pointers. */
- FFEEXPR_contextIOLISTDF, /* IOLIST w/internal file (V112 9-14 30,31). */
- FFEEXPR_contextINDEX_, /* Element dimension or substring value. */
- FFEEXPR_contextEQVINDEX_, /* EQUIVALENCE element dimension. */
- FFEEXPR_contextDATAIMPDOINDEX_, /* INDEX in DATAIMPDO context. */
- FFEEXPR_contextIMPDOITEM_,
- FFEEXPR_contextIMPDOITEMDF_,/* to ...ITEM_ as IOLISTDF is to IOLIST. */
- FFEEXPR_contextIMPDOCTRL_,
- FFEEXPR_contextDATAIMPDOITEM_,
- FFEEXPR_contextDATAIMPDOCTRL_,
- FFEEXPR_contextLOC_,
- FFEEXPR_contextACTUALARG_, /* Actual arg to function or subroutine;
- turns into ACTUALARGEXPR_ if tokens not
- NAME (CLOSE_PAREN/COMMA) or PERCENT.... */
- FFEEXPR_contextACTUALARGEXPR_, /* Like LET but disallow CHAR*(*)
- concats. */
- FFEEXPR_contextINDEXORACTUALARG_, /* "CHARACTER FOO; PRINT *,FOO(?". */
- FFEEXPR_contextINDEXORACTUALARGEXPR_, /* ? not NAME
- (CLOSE_PAREN/COMMA). */
- FFEEXPR_contextSFUNCDEFINDEX_, /* INDEX_ within stmt-func def. */
- FFEEXPR_contextSFUNCDEFACTUALARG_,
- FFEEXPR_contextSFUNCDEFACTUALARGEXPR_,
- FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_,
- FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_,
- FFEEXPR_contextPAREN_, /* Rhs paren except in LET context. */
- FFEEXPR_contextPARENFILENUM_, /* Either PAREN or FILENUM context. */
- FFEEXPR_contextPARENFILEUNIT_, /* Either PAREN or FILEUNIT context. */
- FFEEXPR_context
- } ffeexprContext;
-
-/* Typedefs. */
-
-
-/* Include files needed by this one. */
-
-#include "bld.h"
-#include "lex.h"
-#include "malloc.h"
-
-/* Structure definitions. */
-
-typedef ffelexHandler (*ffeexprCallback) (ffelexToken ft, ffebld expr,
- ffelexToken t);
-
-/* Global objects accessed by users of this module. */
-
-
-/* Declare functions with prototypes. */
-
-ffebld ffeexpr_collapse_convert (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_paren (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_uplus (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_uminus (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_not (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_add (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_subtract (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_multiply (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_divide (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_power (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_lt (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_le (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_eq (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_ne (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_gt (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_ge (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_and (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_or (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_xor (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_eqv (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_neqv (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_symter (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_funcref (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t);
-ffebld ffeexpr_collapse_substr (ffebld expr, ffelexToken t);
-ffebld ffeexpr_convert (ffebld source, ffelexToken source_token,
- ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt,
- ffeinfoRank rk, ffetargetCharacterSize sz,
- ffeexprContext context);
-ffebld ffeexpr_convert_expr (ffebld source, ffelexToken source_token,
- ffebld dest, ffelexToken dest_token,
- ffeexprContext context);
-ffebld ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
- ffesymbol dest, ffelexToken dest_token);
-void ffeexpr_init_2 (void);
-ffelexHandler ffeexpr_rhs (mallocPool pool, ffeexprContext context,
- ffeexprCallback callback);
-ffelexHandler ffeexpr_lhs (mallocPool pool, ffeexprContext context,
- ffeexprCallback callback);
-void ffeexpr_terminate_2 (void);
-void ffeexpr_type_combine (ffeinfoBasictype *nbt, ffeinfoKindtype *nkt,
- ffeinfoBasictype lbt, ffeinfoKindtype lkt,
- ffeinfoBasictype rbt, ffeinfoKindtype rkt,
- ffelexToken t);
-
-/* Define macros. */
-
-#define ffeexpr_init_0()
-#define ffeexpr_init_1()
-#define ffeexpr_init_3()
-#define ffeexpr_init_4()
-#define ffeexpr_terminate_0()
-#define ffeexpr_terminate_1()
-#define ffeexpr_terminate_3()
-#define ffeexpr_terminate_4()
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_EXPR_H */
+++ /dev/null
-@c Copyright (C) 1999, 2003 Free Software Foundation, Inc.
-@c This is part of the G77 manual.
-@c For copying conditions, see the file g77.texi.
-
-@node Front End
-@chapter Front End
-@cindex GNU Fortran Front End (FFE)
-@cindex FFE
-@cindex @code{g77}, front end
-@cindex front end, @code{g77}
-
-This chapter describes some aspects of the design and implementation
-of the @code{g77} front end.
-
-To find about things that are ``To Be Determined'' or ``To Be Done'',
-search for the string TBD.
-If you want to help by working on one or more of these items,
-email @email{gcc@@gcc.gnu.org}.
-If you're planning to do more than just research issues and offer comments,
-see @uref{http://gcc.gnu.org/contribute.html} for steps you might
-need to take first.
-
-@menu
-* Overview of Sources::
-* Overview of Translation Process::
-* Philosophy of Code Generation::
-* Two-pass Design::
-* Challenges Posed::
-* Transforming Statements::
-* Transforming Expressions::
-* Internal Naming Conventions::
-@end menu
-
-@node Overview of Sources
-@section Overview of Sources
-
-The current directory layout includes the following:
-
-@table @file
-@item @var{srcdir}/gcc/
-Non-g77 files in gcc
-
-@item @var{srcdir}/gcc/f/
-GNU Fortran front end sources
-
-@item @var{srcdir}/libf2c/
-@code{libg2c} configuration and @code{g2c.h} file generation
-
-@item @var{srcdir}/libf2c/libF77/
-General support and math portion of @code{libg2c}
-
-@item @var{srcdir}/libf2c/libI77/
-I/O portion of @code{libg2c}
-
-@item @var{srcdir}/libf2c/libU77/
-Additional interfaces to Unix @code{libc} for @code{libg2c}
-@end table
-
-Components of note in @code{g77} are described below.
-
-@file{f/} as a whole contains the source for @code{g77},
-while @file{libf2c/} contains a portion of the separate program
-@code{f2c}.
-Note that the @code{libf2c} code is not part of the program @code{g77},
-just distributed with it.
-
-@file{f/} contains text files that document the Fortran compiler, source
-files for the GNU Fortran Front End (FFE), and some other stuff.
-The @code{g77} compiler code is placed in @file{f/} because it,
-along with its contents,
-is designed to be a subdirectory of a @code{gcc} source directory,
-@file{gcc/},
-which is structured so that language-specific front ends can be ``dropped
-in'' as subdirectories.
-The C++ front end (@code{g++}), is an example of this---it resides in
-the @file{cp/} subdirectory.
-Note that the C front end (also referred to as @code{gcc})
-is an exception to this, as its source files reside
-in the @file{gcc/} directory itself.
-
-@file{libf2c/} contains the run-time libraries for the @code{f2c} program,
-also used by @code{g77}.
-These libraries normally referred to collectively as @code{libf2c}.
-When built as part of @code{g77},
-@code{libf2c} is installed under the name @code{libg2c} to avoid
-conflict with any existing version of @code{libf2c},
-and thus is often referred to as @code{libg2c} when the
-@code{g77} version is specifically being referred to.
-
-The @code{netlib} version of @code{libf2c/}
-contains two distinct libraries,
-@code{libF77} and @code{libI77},
-each in their own subdirectories.
-In @code{g77}, this distinction is not made,
-beyond maintaining the subdirectory structure in the source-code tree.
-
-@file{libf2c/} is not part of the program @code{g77},
-just distributed with it.
-It contains files not present
-in the official (@code{netlib}) version of @code{libf2c},
-and also contains some minor changes made from @code{libf2c},
-to fix some bugs,
-and to facilitate automatic configuration, building, and installation of
-@code{libf2c} (as @code{libg2c}) for use by @code{g77} users.
-See @file{libf2c/README} for more information,
-including licensing conditions
-governing distribution of programs containing code from @code{libg2c}.
-
-@code{libg2c}, @code{g77}'s version of @code{libf2c},
-adds Dave Love's implementation of @code{libU77},
-in the @file{libf2c/libU77/} directory.
-This library is distributed under the
-GNU Library General Public License (LGPL)---see the
-file @file{libf2c/libU77/COPYING.LIB}
-for more information,
-as this license
-governs distribution conditions for programs containing code
-from this portion of the library.
-
-Files of note in @file{f/} and @file{libf2c/} are described below:
-
-@table @file
-@item f/BUGS
-Lists some important bugs known to be in g77.
-Or use Info (or GNU Emacs Info mode) to read
-the ``Actual Bugs'' node of the @code{g77} documentation:
-
-@smallexample
-info -f f/g77.info -n "Actual Bugs"
-@end smallexample
-
-@item f/ChangeLog
-Lists recent changes to @code{g77} internals.
-
-@item libf2c/ChangeLog
-Lists recent changes to @code{libg2c} internals.
-
-@item f/NEWS
-Contains the per-release changes.
-These include the user-visible
-changes described in the node ``Changes''
-in the @code{g77} documentation, plus internal
-changes of import.
-Or use:
-
-@smallexample
-info -f f/g77.info -n News
-@end smallexample
-
-@item f/g77.info*
-The @code{g77} documentation, in Info format,
-produced by building @code{g77}.
-
-All users of @code{g77} (not just installers) should read this,
-using the @code{more} command if neither the @code{info} command,
-nor GNU Emacs (with its Info mode), are available, or if users
-aren't yet accustomed to using these tools.
-All of these files are readable as ``plain text'' files,
-though they're easier to navigate using Info readers
-such as @code{info} and GNU Emacs Info mode.
-@end table
-
-If you want to explore the FFE code, which lives entirely in @file{f/},
-here are a few clues.
-The file @file{g77spec.c} contains the @code{g77}-specific source code
-for the @code{g77} command only---this just forms a variant of the
-@code{gcc} command, so,
-just as the @code{gcc} command itself does not contain the C front end,
-the @code{g77} command does not contain the Fortran front end (FFE).
-The FFE code ends up in an executable named @file{f771},
-which does the actual compiling,
-so it contains the FFE plus the @code{gcc} back end (GBE),
-the latter to do most of the optimization, and the code generation.
-
-The file @file{parse.c} is the source file for @code{yyparse()},
-which is invoked by the GBE to start the compilation process,
-for @file{f771}.
-
-The file @file{top.c} contains the top-level FFE function @code{ffe_file}
-and it (along with top.h) define all @samp{ffe_[a-z].*}, @samp{ffe[A-Z].*},
-and @samp{FFE_[A-Za-z].*} symbols.
-
-The file @file{fini.c} is a @code{main()} program that is used when building
-the FFE to generate C header and source files for recognizing keywords.
-The files @file{malloc.c} and @file{malloc.h} comprise a memory manager
-that defines all @samp{malloc_[a-z].*}, @samp{malloc[A-Z].*}, and
-@samp{MALLOC_[A-Za-z].*} symbols.
-
-All other modules named @var{xyz}
-are comprised of all files named @samp{@var{xyz}*.@var{ext}}
-and define all @samp{ffe@var{xyz}_[a-z].*}, @samp{ffe@var{xyz}[A-Z].*},
-and @samp{FFE@var{XYZ}_[A-Za-z].*} symbols.
-If you understand all this, congratulations---it's easier for me to remember
-how it works than to type in these regular expressions.
-But it does make it easy to find where a symbol is defined.
-For example, the symbol @samp{ffexyz_set_something} would be defined
-in @file{xyz.h} and implemented there (if it's a macro) or in @file{xyz.c}.
-
-The ``porting'' files of note currently are:
-
-@table @file
-@item proj.h
-This defines the ``language'' used by all the other source files,
-the language being Standard C plus some useful things
-like @code{ARRAY_SIZE} and such.
-
-@item target.c
-@itemx target.h
-These describe the target machine
-in terms of what data types are supported,
-how they are denoted
-(to what C type does an @code{INTEGER*8} map, for example),
-how to convert between them,
-and so on.
-Over time, versions of @code{g77} rely less on this file
-and more on run-time configuration based on GBE info
-in @file{com.c}.
-
-@item com.c
-@itemx com.h
-These are the primary interface to the GBE.
-
-@item ste.c
-@itemx ste.h
-This contains code for implementing recognized executable statements
-in the GBE.
-
-@item src.c
-@itemx src.h
-These contain information on the format(s) of source files
-(such as whether they are never to be processed as case-insensitive
-with regard to Fortran keywords).
-@end table
-
-If you want to debug the @file{f771} executable,
-for example if it crashes,
-note that the global variables @code{lineno} and @code{input_filename}
-are usually set to reflect the current line being read by the lexer
-during the first-pass analysis of a program unit and to reflect
-the current line being processed during the second-pass compilation
-of a program unit.
-
-If an invocation of the function @code{ffestd_exec_end} is on the stack,
-the compiler is in the second pass, otherwise it is in the first.
-
-(This information might help you reduce a test case and/or work around
-a bug in @code{g77} until a fix is available.)
-
-@node Overview of Translation Process
-@section Overview of Translation Process
-
-The order of phases translating source code to the form accepted
-by the GBE is:
-
-@enumerate
-@item
-Stripping punched-card sources (@file{g77stripcard.c})
-
-@item
-Lexing (@file{lex.c})
-
-@item
-Stand-alone statement identification (@file{sta.c})
-
-@item
-INCLUDE handling (@file{sti.c})
-
-@item
-Order-dependent statement identification (@file{stq.c})
-
-@item
-Parsing (@file{stb.c} and @file{expr.c})
-
-@item
-Constructing (@file{stc.c})
-
-@item
-Collecting (@file{std.c})
-
-@item
-Expanding (@file{ste.c})
-@end enumerate
-
-To get a rough idea of how a particularly twisted Fortran statement
-gets treated by the passes, consider:
-
-@smallexample
- FORMAT(I2 4H)=(J/
- & I3)
-@end smallexample
-
-The job of @file{lex.c} is to know enough about Fortran syntax rules
-to break the statement up into distinct lexemes without requiring
-any feedback from subsequent phases:
-
-@smallexample
-`FORMAT'
-`('
-`I24H'
-`)'
-`='
-`('
-`J'
-`/'
-`I3'
-`)'
-@end smallexample
-
-The job of @file{sta.c} is to figure out the kind of statement,
-or, at least, statement form, that sequence of lexemes represent.
-
-The sooner it can do this (in terms of using the smallest number of
-lexemes, starting with the first for each statement), the better,
-because that leaves diagnostics for problems beyond the recognition
-of the statement form to subsequent phases,
-which can usually better describe the nature of the problem.
-
-In this case, the @samp{=} at ``level zero''
-(not nested within parentheses)
-tells @file{sta.c} that this is an @emph{assignment-form},
-not @code{FORMAT}, statement.
-
-An assignment-form statement might be a statement-function
-definition or an executable assignment statement.
-
-To make that determination,
-@file{sta.c} looks at the first two lexemes.
-
-Since the second lexeme is @samp{(},
-the first must represent an array for this to be an assignment statement,
-else it's a statement function.
-
-Either way, @file{sta.c} hands off the statement to @file{stq.c}
-(via @file{sti.c}, which expands INCLUDE files).
-@file{stq.c} figures out what a statement that is,
-on its own, ambiguous, must actually be based on the context
-established by previous statements.
-
-So, @file{stq.c} watches the statement stream for executable statements,
-END statements, and so on, so it knows whether @samp{A(B)=C} is
-(intended as) a statement-function definition or an assignment statement.
-
-After establishing the context-aware statement info, @file{stq.c}
-passes the original sample statement on to @file{stb.c}
-(either its statement-function parser or its assignment-statement parser).
-
-@file{stb.c} forms a
-statement-specific record containing the pertinent information.
-That information includes a source expression and,
-for an assignment statement, a destination expression.
-Expressions are parsed by @file{expr.c}.
-
-This record is passed to @file{stc.c},
-which copes with the implications of the statement
-within the context established by previous statements.
-
-For example, if it's the first statement in the file
-or after an @code{END} statement,
-@file{stc.c} recognizes that, first of all,
-a main program unit is now being lexed
-(and tells that to @file{std.c}
-before telling it about the current statement).
-
-@file{stc.c} attaches whatever information it can,
-usually derived from the context established by the preceding statements,
-and passes the information to @file{std.c}.
-
-@file{std.c} saves this information away,
-since the GBE cannot cope with information
-that might be incomplete at this stage.
-
-For example, @samp{I3} might later be determined
-to be an argument to an alternate @code{ENTRY} point.
-
-When @file{std.c} is told about the end of an external (top-level)
-program unit,
-it passes all the information it has saved away
-on statements in that program unit
-to @file{ste.c}.
-
-@file{ste.c} ``expands'' each statement, in sequence, by
-constructing the appropriate GBE information and calling
-the appropriate GBE routines.
-
-Details on the transformational phases follow.
-Keep in mind that Fortran numbering is used,
-so the first character on a line is column 1,
-decimal numbering is used, and so on.
-
-@menu
-* g77stripcard::
-* lex.c::
-* sta.c::
-* sti.c::
-* stq.c::
-* stb.c::
-* expr.c::
-* stc.c::
-* std.c::
-* ste.c::
-
-* Gotchas (Transforming)::
-* TBD (Transforming)::
-@end menu
-
-@node g77stripcard
-@subsection g77stripcard
-
-The @code{g77stripcard} program handles removing content beyond
-column 72 (adjustable via a command-line option),
-optionally warning about that content being something other
-than trailing whitespace or Fortran commentary.
-
-This program is needed because @code{lex.c} doesn't pay attention
-to maximum line lengths at all, to make it easier to maintain,
-as well as faster (for sources that don't depend on the maximum
-column length vis-a-vis trailing non-blank non-commentary content).
-
-Just how this program will be run---whether automatically for
-old source (perhaps as the default for @file{.f} files?)---is not
-yet determined.
-
-In the meantime, it might as well be implemented as a typical UNIX pipe.
-
-It should accept a @samp{-fline-length-@var{n}} option,
-with the default line length set to 72.
-
-When the text it strips off the end of a line is not blank
-(not spaces and tabs),
-it should insert an additional comment line
-(beginning with @samp{!},
-so it works for both fixed-form and free-form files)
-containing the text,
-following the stripped line.
-The inserted comment should have a prefix of some kind,
-TBD, that distinguishes the comment as representing stripped text.
-Users could use that to @code{sed} out such lines, if they wished---it
-seems silly to provide a command-line option to delete information
-when it can be so easily filtered out by another program.
-
-(This inserted comment should be designed to ``fit in'' well
-with whatever the Fortran community is using these days for
-preprocessor, translator, and other such products, like OpenMP.
-What that's all about, and how @code{g77} can elegantly fit its
-special comment conventions into it all, is TBD as well.
-We don't want to reinvent the wheel here, but if there turn out
-to be too many conflicting conventions, we might have to invent
-one that looks nothing like the others, but which offers their
-host products a better infrastructure in which to fit and coexist
-peacefully.)
-
-@code{g77stripcard} probably shouldn't do any tab expansion or other
-fancy stuff.
-People can use @code{expand} or other pre-filtering if they like.
-The idea here is to keep each stage quite simple, while providing
-excellent performance for ``normal'' code.
-
-(Code with junk beyond column 73 is not really ``normal'',
-as it comes from a card-punch heritage,
-and will be increasingly hard for tomorrow's Fortran programmers to read.)
-
-@node lex.c
-@subsection lex.c
-
-To help make the lexer simple, fast, and easy to maintain,
-while also having @code{g77} generally encourage Fortran programmers
-to write simple, maintainable, portable code by maximizing the
-performance of compiling that kind of code:
-
-@itemize @bullet
-@item
-There'll be just one lexer, for both fixed-form and free-form source.
-
-@item
-It'll care about the form only when handling the first 7 columns of
-text, stuff like spaces between strings of alphanumerics, and
-how lines are continued.
-
-Some other distinctions will be handled by subsequent phases,
-so at least one of them will have to know which form is involved.
-
-For example, @samp{I = 2 . 4} is acceptable in fixed form,
-and works in free form as well given the implementation @code{g77}
-presently uses.
-But the standard requires a diagnostic for it in free form,
-so the parser has to be able to recognize that
-the lexemes aren't contiguous
-(information the lexer @emph{does} have to provide)
-and that free-form source is being parsed,
-so it can provide the diagnostic.
-
-The @code{g77} lexer doesn't try to gather @samp{2 . 4} into a single lexeme.
-Otherwise, it'd have to know a whole lot more about how to parse Fortran,
-or subsequent phases (mainly parsing) would have two paths through
-lots of critical code---one to handle the lexeme @samp{2}, @samp{.},
-and @samp{4} in sequence, another to handle the lexeme @samp{2.4}.
-
-@item
-It won't worry about line lengths
-(beyond the first 7 columns for fixed-form source).
-
-That is, once it starts parsing the ``statement'' part of a line
-(column 7 for fixed-form, column 1 for free-form),
-it'll keep going until it finds a newline,
-rather than ignoring everything past a particular column
-(72 or 132).
-
-The implication here is that there shouldn't @emph{be}
-anything past that last column, other than whitespace or
-commentary, because users using typical editors
-(or viewing output as typically printed)
-won't necessarily know just where the last column is.
-
-Code that has ``garbage'' beyond the last column
-(almost certainly only fixed-form code with a punched-card legacy,
-such as code using columns 73-80 for ``sequence numbers'')
-will have to be run through @code{g77stripcard} first.
-
-Also, keeping track of the maximum column position while also watching out
-for the end of a line @emph{and} while reading from a file
-just makes things slower.
-Since a file must be read, and watching for the end of the line
-is necessary (unless the typical input file was preprocessed to
-include the necessary number of trailing spaces),
-dropping the tracking of the maximum column position
-is the only way to reduce the complexity of the pertinent code
-while maintaining high performance.
-
-@item
-ASCII encoding is assumed for the input file.
-
-Code written in other character sets will have to be converted first.
-
-@item
-Tabs (ASCII code 9)
-will be converted to spaces via the straightforward
-approach.
-
-Specifically, a tab is converted to between one and eight spaces
-as necessary to reach column @var{n},
-where dividing @samp{(@var{n} - 1)} by eight
-results in a remainder of zero.
-
-That saves having to pass most source files through @code{expand}.
-
-@item
-Linefeeds (ASCII code 10)
-mark the ends of lines.
-
-@item
-A carriage return (ASCII code 13)
-is accept if it immediately precedes a linefeed,
-in which case it is ignored.
-
-Otherwise, it is rejected (with a diagnostic).
-
-@item
-Any other characters other than the above
-that are not part of the GNU Fortran Character Set
-(@pxref{Character Set})
-are rejected with a diagnostic.
-
-This includes backspaces, form feeds, and the like.
-
-(It might make sense to allow a form feed in column 1
-as long as that's the only character on a line.
-It certainly wouldn't seem to cost much in terms of performance.)
-
-@item
-The end of the input stream (EOF)
-ends the current line.
-
-@item
-The distinction between uppercase and lowercase letters
-will be preserved.
-
-It will be up to subsequent phases to decide to fold case.
-
-Current plans are to permit any casing for Fortran (reserved) keywords
-while preserving casing for user-defined names.
-(This might not be made the default for @file{.f} files, though.)
-
-Preserving case seems necessary to provide more direct access
-to facilities outside of @code{g77}, such as to C or Pascal code.
-
-Names of intrinsics will probably be matchable in any case,
-
-(How @samp{external SiN; r = sin(x)} would be handled is TBD.
-I think old @code{g77} might already handle that pretty elegantly,
-but whether we can cope with allowing the same fragment to reference
-a @emph{different} procedure, even with the same interface,
-via @samp{s = SiN(r)}, needs to be determined.
-If it can't, we need to make sure that when code introduces
-a user-defined name, any intrinsic matching that name
-using a case-insensitive comparison
-is ``turned off''.)
-
-@item
-Backslashes in @code{CHARACTER} and Hollerith constants
-are not allowed.
-
-This avoids the confusion introduced by some Fortran compiler vendors
-providing C-like interpretation of backslashes,
-while others provide straight-through interpretation.
-
-Some kind of lexical construct (TBD) will be provided to allow
-flagging of a @code{CHARACTER}
-(but probably not a Hollerith)
-constant that permits backslashes.
-It'll necessarily be a prefix, such as:
-
-@smallexample
-PRINT *, C'This line has a backspace \b here.'
-PRINT *, F'This line has a straight backslash \ here.'
-@end smallexample
-
-Further, command-line options might be provided to specify that
-one prefix or the other is to be assumed as the default
-for @code{CHARACTER} constants.
-
-However, it seems more helpful for @code{g77} to provide a program
-that converts prefix all constants
-(or just those containing backslashes)
-with the desired designation,
-so printouts of code can be read
-without knowing the compile-time options used when compiling it.
-
-If such a program is provided
-(let's name it @code{g77slash} for now),
-then a command-line option to @code{g77} should not be provided.
-(Though, given that it'll be easy to implement, it might be hard
-to resist user requests for it ``to compile faster than if we
-have to invoke another filter''.)
-
-This program would take a command-line option to specify the
-default interpretation of slashes,
-affecting which prefix it uses for constants.
-
-@code{g77slash} probably should automatically convert Hollerith
-constants that contain slashes
-to the appropriate @code{CHARACTER} constants.
-Then @code{g77} wouldn't have to define a prefix syntax for Hollerith
-constants specifying whether they want C-style or straight-through
-backslashes.
-
-@item
-To allow for form-neutral INCLUDE files without requiring them
-to be preprocessed,
-the fixed-form lexer should offer an extension (if possible)
-allowing a trailing @samp{&} to be ignored, especially if after
-column 72, as it would be using the traditional Unix Fortran source
-model (which ignores @emph{everything} after column 72).
-@end itemize
-
-The above implements nearly exactly what is specified by
-@ref{Character Set},
-and
-@ref{Lines},
-except it also provides automatic conversion of tabs
-and ignoring of newline-related carriage returns,
-as well as accommodating form-neutral INCLUDE files.
-
-It also implements the ``pure visual'' model,
-by which is meant that a user viewing his code
-in a typical text editor
-(assuming it's not preprocessed via @code{g77stripcard} or similar)
-doesn't need any special knowledge
-of whether spaces on the screen are really tabs,
-whether lines end immediately after the last visible non-space character
-or after a number of spaces and tabs that follow it,
-or whether the last line in the file is ended by a newline.
-
-Most editors don't make these distinctions,
-the ANSI FORTRAN 77 standard doesn't require them to,
-and it permits a standard-conforming compiler
-to define a method for transforming source code to
-``standard form'' however it wants.
-
-So, GNU Fortran defines it such that users have the best chance
-of having the code be interpreted the way it looks on the screen
-of the typical editor.
-
-(Fancy editors should @emph{never} be required to correctly read code
-written in classic two-dimensional-plaintext form.
-By correct reading I mean ability to read it, book-like, without
-mistaking text ignored by the compiler for program code and vice versa,
-and without having to count beyond the first several columns.
-The vague meaning of ASCII TAB, among other things, complicates
-this somewhat, but as long as ``everyone'', including the editor,
-other tools, and printer, agrees about the every-eighth-column convention,
-the GNU Fortran ``pure visual'' model meets these requirements.
-Any language or user-visible source form
-requiring special tagging of tabs,
-the ends of lines after spaces/tabs,
-and so on, fails to meet this fairly straightforward specification.
-Fortunately, Fortran @emph{itself} does not mandate such a failure,
-though most vendor-supplied defaults for their Fortran compilers @emph{do}
-fail to meet this specification for readability.)
-
-Further, this model provides a clean interface
-to whatever preprocessors or code-generators are used
-to produce input to this phase of @code{g77}.
-Mainly, they need not worry about long lines.
-
-@node sta.c
-@subsection sta.c
-
-@node sti.c
-@subsection sti.c
-
-@node stq.c
-@subsection stq.c
-
-@node stb.c
-@subsection stb.c
-
-@node expr.c
-@subsection expr.c
-
-@node stc.c
-@subsection stc.c
-
-@node std.c
-@subsection std.c
-
-@node ste.c
-@subsection ste.c
-
-@node Gotchas (Transforming)
-@subsection Gotchas (Transforming)
-
-This section is not about transforming ``gotchas'' into something else.
-It is about the weirder aspects of transforming Fortran,
-however that's defined,
-into a more modern, canonical form.
-
-@subsubsection Multi-character Lexemes
-
-Each lexeme carries with it a pointer to where it appears in the source.
-
-To provide the ability for diagnostics to point to column numbers,
-in addition to line numbers and names,
-lexemes that represent more than one (significant) character
-in the source code need, generally,
-to provide pointers to where each @emph{character} appears in the source.
-
-This provides the ability to properly identify the precise location
-of the problem in code like
-
-@smallexample
-SUBROUTINE X
-END
-BLOCK DATA X
-END
-@end smallexample
-
-which, in fixed-form source, would result in single lexemes
-consisting of the strings @samp{SUBROUTINEX} and @samp{BLOCKDATAX}.
-(The problem is that @samp{X} is defined twice,
-so a pointer to the @samp{X} in the second definition,
-as well as a follow-up pointer to the corresponding pointer in the first,
-would be preferable to pointing to the beginnings of the statements.)
-
-This need also arises when parsing (and diagnosing) @code{FORMAT}
-statements.
-
-Further, it arises when diagnosing
-@code{FMT=} specifiers that contain constants
-(or partial constants, or even propagated constants!)
-in I/O statements, as in:
-
-@smallexample
-PRINT '(I2, 3HAB)', J
-@end smallexample
-
-(A pointer to the beginning of the prematurely-terminated Hollerith
-constant, and/or to the close parenthese, is preferable to a pointer
-to the open-parenthese or the apostrophe that precedes it.)
-
-Multi-character lexemes, which would seem to naturally include
-at least digit strings, alphanumeric strings, @code{CHARACTER}
-constants, and Hollerith constants, therefore need to provide
-location information on each character.
-(Maybe Hollerith constants don't, but it's unnecessary to except them.)
-
-The question then arises, what about @emph{other} multi-character lexemes,
-such as @samp{**} and @samp{//},
-and Fortran 90's @samp{(/}, @samp{/)}, @samp{::}, and so on?
-
-Turns out there's a need to identify the location of the second character
-of these two-character lexemes.
-For example, in @samp{I(/J) = K}, the slash needs to be diagnosed
-as the problem, not the open parenthese.
-Similarly, it is preferable to diagnose the second slash in
-@samp{I = J // K} rather than the first, given the implicit typing
-rules, which would result in the compiler disallowing the attempted
-concatenation of two integers.
-(Though, since that's more of a semantic issue,
-it's not @emph{that} much preferable.)
-
-Even sequences that could be parsed as digit strings could use location info,
-for example, to diagnose the @samp{9} in the octal constant @samp{O'129'}.
-(This probably will be parsed as a character string,
-to be consistent with the parsing of @samp{Z'129A'}.)
-
-To avoid the hassle of recording the location of the second character,
-while also preserving the general rule that each significant character
-is distinctly pointed to by the lexeme that contains it,
-it's best to simply not have any fixed-size lexemes
-larger than one character.
-
-This new design is expected to make checking for two
-@samp{*} lexemes in a row much easier than the old design,
-so this is not much of a sacrifice.
-It probably makes the lexer much easier to implement
-than it makes the parser harder.
-
-@subsubsection Space-padding Lexemes
-
-Certain lexemes need to be padded with virtual spaces when the
-end of the line (or file) is encountered.
-
-This is necessary in fixed form, to handle lines that don't
-extend to column 72, assuming that's the line length in effect.
-
-@subsubsection Bizarre Free-form Hollerith Constants
-
-Last I checked, the Fortran 90 standard actually required the compiler
-to silently accept something like
-
-@smallexample
-FORMAT ( 1 2 Htwelve chars )
-@end smallexample
-
-as a valid @code{FORMAT} statement specifying a twelve-character
-Hollerith constant.
-
-The implication here is that, since the new lexer is a zero-feedback one,
-it won't know that the special case of a @code{FORMAT} statement being parsed
-requires apparently distinct lexemes @samp{1} and @samp{2} to be treated as
-a single lexeme.
-
-(This is a horrible misfeature of the Fortran 90 language.
-It's one of many such misfeatures that almost make me want
-to not support them, and forge ahead with designing a new
-``GNU Fortran'' language that has the features,
-but not the misfeatures, of Fortran 90,
-and provide utility programs to do the conversion automatically.)
-
-So, the lexer must gather distinct chunks of decimal strings into
-a single lexeme in contexts where a single decimal lexeme might
-start a Hollerith constant.
-
-(Which probably means it might as well do that all the time
-for all multi-character lexemes, even in free-form mode,
-leaving it to subsequent phases to pull them apart as they see fit.)
-
-Compare the treatment of this to how
-
-@smallexample
-CHARACTER * 4 5 HEY
-@end smallexample
-
-and
-
-@smallexample
-CHARACTER * 12 HEY
-@end smallexample
-
-must be treated---the former must be diagnosed, due to the separation
-between lexemes, the latter must be accepted as a proper declaration.
-
-@subsubsection Hollerith Constants
-
-Recognizing a Hollerith constant---specifically,
-that an @samp{H} or @samp{h} after a digit string begins
-such a constant---requires some knowledge of context.
-
-Hollerith constants (such as @samp{2HAB}) can appear after:
-
-@itemize @bullet
-@item
-@samp{(}
-
-@item
-@samp{,}
-
-@item
-@samp{=}
-
-@item
-@samp{+}, @samp{-}, @samp{/}
-
-@item
-@samp{*}, except as noted below
-@end itemize
-
-Hollerith constants don't appear after:
-
-@itemize @bullet
-@item
-@samp{CHARACTER*},
-which can be treated generally as
-any @samp{*} that is the second lexeme of a statement
-@end itemize
-
-@subsubsection Confusing Function Keyword
-
-While
-
-@smallexample
-REAL FUNCTION FOO ()
-@end smallexample
-
-must be a @code{FUNCTION} statement and
-
-@smallexample
-REAL FUNCTION FOO (5)
-@end smallexample
-
-must be a type-definition statement,
-
-@smallexample
-REAL FUNCTION FOO (@var{names})
-@end smallexample
-
-where @var{names} is a comma-separated list of names,
-can be one or the other.
-
-The only way to disambiguate that statement
-(short of mandating free-form source or a short maximum
-length for name for external procedures)
-is based on the context of the statement.
-
-In particular, the statement is known to be within an
-already-started program unit
-(but not at the outer level of the @code{CONTAINS} block),
-it is a type-declaration statement.
-
-Otherwise, the statement is a @code{FUNCTION} statement,
-in that it begins a function program unit
-(external, or, within @code{CONTAINS}, nested).
-
-@subsubsection Weird READ
-
-The statement
-
-@smallexample
-READ (N)
-@end smallexample
-
-is equivalent to either
-
-@smallexample
-READ (UNIT=(N))
-@end smallexample
-
-or
-
-@smallexample
-READ (FMT=(N))
-@end smallexample
-
-depending on which would be valid in context.
-
-Specifically, if @samp{N} is type @code{INTEGER},
-@samp{READ (FMT=(N))} would not be valid,
-because parentheses may not be used around @samp{N},
-whereas they may around it in @samp{READ (UNIT=(N))}.
-
-Further, if @samp{N} is type @code{CHARACTER},
-the opposite is true---@samp{READ (UNIT=(N))} is not valid,
-but @samp{READ (FMT=(N))} is.
-
-Strictly speaking, if anything follows
-
-@smallexample
-READ (N)
-@end smallexample
-
-in the statement, whether the first lexeme after the close
-parenthese is a comma could be used to disambiguate the two cases,
-without looking at the type of @samp{N},
-because the comma is required for the @samp{READ (FMT=(N))}
-interpretation and disallowed for the @samp{READ (UNIT=(N))}
-interpretation.
-
-However, in practice, many Fortran compilers allow
-the comma for the @samp{READ (UNIT=(N))}
-interpretation anyway
-(in that they generally allow a leading comma before
-an I/O list in an I/O statement),
-and much code takes advantage of this allowance.
-
-(This is quite a reasonable allowance, since the
-juxtaposition of a comma-separated list immediately
-after an I/O control-specification list, which is also comma-separated,
-without an intervening comma,
-looks sufficiently ``wrong'' to programmers
-that they can't resist the itch to insert the comma.
-@samp{READ (I, J), K, L} simply looks cleaner than
-@samp{READ (I, J) K, L}.)
-
-So, type-based disambiguation is needed unless strict adherence
-to the standard is always assumed, and we're not going to assume that.
-
-@node TBD (Transforming)
-@subsection TBD (Transforming)
-
-Continue researching gotchas, designing the transformational process,
-and implementing it.
-
-Specific issues to resolve:
-
-@itemize @bullet
-@item
-Just where should (if it was implemented) @code{USE} processing take place?
-
-This gets into the whole issue of how @code{g77} should handle the concept
-of modules.
-I think GNAT already takes on this issue, but don't know more than that.
-Jim Giles has written extensively on @code{comp.lang.fortran}
-about his opinions on module handling, as have others.
-Jim's views should be taken into account.
-
-Actually, Richard M. Stallman (RMS) also has written up
-some guidelines for implementing such things,
-but I'm not sure where I read them.
-Perhaps the old @email{gcc2@@cygnus.com} list.
-
-If someone could dig references to these up and get them to me,
-that would be much appreciated!
-Even though modules are not on the short-term list for implementation,
-it'd be helpful to know @emph{now} how to avoid making them harder to
-implement them @emph{later}.
-
-@item
-Should the @code{g77} command become just a script that invokes
-all the various preprocessing that might be needed,
-thus making it seem slower than necessary for legacy code
-that people are unwilling to convert,
-or should we provide a separate script for that,
-thus encouraging people to convert their code once and for all?
-
-At least, a separate script to behave as old @code{g77} did,
-perhaps named @code{g77old}, might ease the transition,
-as might a corresponding one that converts source codes
-named @code{g77oldnew}.
-
-These scripts would take all the pertinent options @code{g77} used
-to take and run the appropriate filters,
-passing the results to @code{g77} or just making new sources out of them
-(in a subdirectory, leaving the user to do the dirty deed of
-moving or copying them over the old sources).
-
-@item
-Do other Fortran compilers provide a prefix syntax
-to govern the treatment of backslashes in @code{CHARACTER}
-(or Hollerith) constants?
-
-Knowing what other compilers provide would help.
-
-@item
-Is it okay to drop support for the @samp{-fintrin-case-initcap},
-@samp{-fmatch-case-initcap}, @samp{-fsymbol-case-initcap},
-and @samp{-fcase-initcap} options?
-
-I've asked @email{info-gnu-fortran@@gnu.org} for input on this.
-Not having to support these makes it easier to write the new front end,
-and might also avoid complicated its design.
-
-The consensus to date (1999-11-17) has been to drop this support.
-Can't recall anybody saying they're using it, in fact.
-@end itemize
-
-@node Philosophy of Code Generation
-@section Philosophy of Code Generation
-
-Don't poke the bear.
-
-The @code{g77} front end generates code
-via the @code{gcc} back end.
-
-@cindex GNU Back End (GBE)
-@cindex GBE
-@cindex @code{gcc}, back end
-@cindex back end, gcc
-@cindex code generator
-The @code{gcc} back end (GBE) is a large, complex
-labyrinth of intricate code
-written in a combination of the C language
-and specialized languages internal to @code{gcc}.
-
-While the @emph{code} that implements the GBE
-is written in a combination of languages,
-the GBE itself is,
-to the front end for a language like Fortran,
-best viewed as a @emph{compiler}
-that compiles its own, unique, language.
-
-The GBE's ``source'', then, is written in this language,
-which consists primarily of
-a combination of calls to GBE functions
-and @dfn{tree} nodes
-(which are, themselves, created
-by calling GBE functions).
-
-So, the @code{g77} generates code by, in effect,
-translating the Fortran code it reads
-into a form ``written'' in the ``language''
-of the @code{gcc} back end.
-
-@cindex GBEL
-@cindex GNU Back End Language (GBEL)
-This language will heretofore be referred to as @dfn{GBEL},
-for GNU Back End Language.
-
-GBEL is an evolving language,
-not fully specified in any published form
-as of this writing.
-It offers many facilities,
-but its ``core'' facilities
-are those that corresponding most directly
-to those needed to support @code{gcc}
-(compiling code written in GNU C).
-
-The @code{g77} Fortran Front End (FFE)
-is designed and implemented
-to navigate the currents and eddies
-of ongoing GBEL and @code{gcc} development
-while also delivering on the potential
-of an integrated FFE
-(as compared to using a converter like @code{f2c}
-and feeding the output into @code{gcc}).
-
-Goals of the FFE's code-generation strategy include:
-
-@itemize @bullet
-@item
-High likelihood of generation of correct code,
-or, failing that, producing a fatal diagnostic or crashing.
-
-@item
-Generation of highly optimized code,
-as directed by the user
-via GBE-specific (versus @code{g77}-specific) constructs,
-such as command-line options.
-
-@item
-Fast overall (FFE plus GBE) compilation.
-
-@item
-Preservation of source-level debugging information.
-@end itemize
-
-The strategies historically, and currently, used by the FFE
-to achieve these goals include:
-
-@itemize @bullet
-@item
-Use of GBEL constructs that most faithfully encapsulate
-the semantics of Fortran.
-
-@item
-Avoidance of GBEL constructs that are so rarely used,
-or limited to use in specialized situations not related to Fortran,
-that their reliability and performance has not yet been established
-as sufficient for use by the FFE.
-
-@item
-Flexible design, to readily accommodate changes to specific
-code-generation strategies, perhaps governed by command-line options.
-@end itemize
-
-@cindex Bear-poking
-@cindex Poking the bear
-``Don't poke the bear'' somewhat summarizes the above strategies.
-The GBE is the bear.
-The FFE is designed and implemented to avoid poking it
-in ways that are likely to just annoy it.
-The FFE usually either tackles it head-on,
-or avoids treating it in ways dissimilar to how
-the @code{gcc} front end treats it.
-
-For example, the FFE uses the native array facility in the back end
-instead of the lower-level pointer-arithmetic facility
-used by @code{gcc} when compiling @code{f2c} output).
-Theoretically, this presents more opportunities for optimization,
-faster compile times,
-and the production of more faithful debugging information.
-These benefits were not, however, immediately realized,
-mainly because @code{gcc} itself makes little or no use
-of the native array facility.
-
-Complex arithmetic is a case study of the evolution of this strategy.
-When originally implemented,
-the GBEL had just evolved its own native complex-arithmetic facility,
-so the FFE took advantage of that.
-
-When porting @code{g77} to 64-bit systems,
-it was discovered that the GBE didn't really
-implement its native complex-arithmetic facility properly.
-
-The short-term solution was to rewrite the FFE
-to instead use the lower-level facilities
-that'd be used by @code{gcc}-compiled code
-(assuming that code, itself, didn't use the native complex type
-provided, as an extension, by @code{gcc}),
-since these were known to work,
-and, in any case, if shown to not work,
-would likely be rapidly fixed
-(since they'd likely not work for vanilla C code in similar circumstances).
-
-However, the rewrite accommodated the original, native approach as well
-by offering a command-line option to select it over the emulated approach.
-This allowed users, and especially GBE maintainers, to try out
-fixes to complex-arithmetic support in the GBE
-while @code{g77} continued to default to compiling more code correctly,
-albeit producing (typically) slower executables.
-
-As of April 1999, it appeared that the last few bugs
-in the GBE's support of its native complex-arithmetic facility
-were worked out.
-The FFE was changed back to default to using that native facility,
-leaving emulation as an option.
-
-Later during the release cycle
-(which was called EGCS 1.2, but soon became GCC 2.95),
-bugs in the native facility were found.
-Reactions among various people included
-``the last thing we should do is change the default back'',
-``we must change the default back'',
-and ``let's figure out whether we can narrow down the bugs to
-few enough cases to allow the now-months-long-tested default
-to remain the same''.
-The latter viewpoint won that particular time.
-The bugs exposed other concerns regarding ABI compliance
-when the ABI specified treatment of complex data as different
-from treatment of what Fortran and GNU C consider the equivalent
-aggregation (structure) of real (or float) pairs.
-
-Other Fortran constructs---arrays, character strings,
-complex division, @code{COMMON} and @code{EQUIVALENCE} aggregates,
-and so on---involve issues similar to those pertaining to complex arithmetic.
-
-So, it is possible that the history
-of how the FFE handled complex arithmetic
-will be repeated, probably in modified form
-(and hopefully over shorter timeframes),
-for some of these other facilities.
-
-@node Two-pass Design
-@section Two-pass Design
-
-The FFE does not tell the GBE anything about a program unit
-until after the last statement in that unit has been parsed.
-(A program unit is a Fortran concept that corresponds, in the C world,
-mostly closely to functions definitions in ISO C.
-That is, a program unit in Fortran is like a top-level function in C.
-Nested functions, found among the extensions offered by GNU C,
-correspond roughly to Fortran's statement functions.)
-
-So, while parsing the code in a program unit,
-the FFE saves up all the information
-on statements, expressions, names, and so on,
-until it has seen the last statement.
-
-At that point, the FFE revisits the saved information
-(in what amounts to a second @dfn{pass} over the program unit)
-to perform the actual translation of the program unit into GBEL,
-ultimating in the generation of assembly code for it.
-
-Some lookahead is performed during this second pass,
-so the FFE could be viewed as a ``two-plus-pass'' design.
-
-@menu
-* Two-pass Code::
-* Why Two Passes::
-@end menu
-
-@node Two-pass Code
-@subsection Two-pass Code
-
-Most of the code that turns the first pass (parsing)
-into a second pass for code generation
-is in @file{@value{path-g77}/std.c}.
-
-It has external functions,
-called mainly by siblings in @file{@value{path-g77}/stc.c},
-that record the information on statements and expressions
-in the order they are seen in the source code.
-These functions save that information.
-
-It also has an external function that revisits that information,
-calling the siblings in @file{@value{path-g77}/ste.c},
-which handles the actual code generation
-(by generating GBEL code,
-that is, by calling GBE routines
-to represent and specify expressions, statements, and so on).
-
-@node Why Two Passes
-@subsection Why Two Passes
-
-The need for two passes was not immediately evident
-during the design and implementation of the code in the FFE
-that was to produce GBEL.
-Only after a few kludges,
-to handle things like incorrectly-guessed @code{ASSIGN} label nature,
-had been implemented,
-did enough evidence pile up to make it clear
-that @file{std.c} had to be introduced to intercept,
-save, then revisit as part of a second pass,
-the digested contents of a program unit.
-
-Other such missteps have occurred during the evolution of the FFE,
-because of the different goals of the FFE and the GBE.
-
-Because the GBE's original, and still primary, goal
-was to directly support the GNU C language,
-the GBEL, and the GBE itself,
-requires more complexity
-on the part of most front ends
-than it requires of @code{gcc}'s.
-
-For example,
-the GBEL offers an interface that permits the @code{gcc} front end
-to implement most, or all, of the language features it supports,
-without the front end having to
-make use of non-user-defined variables.
-(It's almost certainly the case that all of K&R C,
-and probably ANSI C as well,
-is handled by the @code{gcc} front end
-without declaring such variables.)
-
-The FFE, on the other hand, must resort to a variety of ``tricks''
-to achieve its goals.
-
-Consider the following C code:
-
-@smallexample
-int
-foo (int a, int b)
-@{
- int c = 0;
-
- if ((c = bar (c)) == 0)
- goto done;
-
- quux (c << 1);
-
-done:
- return c;
-@}
-@end smallexample
-
-Note what kinds of objects are declared, or defined, before their use,
-and before any actual code generation involving them
-would normally take place:
-
-@itemize @bullet
-@item
-Return type of function
-
-@item
-Entry point(s) of function
-
-@item
-Dummy arguments
-
-@item
-Variables
-
-@item
-Initial values for variables
-@end itemize
-
-Whereas, the following items can, and do,
-suddenly appear ``out of the blue'' in C:
-
-@itemize @bullet
-@item
-Label references
-
-@item
-Function references
-@end itemize
-
-Not surprisingly, the GBE faithfully permits the latter set of items
-to be ``discovered'' partway through GBEL ``programs'',
-just as they are permitted to in C.
-
-Yet, the GBE has tended, at least in the past,
-to be reticent to fully support similar ``late'' discovery
-of items in the former set.
-
-This makes Fortran a poor fit for the ``safe'' subset of GBEL.
-Consider:
-
-@smallexample
- FUNCTION X (A, ARRAY, ID1)
- CHARACTER*(*) A
- DOUBLE PRECISION X, Y, Z, TMP, EE, PI
- REAL ARRAY(ID1*ID2)
- COMMON ID2
- EXTERNAL FRED
-
- ASSIGN 100 TO J
- CALL FOO (I)
- IF (I .EQ. 0) PRINT *, A(0)
- GOTO 200
-
- ENTRY Y (Z)
- ASSIGN 101 TO J
-200 PRINT *, A(1)
- READ *, TMP
- GOTO J
-100 X = TMP * EE
- RETURN
-101 Y = TMP * PI
- CALL FRED
- DATA EE, PI /2.71D0, 3.14D0/
- END
-@end smallexample
-
-Here are some observations about the above code,
-which, while somewhat contrived,
-conforms to the FORTRAN 77 and Fortran 90 standards:
-
-@itemize @bullet
-@item
-The return type of function @samp{X} is not known
-until the @samp{DOUBLE PRECISION} line has been parsed.
-
-@item
-Whether @samp{A} is a function or a variable
-is not known until the @samp{PRINT *, A(0)} statement
-has been parsed.
-
-@item
-The bounds of the array of argument @samp{ARRAY}
-depend on a computation involving
-the subsequent argument @samp{ID1}
-and the blank-common member @samp{ID2}.
-
-@item
-Whether @samp{Y} and @samp{Z} are local variables,
-additional function entry points,
-or dummy arguments to additional entry points
-is not known
-until the @code{ENTRY} statement is parsed.
-
-@item
-Similarly, whether @samp{TMP} is a local variable is not known
-until the @samp{READ *, TMP} statement is parsed.
-
-@item
-The initial values for @samp{EE} and @samp{PI}
-are not known until after the @code{DATA} statement is parsed.
-
-@item
-Whether @samp{FRED} is a function returning type @code{REAL}
-or a subroutine
-(which can be thought of as returning type @code{void}
-@emph{or}, to support alternate returns in a simple way,
-type @code{int})
-is not known
-until the @samp{CALL FRED} statement is parsed.
-
-@item
-Whether @samp{100} is a @code{FORMAT} label
-or the label of an executable statement
-is not known
-until the @samp{X =} statement is parsed.
-(These two types of labels get @emph{very} different treatment,
-especially when @code{ASSIGN}'ed.)
-
-@item
-That @samp{J} is a local variable is not known
-until the first @code{ASSIGN} statement is parsed.
-(This happens @emph{after} executable code has been seen.)
-@end itemize
-
-Very few of these ``discoveries''
-can be accommodated by the GBE as it has evolved over the years.
-The GBEL doesn't support several of them,
-and those it might appear to support
-don't always work properly,
-especially in combination with other GBEL and GBE features,
-as implemented in the GBE.
-
-(Had the GBE and its GBEL originally evolved to support @code{g77},
-the shoe would be on the other foot, so to speak---most, if not all,
-of the above would be directly supported by the GBEL,
-and a few C constructs would probably not, as they are in reality,
-be supported.
-Both this mythical, and today's real, GBE caters to its GBEL
-by, sometimes, scrambling around, cleaning up after itself---after
-discovering that assumptions it made earlier during code generation
-are incorrect.
-That's not a great design, since it indicates significant code
-paths that might be rarely tested but used in some key production
-environments.)
-
-So, the FFE handles these discrepancies---between the order in which
-it discovers facts about the code it is compiling,
-and the order in which the GBEL and GBE support such discoveries---by
-performing what amounts to two
-passes over each program unit.
-
-(A few ambiguities can remain at that point,
-such as whether, given @samp{EXTERNAL BAZ}
-and no other reference to @samp{BAZ} in the program unit,
-it is a subroutine, a function, or a block-data---which, in C-speak,
-governs its declared return type.
-Fortunately, these distinctions are easily finessed
-for the procedure, library, and object-file interfaces
-supported by @code{g77}.)
-
-@node Challenges Posed
-@section Challenges Posed
-
-Consider the following Fortran code, which uses various extensions
-(including some to Fortran 90):
-
-@smallexample
-SUBROUTINE X(A)
-CHARACTER*(*) A
-COMPLEX CFUNC
-INTEGER*2 CLOCKS(200)
-INTEGER IFUNC
-
-CALL SYSTEM_CLOCK (CLOCKS (IFUNC (CFUNC ('('//A//')'))))
-@end smallexample
-
-The above poses the following challenges to any Fortran compiler
-that uses run-time interfaces, and a run-time library, roughly similar
-to those used by @code{g77}:
-
-@itemize @bullet
-@item
-Assuming the library routine that supports @code{SYSTEM_CLOCK}
-expects to set an @code{INTEGER*4} variable via its @code{COUNT} argument,
-the compiler must make available to it a temporary variable of that type.
-
-@item
-Further, after the @code{SYSTEM_CLOCK} library routine returns,
-the compiler must ensure that the temporary variable it wrote
-is copied into the appropriate element of the @samp{CLOCKS} array.
-(This assumes the compiler doesn't just reject the code,
-which it should if it is compiling under some kind of a ``strict'' option.)
-
-@item
-To determine the correct index into the @samp{CLOCKS} array,
-(putting aside the fact that the index, in this particular case,
-need not be computed until after
-the @code{SYSTEM_CLOCK} library routine returns),
-the compiler must ensure that the @code{IFUNC} function is called.
-
-That requires evaluating its argument,
-which requires, for @code{g77}
-(assuming @code{-ff2c} is in force),
-reserving a temporary variable of type @code{COMPLEX}
-for use as a repository for the return value
-being computed by @samp{CFUNC}.
-
-@item
-Before invoking @samp{CFUNC},
-is argument must be evaluated,
-which requires allocating, at run time,
-a temporary large enough to hold the result of the concatenation,
-as well as actually performing the concatenation.
-
-@item
-The large temporary needed during invocation of @code{CFUNC}
-should, ideally, be deallocated
-(or, at least, left to the GBE to dispose of, as it sees fit)
-as soon as @code{CFUNC} returns,
-which means before @code{IFUNC} is called
-(as it might need a lot of dynamically allocated memory).
-@end itemize
-
-@code{g77} currently doesn't support all of the above,
-but, so that it might someday, it has evolved to handle
-at least some of the above requirements.
-
-Meeting the above requirements is made more challenging
-by conforming to the requirements of the GBEL/GBE combination.
-
-@node Transforming Statements
-@section Transforming Statements
-
-Most Fortran statements are given their own block,
-and, for temporary variables they might need, their own scope.
-(A block is what distinguishes @samp{@{ foo (); @}}
-from just @samp{foo ();} in C.
-A scope is included with every such block,
-providing a distinct name space for local variables.)
-
-Label definitions for the statement precede this block,
-so @samp{10 PRINT *, I} is handled more like
-@samp{fl10: @{ @dots{} @}} than @samp{@{ fl10: @dots{} @}}
-(where @samp{fl10} is just a notation meaning ``Fortran Label 10''
-for the purposes of this document).
-
-@menu
-* Statements Needing Temporaries::
-* Transforming DO WHILE::
-* Transforming Iterative DO::
-* Transforming Block IF::
-* Transforming SELECT CASE::
-@end menu
-
-@node Statements Needing Temporaries
-@subsection Statements Needing Temporaries
-
-Any temporaries needed during, but not beyond,
-execution of a Fortran statement,
-are made local to the scope of that statement's block.
-
-This allows the GBE to share storage for these temporaries
-among the various statements without the FFE
-having to manage that itself.
-
-(The GBE could, of course, decide to optimize
-management of these temporaries.
-For example, it could, theoretically,
-schedule some of the computations involving these temporaries
-to occur in parallel.
-More practically, it might leave the storage for some temporaries
-``live'' beyond their scopes, to reduce the number of
-manipulations of the stack pointer at run time.)
-
-Temporaries needed across distinct statement boundaries usually
-are associated with Fortran blocks (such as @code{DO}/@code{END DO}).
-(Also, there might be temporaries not associated with blocks at all---these
-would be in the scope of the entire program unit.)
-
-Each Fortran block @emph{should} get its own block/scope in the GBE.
-This is best, because it allows temporaries to be more naturally handled.
-However, it might pose problems when handling labels
-(in particular, when they're the targets of @code{GOTO}s outside the Fortran
-block), and generally just hassling with replicating
-parts of the @code{gcc} front end
-(because the FFE needs to support
-an arbitrary number of nested back-end blocks
-if each Fortran block gets one).
-
-So, there might still be a need for top-level temporaries, whose
-``owning'' scope is that of the containing procedure.
-
-Also, there seems to be problems declaring new variables after
-generating code (within a block) in the back end, leading to, e.g.,
-@samp{label not defined before binding contour} or similar messages,
-when compiling with @samp{-fstack-check} or
-when compiling for certain targets.
-
-Because of that, and because sometimes these temporaries are not
-discovered until in the middle of of generating code for an expression
-statement (as in the case of the optimization for @samp{X**I}),
-it seems best to always
-pre-scan all the expressions that'll be expanded for a block
-before generating any of the code for that block.
-
-This pre-scan then handles discovering and declaring, to the back end,
-the temporaries needed for that block.
-
-It's also important to treat distinct items in an I/O list as distinct
-statements deserving their own blocks.
-That's because there's a requirement
-that each I/O item be fully processed before the next one,
-which matters in cases like @samp{READ (*,*), I, A(I)}---the
-element of @samp{A} read in the second item
-@emph{must} be determined from the value
-of @samp{I} read in the first item.
-
-@node Transforming DO WHILE
-@subsection Transforming DO WHILE
-
-@samp{DO WHILE(expr)} @emph{must} be implemented
-so that temporaries needed to evaluate @samp{expr}
-are generated just for the test, each time.
-
-Consider how @samp{DO WHILE (A//B .NE. 'END'); @dots{}; END DO} is transformed:
-
-@smallexample
-for (;;)
- @{
- int temp0;
-
- @{
- char temp1[large];
-
- libg77_catenate (temp1, a, b);
- temp0 = libg77_ne (temp1, 'END');
- @}
-
- if (! temp0)
- break;
-
- @dots{}
- @}
-@end smallexample
-
-In this case, it seems like a time/space tradeoff
-between allocating and deallocating @samp{temp1} for each iteration
-and allocating it just once for the entire loop.
-
-However, if @samp{temp1} is allocated just once for the entire loop,
-it could be the wrong size for subsequent iterations of that loop
-in cases like @samp{DO WHILE (A(I:J)//B .NE. 'END')},
-because the body of the loop might modify @samp{I} or @samp{J}.
-
-So, the above implementation is used,
-though a more optimal one can be used
-in specific circumstances.
-
-@node Transforming Iterative DO
-@subsection Transforming Iterative DO
-
-An iterative @code{DO} loop
-(one that specifies an iteration variable)
-is required by the Fortran standards
-to be implemented as though an iteration count
-is computed before entering the loop body,
-and that iteration count used to determine
-the number of times the loop body is to be performed
-(assuming the loop isn't cut short via @code{GOTO} or @code{EXIT}).
-
-The FFE handles this by allocating a temporary variable
-to contain the computed number of iterations.
-Since this variable must be in a scope that includes the entire loop,
-a GBEL block is created for that loop,
-and the variable declared as belonging to the scope of that block.
-
-@node Transforming Block IF
-@subsection Transforming Block IF
-
-Consider:
-
-@smallexample
-SUBROUTINE X(A,B,C)
-CHARACTER*(*) A, B, C
-LOGICAL LFUNC
-
-IF (LFUNC (A//B)) THEN
- CALL SUBR1
-ELSE IF (LFUNC (A//C)) THEN
- CALL SUBR2
-ELSE
- CALL SUBR3
-END
-@end smallexample
-
-The arguments to the two calls to @samp{LFUNC}
-require dynamic allocation (at run time),
-but are not required during execution of the @code{CALL} statements.
-
-So, the scopes of those temporaries must be within blocks inside
-the block corresponding to the Fortran @code{IF} block.
-
-This cannot be represented ``naturally''
-in vanilla C, nor in GBEL.
-The @code{if}, @code{elseif}, @code{else},
-and @code{endif} constructs
-provided by both languages must,
-for a given @code{if} block,
-share the same C/GBE block.
-
-Therefore, any temporaries needed during evaluation of @samp{expr}
-while executing @samp{ELSE IF(expr)}
-must either have been predeclared
-at the top of the corresponding @code{IF} block,
-or declared within a new block for that @code{ELSE IF}---a block that,
-since it cannot contain the @code{else} or @code{else if} itself
-(due to the above requirement),
-actually implements the rest of the @code{IF} block's
-@code{ELSE IF} and @code{ELSE} statements
-within an inner block.
-
-The FFE takes the latter approach.
-
-@node Transforming SELECT CASE
-@subsection Transforming SELECT CASE
-
-@code{SELECT CASE} poses a few interesting problems for code generation,
-if efficiency and frugal stack management are important.
-
-Consider @samp{SELECT CASE (I('PREFIX'//A))},
-where @samp{A} is @code{CHARACTER*(*)}.
-In a case like this---basically,
-in any case where largish temporaries are needed
-to evaluate the expression---those temporaries should
-not be ``live'' during execution of any of the @code{CASE} blocks.
-
-So, evaluation of the expression is best done within its own block,
-which in turn is within the @code{SELECT CASE} block itself
-(which contains the code for the CASE blocks as well,
-though each within their own block).
-
-Otherwise, we'd have the rough equivalent of this pseudo-code:
-
-@smallexample
-@{
- char temp[large];
-
- libg77_catenate (temp, 'prefix', a);
-
- switch (i (temp))
- @{
- case 0:
- @dots{}
- @}
-@}
-@end smallexample
-
-And that would leave temp[large] in scope during the CASE blocks
-(although a clever back end *could* see that it isn't referenced
-in them, and thus free that temp before executing the blocks).
-
-So this approach is used instead:
-
-@smallexample
-@{
- int temp0;
-
- @{
- char temp1[large];
-
- libg77_catenate (temp1, 'prefix', a);
- temp0 = i (temp1);
- @}
-
- switch (temp0)
- @{
- case 0:
- @dots{}
- @}
-@}
-@end smallexample
-
-Note how @samp{temp1} goes out of scope before starting the switch,
-thus making it easy for a back end to free it.
-
-The problem @emph{that} solution has, however,
-is with @samp{SELECT CASE('prefix'//A)}
-(which is currently not supported).
-
-Unless the GBEL is extended to support arbitrarily long character strings
-in its @code{case} facility,
-the FFE has to implement @code{SELECT CASE} on @code{CHARACTER}
-(probably excepting @code{CHARACTER*1})
-using a cascade of
-@code{if}, @code{elseif}, @code{else}, and @code{endif} constructs
-in GBEL.
-
-To prevent the (potentially large) temporary,
-needed to hold the selected expression itself (@samp{'prefix'//A}),
-from being in scope during execution of the @code{CASE} blocks,
-two approaches are available:
-
-@itemize @bullet
-@item
-Pre-evaluate all the @code{CASE} tests,
-producing an integer ordinal that is used,
-a la @samp{temp0} in the earlier example,
-as if @samp{SELECT CASE(temp0)} had been written.
-
-Each corresponding @code{CASE} is replaced with @samp{CASE(@var{i})},
-where @var{i} is the ordinal for that case,
-determined while, or before,
-generating the cascade of @code{if}-related constructs
-to cope with @code{CHARACTER} selection.
-
-@item
-Make @samp{temp0} above just
-large enough to hold the longest @code{CASE} string
-that'll actually be compared against the expression
-(in this case, @samp{'prefix'//A}).
-
-Since that length must be constant
-(because @code{CASE} expressions are all constant),
-it won't be so large,
-and, further, @samp{temp1} need not be dynamically allocated,
-since normal @code{CHARACTER} assignment can be used
-into the fixed-length @samp{temp0}.
-@end itemize
-
-Both of these solutions require @code{SELECT CASE} implementation
-to be changed so all the corresponding @code{CASE} statements
-are seen during the actual code generation for @code{SELECT CASE}.
-
-@node Transforming Expressions
-@section Transforming Expressions
-
-The interactions between statements, expressions, and subexpressions
-at program run time can be viewed as:
-
-@smallexample
-@var{action}(@var{expr})
-@end smallexample
-
-Here, @var{action} is the series of steps
-performed to effect the statement,
-and @var{expr} is the expression
-whose value is used by @var{action}.
-
-Expanding the above shows a typical order of events at run time:
-
-@smallexample
-Evaluate @var{expr}
-Perform @var{action}, using result of evaluation of @var{expr}
-Clean up after evaluating @var{expr}
-@end smallexample
-
-So, if evaluating @var{expr} requires allocating memory,
-that memory can be freed before performing @var{action}
-only if it is not needed to hold the result of evaluating @var{expr}.
-Otherwise, it must be freed no sooner than
-after @var{action} has been performed.
-
-The above are recursive definitions,
-in the sense that they apply to subexpressions of @var{expr}.
-
-That is, evaluating @var{expr} involves
-evaluating all of its subexpressions,
-performing the @var{action} that computes the
-result value of @var{expr},
-then cleaning up after evaluating those subexpressions.
-
-The recursive nature of this evaluation is implemented
-via recursive-descent transformation of the top-level statements,
-their expressions, @emph{their} subexpressions, and so on.
-
-However, that recursive-descent transformation is,
-due to the nature of the GBEL,
-focused primarily on generating a @emph{single} stream of code
-to be executed at run time.
-
-Yet, from the above, it's clear that multiple streams of code
-must effectively be simultaneously generated
-during the recursive-descent analysis of statements.
-
-The primary stream implements the primary @var{action} items,
-while at least two other streams implement
-the evaluation and clean-up items.
-
-Requirements imposed by expressions include:
-
-@itemize @bullet
-@item
-Whether the caller needs to have a temporary ready
-to hold the value of the expression.
-
-@item
-Other stuff???
-@end itemize
-
-@node Internal Naming Conventions
-@section Internal Naming Conventions
-
-Names exported by FFE modules have the following (regular-expression) forms.
-Note that all names beginning @code{ffe@var{mod}} or @code{FFE@var{mod}},
-where @var{mod} is lowercase or uppercase alphanumerics, respectively,
-are exported by the module @code{ffe@var{mod}},
-with the source code doing the exporting in @file{@var{mod}.h}.
-(Usually, the source code for the implementation is in @file{@var{mod}.c}.)
-
-Identifiers that don't fit the following forms
-are not considered exported,
-even if they are according to the C language.
-(For example, they might be made available to other modules
-solely for use within expansions of exported macros,
-not for use within any source code in those other modules.)
-
-@table @code
-@item ffe@var{mod}
-The single typedef exported by the module.
-
-@item FFE@var{umod}_[A-Z][A-Z0-9_]*
-(Where @var{umod} is the uppercase for of @var{mod}.)
-
-A @code{#define} or @code{enum} constant of the type @code{ffe@var{mod}}.
-
-@item ffe@var{mod}[A-Z][A-Z][a-z0-9]*
-A typedef exported by the module.
-
-The portion of the identifier after @code{ffe@var{mod}} is
-referred to as @code{ctype}, a capitalized (mixed-case) form
-of @code{type}.
-
-@item FFE@var{umod}_@var{type}[A-Z][A-Z0-9_]*[A-Z0-9]?
-(Where @var{umod} is the uppercase for of @var{mod}.)
-
-A @code{#define} or @code{enum} constant of the type
-@code{ffe@var{mod}@var{type}},
-where @var{type} is the lowercase form of @var{ctype}
-in an exported typedef.
-
-@item ffe@var{mod}_@var{value}
-A function that does or returns something,
-as described by @var{value} (see below).
-
-@item ffe@var{mod}_@var{value}_@var{input}
-A function that does or returns something based
-primarily on the thing described by @var{input} (see below).
-@end table
-
-Below are names used for @var{value} and @var{input},
-along with their definitions.
-
-@table @code
-@item col
-A column number within a line (first column is number 1).
-
-@item file
-An encapsulation of a file's name.
-
-@item find
-Looks up an instance of some type that matches specified criteria,
-and returns that, even if it has to create a new instance or
-crash trying to find it (as appropriate).
-
-@item initialize
-Initializes, usually a module. No type.
-
-@item int
-A generic integer of type @code{int}.
-
-@item is
-A generic integer that contains a true (nonzero) or false (zero) value.
-
-@item len
-A generic integer that contains the length of something.
-
-@item line
-A line number within a source file,
-or a global line number.
-
-@item lookup
-Looks up an instance of some type that matches specified criteria,
-and returns that, or returns nil.
-
-@item name
-A @code{text} that points to a name of something.
-
-@item new
-Makes a new instance of the indicated type.
-Might return an existing one if appropriate---if so,
-similar to @code{find} without crashing.
-
-@item pt
-Pointer to a particular character (line, column pairs)
-in the input file (source code being compiled).
-
-@item run
-Performs some herculean task. No type.
-
-@item terminate
-Terminates, usually a module. No type.
-
-@item text
-A @code{char *} that points to generic text.
-@end table
+++ /dev/null
-/* fini.c
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
-
-#define USE_BCONFIG
-
-#include "proj.h"
-#include "malloc.h"
-
-#undef MAXNAMELEN
-#define MAXNAMELEN 100
-
-typedef struct _name_ *name;
-
-struct _name_
- {
- name next;
- name previous;
- name next_alpha;
- name previous_alpha;
- int namelen;
- int kwlen;
- char kwname[MAXNAMELEN];
- char name_uc[MAXNAMELEN];
- char name_lc[MAXNAMELEN];
- char name_ic[MAXNAMELEN];
- };
-
-struct _name_root_
- {
- name first;
- name last;
- };
-
-struct _name_alpha_
- {
- name ign1;
- name ign2;
- name first;
- name last;
- };
-
-static FILE *in;
-static FILE *out;
-static char prefix[32];
-static char postfix[32];
-static char storage[32];
-static const char *const xspaces[]
-=
-{
- "", /* 0 */
- " ", /* 1 */
- " ", /* 2 */
- " ", /* 3 */
- " ", /* 4 */
- " ", /* 5 */
- " ", /* 6 */
- " ", /* 7 */
- "\t", /* 8 */
- "\t ", /* 9 */
- "\t ", /* 10 */
- "\t ", /* 11 */
- "\t ", /* 12 */
- "\t ", /* 13 */
- "\t ", /* 14 */
- "\t ", /* 15 */
- "\t\t", /* 16 */
- "\t\t ", /* 17 */
- "\t\t ", /* 18 */
- "\t\t ", /* 19 */
- "\t\t ", /* 20 */
- "\t\t ", /* 21 */
- "\t\t ", /* 22 */
- "\t\t ", /* 23 */
- "\t\t\t", /* 24 */
- "\t\t\t ", /* 25 */
- "\t\t\t ", /* 26 */
- "\t\t\t ", /* 27 */
- "\t\t\t ", /* 28 */
- "\t\t\t ", /* 29 */
- "\t\t\t ", /* 30 */
- "\t\t\t ", /* 31 */
- "\t\t\t\t", /* 32 */
- "\t\t\t\t ", /* 33 */
- "\t\t\t\t ", /* 34 */
- "\t\t\t\t ", /* 35 */
- "\t\t\t\t ", /* 36 */
- "\t\t\t\t ", /* 37 */
- "\t\t\t\t ", /* 38 */
- "\t\t\t\t ", /* 39 */
- "\t\t\t\t\t", /* 40 */
- "\t\t\t\t\t ", /* 41 */
- "\t\t\t\t\t ", /* 42 */
- "\t\t\t\t\t ", /* 43 */
- "\t\t\t\t\t ", /* 44 */
- "\t\t\t\t\t ", /* 45 */
- "\t\t\t\t\t ", /* 46 */
- "\t\t\t\t\t ", /* 47 */
- "\t\t\t\t\t\t", /* 48 */
- "\t\t\t\t\t\t ", /* 49 */
- "\t\t\t\t\t\t ", /* 50 */
- "\t\t\t\t\t\t ", /* 51 */
- "\t\t\t\t\t\t ", /* 52 */
- "\t\t\t\t\t\t ", /* 53 */
- "\t\t\t\t\t\t ", /* 54 */
- "\t\t\t\t\t\t ", /* 55 */
- "\t\t\t\t\t\t\t", /* 56 */
- "\t\t\t\t\t\t\t ", /* 57 */
- "\t\t\t\t\t\t\t ", /* 58 */
- "\t\t\t\t\t\t\t ", /* 59 */
- "\t\t\t\t\t\t\t ", /* 60 */
- "\t\t\t\t\t\t\t ", /* 61 */
- "\t\t\t\t\t\t\t ", /* 62 */
- "\t\t\t\t\t\t\t ", /* 63 */
- "\t\t\t\t\t\t\t\t", /* 64 */
- "\t\t\t\t\t\t\t\t ", /* 65 */
- "\t\t\t\t\t\t\t\t ", /* 66 */
- "\t\t\t\t\t\t\t\t ", /* 67 */
- "\t\t\t\t\t\t\t\t ", /* 68 */
- "\t\t\t\t\t\t\t\t ", /* 69 */
- "\t\t\t\t\t\t\t\t ", /* 70 */
- "\t\t\t\t\t\t\t\t ", /* 71 */
- "\t\t\t\t\t\t\t\t\t", /* 72 */
- "\t\t\t\t\t\t\t\t\t ", /* 73 */
- "\t\t\t\t\t\t\t\t\t ", /* 74 */
- "\t\t\t\t\t\t\t\t\t ", /* 75 */
- "\t\t\t\t\t\t\t\t\t ", /* 76 */
- "\t\t\t\t\t\t\t\t\t ", /* 77 */
- "\t\t\t\t\t\t\t\t\t ", /* 78 */
- "\t\t\t\t\t\t\t\t\t ", /* 79 */
- "\t\t\t\t\t\t\t\t\t\t", /* 80 */
- "\t\t\t\t\t\t\t\t\t\t ", /* 81 */
- "\t\t\t\t\t\t\t\t\t\t ", /* 82 */
- "\t\t\t\t\t\t\t\t\t\t ", /* 83 */
- "\t\t\t\t\t\t\t\t\t\t ", /* 84 */
- "\t\t\t\t\t\t\t\t\t\t ", /* 85 */
- "\t\t\t\t\t\t\t\t\t\t ", /* 86 */
- "\t\t\t\t\t\t\t\t\t\t ",/* 87 */
- "\t\t\t\t\t\t\t\t\t\t\t", /* 88 */
- "\t\t\t\t\t\t\t\t\t\t\t ", /* 89 */
- "\t\t\t\t\t\t\t\t\t\t\t ", /* 90 */
- "\t\t\t\t\t\t\t\t\t\t\t ", /* 91 */
- "\t\t\t\t\t\t\t\t\t\t\t ", /* 92 */
- "\t\t\t\t\t\t\t\t\t\t\t ",/* 93 */
- "\t\t\t\t\t\t\t\t\t\t\t ", /* 94 */
- "\t\t\t\t\t\t\t\t\t\t\t ", /* 95 */
- "\t\t\t\t\t\t\t\t\t\t\t\t", /* 96 */
- "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 97 */
- "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 98 */
- "\t\t\t\t\t\t\t\t\t\t\t\t ",/* 99 */
- "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 100 */
- "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 101 */
- "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 102 */
- "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 103 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 104 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t ",/* 105 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 106 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 107 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 108 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 109 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 110 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 111 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 112 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 113 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 114 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 115 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 116 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 117 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 118 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 119 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 120 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 121 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 122 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 123 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 124 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 125 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 126 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 127 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 128 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 129 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 130 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 131 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 132 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 133 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 134 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 135 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 136 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 137 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 138 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 139 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 140 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 141 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 142 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 143 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 144 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 145 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 146 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 147 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 148 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 149 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 150 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 151 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 152 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 153 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 154 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 155 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 156 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 157 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 158 */
- "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 159 */
-};
-
-void testname (bool nested, int indent, name first, name last);
-void testnames (bool nested, int indent, int len, name first, name last);
-
-int
-main (int argc, char **argv)
-{
- char buf[MAXNAMELEN];
- char last_buf[MAXNAMELEN];
- char kwname[MAXNAMELEN];
- char routine[32];
- char type[32];
- int i;
- int count;
- int len;
- struct _name_root_ names[200];
- struct _name_alpha_ names_alpha;
- name n;
- name newname;
- char *input_name;
- char *output_name;
- char *include_name;
- FILE *incl;
- int fixlengths;
- int total_length;
- int do_name; /* TRUE if token may be NAME. */
- int do_names; /* TRUE if token may be NAMES. */
- int cc;
- bool do_exit = FALSE;
-
- last_buf[0] = '\0';
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
- { /* Initialize length/name ordered list roots. */
- names[i].first = (name) &names[i];
- names[i].last = (name) &names[i];
- }
- names_alpha.first = (name) &names_alpha; /* Initialize name order. */
- names_alpha.last = (name) &names_alpha;
-
- if (argc != 4)
- {
- fprintf (stderr, "Command form: fini input output-code output-include\n");
- return (1);
- }
-
- input_name = argv[1];
- output_name = argv[2];
- include_name = argv[3];
-
- in = fopen (input_name, "r");
- if (in == NULL)
- {
- fprintf (stderr, "Cannot open \"%s\"\n", input_name);
- return (1);
- }
- out = fopen (output_name, "w");
- if (out == NULL)
- {
- fclose (in);
- fprintf (stderr, "Cannot open \"%s\"\n", output_name);
- return (1);
- }
- incl = fopen (include_name, "w");
- if (incl == NULL)
- {
- fclose (in);
- fprintf (stderr, "Cannot open \"%s\"\n", include_name);
- return (1);
- }
-
- /* Get past the initial block-style comment (man, this parsing code is just
- _so_ lame, but I'm too lazy to improve it). */
-
- for (;;)
- {
- cc = getc (in);
- if (cc == '{')
- {
- while (((cc = getc (in)) != '}') && (cc != EOF))
- ;
- }
- else if (cc != EOF)
- {
- while (((cc = getc (in)) != EOF) && (! ISALNUM (cc)))
- ;
- ungetc (cc, in);
- break;
- }
- else
- {
- assert ("EOF too soon!" == NULL);
- return (1);
- }
- }
-
- fscanf (in, "%s %s %s %s %s %d %d", prefix, postfix, storage, type, routine,
- &do_name, &do_names);
-
- if (storage[0] == '\0')
- storage[1] = '\0';
- else
- /* Assume string is quoted somehow, replace ending quote with space. */
- {
- if (storage[2] == '\0')
- storage[1] = '\0';
- else
- storage[strlen (storage) - 1] = ' ';
- }
-
- if (postfix[0] == '\0')
- postfix[1] = '\0';
- else /* Assume string is quoted somehow, strip off
- ending quote. */
- postfix[strlen (postfix) - 1] = '\0';
-
- for (i = 1; storage[i] != '\0'; ++i)
- storage[i - 1] = storage[i];
- storage[i - 1] = '\0';
-
- for (i = 1; postfix[i] != '\0'; ++i)
- postfix[i - 1] = postfix[i];
- postfix[i - 1] = '\0';
-
- fixlengths = strlen (prefix) + strlen (postfix);
-
- while (TRUE)
- {
- count = fscanf (in, "%s %s", buf, kwname);
- if (count == EOF)
- break;
- len = strlen (buf);
- if (len == 0)
- continue; /* Skip empty lines. */
- if (buf[0] == ';')
- continue; /* Skip commented-out lines. */
- for (i = strlen (buf) - 1; i > 0; --i)
- cc = buf[i];
-
- /* Make new name object to store name and its keyword. */
-
- newname = xmalloc (sizeof (*newname));
- newname->namelen = strlen (buf);
- newname->kwlen = strlen (kwname);
- total_length = newname->kwlen + fixlengths;
- if (total_length >= 32) /* Else resulting keyword name too long. */
- {
- fprintf (stderr, "%s: %s%s%s is 31+%d chars long\n", input_name,
- prefix, kwname, postfix, total_length - 31);
- do_exit = TRUE;
- }
- strcpy (newname->kwname, kwname);
- for (i = 0; i < newname->namelen; ++i)
- {
- cc = buf[i];
- newname->name_uc[i] = TOUPPER (cc);
- newname->name_lc[i] = TOLOWER (cc);
- newname->name_ic[i] = cc;
- }
- newname->name_uc[i] = newname->name_lc[i] = newname->name_ic[i] = '\0';
-
- /* Warn user if names aren't alphabetically ordered. */
-
- if ((last_buf[0] != '\0')
- && (strcmp (last_buf, newname->name_uc) >= 0))
- {
- fprintf (stderr, "%s: \"%s\" precedes \"%s\"\n", input_name,
- last_buf, newname->name_uc);
- do_exit = TRUE;
- }
- strcpy (last_buf, newname->name_uc);
-
- /* Append name to end of alpha-sorted list (assumes names entered in
- alpha order wrt name, not kwname, even though kwname is output from
- this list). */
-
- n = names_alpha.last;
- newname->next_alpha = n->next_alpha;
- newname->previous_alpha = n;
- n->next_alpha->previous_alpha = newname;
- n->next_alpha = newname;
-
- /* Insert name in appropriate length/name ordered list. */
-
- n = (name) &names[len];
- while ((n->next != (name) &names[len])
- && (strcmp (buf, n->next->name_uc) > 0))
- n = n->next;
- if (strcmp (buf, n->next->name_uc) == 0)
- {
- fprintf (stderr, "%s: extraneous \"%s\"\n", input_name, buf);
- do_exit = TRUE;
- }
- newname->next = n->next;
- newname->previous = n;
- n->next->previous = newname;
- n->next = newname;
- }
-
-#if 0
- for (len = 0; len < ARRAY_SIZE (name); ++len)
- {
- if (names[len].first == (name) &names[len])
- continue;
- printf ("Length %d:\n", len);
- for (n = names[len].first; n != (name) &names[len]; n = n->next)
- printf (" %s %s %s\n", n->name_uc, n->name_lc, n->name_ic);
- }
-#endif
-
- if (do_exit)
- return (1);
-
- /* First output the #include file. */
-
- for (n = names_alpha.first; n != (name) &names_alpha; n = n->next_alpha)
- {
- fprintf (incl, "#define %sl%s%s %d\n", prefix, n->kwname, postfix,
- n->namelen);
- }
-
- fprintf (incl,
- "\
-\n\
-enum %s_\n\
-{\n\
-%sNone%s,\n\
-",
- type, prefix, postfix);
-
- for (n = names_alpha.first; n != (name) &names_alpha; n = n->next_alpha)
- {
- fprintf (incl,
- "\
-%s%s%s,\n\
-",
- prefix, n->kwname, postfix);
- }
-
- fprintf (incl,
- "\
-%s%s\n\
-};\n\
-typedef enum %s_ %s;\n\
-",
- prefix, postfix, type, type);
-
- /* Now output the C program. */
-
- fprintf (out,
- "\
-%s%s\n\
-%s (ffelexToken t)\n\
-%c\n\
- char *p;\n\
- int c;\n\
-\n\
- p = ffelex_token_text (t);\n\
-\n\
-",
- storage, type, routine, '{');
-
- if (do_name)
- {
- if (do_names)
- fprintf (out,
- "\
- if (ffelex_token_type (t) == FFELEX_typeNAME)\n\
- {\n\
- switch (ffelex_token_length (t))\n\
-\t{\n\
-"
- );
- else
- fprintf (out,
- "\
- assert (ffelex_token_type (t) == FFELEX_typeNAME);\n\
-\n\
- switch (ffelex_token_length (t))\n\
- {\n\
-"
- );
-
-/* Now output the length as a case, followed by the binary search within that length. */
-
- for (len = 0; ((size_t) len) < ARRAY_SIZE (names); ++len)
- {
- if (names[len].first != (name) &names[len])
- {
- if (do_names)
- fprintf (out,
- "\
-\tcase %d:\n\
-",
- len);
- else
- fprintf (out,
- "\
- case %d:\n\
-",
- len);
- testname (FALSE, do_names ? 10 : 6, names[len].first, names[len].last);
- if (do_names)
- fprintf (out,
- "\
-\t break;\n\
-"
- );
- else
- fprintf (out,
- "\
- break;\n\
-"
- );
- }
- }
-
- if (do_names)
- fprintf (out,
- "\
-\t}\n\
- return %sNone%s;\n\
- }\n\
-\n\
-",
- prefix, postfix);
- else
- fprintf (out,
- "\
- }\n\
-\n\
- return %sNone%s;\n\
-}\n\
-",
- prefix, postfix);
- }
-
- if (do_names)
- {
- fputs ("\
- assert (ffelex_token_type (t) == FFELEX_typeNAMES);\n\
-\n\
- switch (ffelex_token_length (t))\n\
- {\n\
- default:\n\
-",
- out);
-
- /* Find greatest non-empty length list. */
-
- for (len = ARRAY_SIZE (names) - 1;
- names[len].first == (name) &names[len];
- --len)
- ;
-
-/* Now output the length as a case, followed by the binary search within that length. */
-
- if (len > 0)
- {
- for (; len != 0; --len)
- {
- fprintf (out,
- "\
- case %d:\n\
-",
- len);
- if (names[len].first != (name) &names[len])
- testnames (FALSE, 6, len, names[len].first, names[len].last);
- }
- if (names[1].first == (name) &names[1])
- fprintf (out,
- "\
- ;\n\
-"
- ); /* Need empty statement after an empty case
- 1: */
- }
-
- fprintf (out,
- "\
- }\n\
-\n\
- return %sNone%s;\n\
-}\n\
-",
- prefix, postfix);
- }
-
- if (out != stdout)
- fclose (out);
- if (incl != stdout)
- fclose (incl);
- if (in != stdin)
- fclose (in);
- return (0);
-}
-
-void
-testname (bool nested, int indent, name first, name last)
-{
- name n;
- name nhalf;
- int num;
- int numhalf;
-
- assert (!nested || indent >= 2);
- assert (((size_t) indent) + 4 < ARRAY_SIZE (xspaces));
-
- num = 0;
- numhalf = 0;
- for (n = first, nhalf = first; n != last->next; n = n->next)
- {
- if ((++num & 1) == 0)
- {
- nhalf = nhalf->next;
- ++numhalf;
- }
- }
-
- if (nested)
- fprintf (out,
- "\
-%s{\n\
-",
- xspaces[indent - 2]);
-
- fprintf (out,
- "\
-%sif ((c = ffesrc_strcmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\")) == 0)\n\
-%sreturn %s%s%s;\n\
-",
- xspaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic,
- xspaces[indent + 2], prefix, nhalf->kwname, postfix);
-
- if (num != 1)
- {
- fprintf (out,
- "\
-%selse if (c < 0)\n\
-",
- xspaces[indent]);
-
- if (numhalf == 0)
- fprintf (out,
- "\
-%s;\n\
-",
- xspaces[indent + 2]);
- else
- testname (TRUE, indent + 4, first, nhalf->previous);
-
- if (num - numhalf > 1)
- {
- fprintf (out,
- "\
-%selse\n\
-",
- xspaces[indent]);
-
- testname (TRUE, indent + 4, nhalf->next, last);
- }
- }
-
- if (nested)
- fprintf (out,
- "\
-%s}\n\
-",
- xspaces[indent - 2]);
-}
-
-void
-testnames (bool nested, int indent, int len, name first, name last)
-{
- name n;
- name nhalf;
- int num;
- int numhalf;
-
- assert (!nested || indent >= 2);
- assert (((size_t) indent) + 4 < ARRAY_SIZE (xspaces));
-
- num = 0;
- numhalf = 0;
- for (n = first, nhalf = first; n != last->next; n = n->next)
- {
- if ((++num & 1) == 0)
- {
- nhalf = nhalf->next;
- ++numhalf;
- }
- }
-
- if (nested)
- fprintf (out,
- "\
-%s{\n\
-",
- xspaces[indent - 2]);
-
- fprintf (out,
- "\
-%sif ((c = ffesrc_strncmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\", %d)) == 0)\n\
-%sreturn %s%s%s;\n\
-",
- xspaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic,
- len, xspaces[indent + 2], prefix, nhalf->kwname, postfix);
-
- if (num != 1)
- {
- fprintf (out,
- "\
-%selse if (c < 0)\n\
-",
- xspaces[indent]);
-
- if (numhalf == 0)
- fprintf (out,
- "\
-%s;\n\
-",
- xspaces[indent + 2]);
- else
- testnames (TRUE, indent + 4, len, first, nhalf->previous);
-
- if (num - numhalf > 1)
- {
- fprintf (out,
- "\
-%selse\n\
-",
- xspaces[indent]);
-
- testnames (TRUE, indent + 4, len, nhalf->next, last);
- }
- }
-
- if (nested)
- fprintf (out,
- "\
-%s}\n\
-",
- xspaces[indent - 2]);
-}
+++ /dev/null
-\input texinfo @c -*-texinfo-*-
-@c %**start of header
-@setfilename g77.info
-
-@set last-update 2004-03-21
-@set copyrights-g77 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
-
-@include root.texi
-
-@c This tells @include'd files that they're part of the overall G77 doc
-@c set. (They might be part of a higher-level doc set too.)
-@set DOC-G77
-
-@c @setfilename useg77.info
-@c @setfilename portg77.info
-@c To produce the full manual, use the "g77.info" setfilename, and
-@c make sure the following do NOT begin with '@c' (and the @clear lines DO)
-@set INTERNALS
-@set USING
-@c To produce a user-only manual, use the "useg77.info" setfilename, and
-@c make sure the following does NOT begin with '@c':
-@c @clear INTERNALS
-@c To produce a porter-only manual, use the "portg77.info" setfilename,
-@c and make sure the following does NOT begin with '@c':
-@c @clear USING
-
-@ifset INTERNALS
-@ifset USING
-@settitle Using and Porting GNU Fortran
-@end ifset
-@end ifset
-@c seems reasonable to assume at least one of INTERNALS or USING is set...
-@ifclear INTERNALS
-@settitle Using GNU Fortran
-@end ifclear
-@ifclear USING
-@settitle Porting GNU Fortran
-@end ifclear
-@c then again, have some fun
-@ifclear INTERNALS
-@ifclear USING
-@settitle Doing Squat with GNU Fortran
-@end ifclear
-@end ifclear
-
-@syncodeindex fn cp
-@syncodeindex vr cp
-@c %**end of header
-
-@c Cause even numbered pages to be printed on the left hand side of
-@c the page and odd numbered pages to be printed on the right hand
-@c side of the page. Using this, you can print on both sides of a
-@c sheet of paper and have the text on the same part of the sheet.
-
-@c The text on right hand pages is pushed towards the right hand
-@c margin and the text on left hand pages is pushed toward the left
-@c hand margin.
-@c (To provide the reverse effect, set bindingoffset to -0.75in.)
-
-@c @tex
-@c \global\bindingoffset=0.75in
-@c \global\normaloffset =0.75in
-@c @end tex
-
-@copying
-Copyright @copyright{} @value{copyrights-g77} Free Software Foundation, Inc.
-
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.2 or
-any later version published by the Free Software Foundation; with the
-Invariant Sections being ``GNU General Public License'' and ``Funding
-Free Software'', the Front-Cover
-texts being (a) (see below), and with the Back-Cover Texts being (b)
-(see below). A copy of the license is included in the section entitled
-``GNU Free Documentation License''.
-
-(a) The FSF's Front-Cover Text is:
-
- A GNU Manual
-
-(b) The FSF's Back-Cover Text is:
-
- You have freedom to copy and modify this GNU Manual, like GNU
- software. Copies published by the Free Software Foundation raise
- funds for GNU development.
-@end copying
-
-@ifinfo
-@dircategory Programming
-@direntry
-* g77: (g77). The GNU Fortran compiler.
-@end direntry
-@ifset INTERNALS
-@ifset USING
-This file documents the use and the internals of the GNU Fortran (@command{g77})
-compiler.
-It corresponds to the @value{which-g77} version of @command{g77}.
-@end ifset
-@end ifset
-@ifclear USING
-This file documents the internals of the GNU Fortran (@command{g77}) compiler.
-It corresponds to the @value{which-g77} version of @command{g77}.
-@end ifclear
-@ifclear INTERNALS
-This file documents the use of the GNU Fortran (@command{g77}) compiler.
-It corresponds to the @value{which-g77} version of @command{g77}.
-@end ifclear
-
-Published by the Free Software Foundation
-59 Temple Place - Suite 330
-Boston, MA 02111-1307 USA
-
-@insertcopying
-@end ifinfo
-
-Contributed by James Craig Burley (@email{@value{email-burley}}).
-Inspired by a first pass at translating @file{g77-0.5.16/f/DOC} that
-was contributed to Craig by David Ronis (@email{ronis@@onsager.chem.mcgill.ca}).
-
-@setchapternewpage odd
-@titlepage
-@ifset INTERNALS
-@ifset USING
-@center @titlefont{Using and Porting GNU Fortran}
-
-@end ifset
-@end ifset
-@ifclear INTERNALS
-@title Using GNU Fortran
-@end ifclear
-@ifclear USING
-@title Porting GNU Fortran
-@end ifclear
-@sp 2
-@center James Craig Burley
-@sp 3
-@center Last updated @value{last-update}
-@sp 1
-@center for version @value{which-g77}
-@page
-@vskip 0pt plus 1filll
-For the @value{which-g77} Version*
-@sp 1
-Published by the Free Software Foundation @*
-59 Temple Place - Suite 330@*
-Boston, MA 02111-1307, USA@*
-@c Last printed ??ber, 19??.@*
-@c Printed copies are available for $? each.@*
-@c ISBN ???
-@sp 1
-@insertcopying
-@end titlepage
-@summarycontents
-@contents
-@page
-
-@node Top, Copying,, (DIR)
-@top Introduction
-@cindex Introduction
-
-@ifset INTERNALS
-@ifset USING
-This manual documents how to run, install and port @command{g77},
-as well as its new features and incompatibilities,
-and how to report bugs.
-It corresponds to the @value{which-g77} version of @command{g77}.
-@end ifset
-@end ifset
-
-@ifclear INTERNALS
-This manual documents how to run and install @command{g77},
-as well as its new features and incompatibilities, and how to report
-bugs.
-It corresponds to the @value{which-g77} version of @command{g77}.
-@end ifclear
-@ifclear USING
-This manual documents how to port @command{g77},
-as well as its new features and incompatibilities,
-and how to report bugs.
-It corresponds to the @value{which-g77} version of @command{g77}.
-@end ifclear
-
-@ifset DEVELOPMENT
-@emph{Warning:} This document is still under development,
-and might not accurately reflect the @command{g77} code base
-of which it is a part.
-Efforts are made to keep it somewhat up-to-date,
-but they are particularly concentrated
-on any version of this information
-that is distributed as part of a @emph{released} @command{g77}.
-
-In particular, while this document is intended to apply to
-the @value{which-g77} version of @command{g77},
-only an official @emph{release} of that version
-is expected to contain documentation that is
-most consistent with the @command{g77} product in that version.
-@end ifset
-
-@menu
-* Copying:: GNU General Public License says
- how you can copy and share GNU Fortran.
-* GNU Free Documentation License::
- How you can copy and share this manual.
-* Contributors:: People who have contributed to GNU Fortran.
-* Funding:: How to help assure continued work for free software.
-* Funding GNU Fortran:: How to help assure continued work on GNU Fortran.
-@ifset USING
-* Getting Started:: Finding your way around this manual.
-* What is GNU Fortran?:: How @command{g77} fits into the universe.
-* G77 and GCC:: You can compile Fortran, C, or other programs.
-* Invoking G77:: Command options supported by @command{g77}.
-* News:: News about recent releases of @command{g77}.
-* Changes:: User-visible changes to recent releases of @command{g77}.
-* Language:: The GNU Fortran language.
-* Compiler:: The GNU Fortran compiler.
-* Other Dialects:: Dialects of Fortran supported by @command{g77}.
-* Other Compilers:: Fortran compilers other than @command{g77}.
-* Other Languages:: Languages other than Fortran.
-* Debugging and Interfacing:: How @command{g77} generates code.
-* Collected Fortran Wisdom:: How to avoid Trouble.
-* Trouble:: If you have trouble with GNU Fortran.
-* Open Questions:: Things we'd like to know.
-* Bugs:: How, why, and where to report bugs.
-* Service:: How to find suppliers of support for GNU Fortran.
-@end ifset
-@ifset INTERNALS
-* Adding Options:: Guidance on teaching @command{g77} about new options.
-* Projects:: Projects for @command{g77} internals hackers.
-* Front End:: Design and implementation of the @command{g77} front end.
-@end ifset
-
-* M: Diagnostics. Diagnostics produced by @command{g77}.
-
-* Keyword Index:: Index of concepts and symbol names.
-@end menu
-@c yes, the "M: " @emph{is} intentional -- bad.def references it (CMPAMBIG)!
-
-@include gpl.texi
-
-@include fdl.texi
-
-@node Contributors
-@unnumbered Contributors to GNU Fortran
-@cindex contributors
-@cindex credits
-
-In addition to James Craig Burley, who wrote the front end,
-many people have helped create and improve GNU Fortran.
-
-@itemize @bullet
-@item
-The packaging and compiler portions of GNU Fortran are based largely
-on the GCC compiler.
-@xref{Contributors,,Contributors to GCC,gcc,Using the GNU Compiler
-Collection (GCC)},
-for more information.
-
-@item
-The run-time library used by GNU Fortran is a repackaged version
-of the @code{libf2c} library (combined from the @code{libF77} and
-@code{libI77} libraries) provided as part of @command{f2c}, available for
-free from @code{netlib} sites on the Internet.
-
-@item
-Cygnus Support and The Free Software Foundation contributed
-significant money and/or equipment to Craig's efforts.
-
-@item
-The following individuals served as alpha testers prior to @command{g77}'s
-public release. This work consisted of testing, researching, sometimes
-debugging, and occasionally providing small amounts of code and fixes
-for @command{g77}, plus offering plenty of helpful advice to Craig:
-
-@itemize @w{}
-@item
-Jonathan Corbet
-@item
-Dr.@: Mark Fernyhough
-@item
-Takafumi Hayashi (The University of Aizu)---@email{takafumi@@u-aizu.ac.jp}
-@item
-Kate Hedstrom
-@item
-Michel Kern (INRIA and Rice University)---@email{Michel.Kern@@inria.fr}
-@item
-Dr.@: A. O. V. Le Blanc
-@item
-Dave Love
-@item
-Rick Lutowski
-@item
-Toon Moene
-@item
-Rick Niles
-@item
-Derk Reefman
-@item
-Wayne K. Schroll
-@item
-Bill Thorson
-@item
-Pedro A. M. Vazquez
-@item
-Ian Watson
-@end itemize
-
-@item
-Dave Love (@email{d.love@@dl.ac.uk})
-wrote the libU77 part of the run-time library.
-
-@item
-Scott Snyder (@email{snyder@@d0sgif.fnal.gov})
-provided the patch to add rudimentary support
-for @code{INTEGER*1}, @code{INTEGER*2}, and
-@code{LOGICAL*1}.
-This inspired Craig to add further support,
-even though the resulting support
-would still be incomplete.
-This support is believed to be completed at version 3.4
-of @command{gcc} by Roger Sayle (@email{roger@@eyesopen.com}).
-
-@item
-David Ronis (@email{ronis@@onsager.chem.mcgill.ca}) inspired
-and encouraged Craig to rewrite the documentation in texinfo
-format by contributing a first pass at a translation of the
-old @file{g77-0.5.16/f/DOC} file.
-
-@item
-Toon Moene (@email{toon@@moene.indiv.nluug.nl}) performed
-some analysis of generated code as part of an overall project
-to improve @command{g77} code generation to at least be as good
-as @command{f2c} used in conjunction with @command{gcc}.
-So far, this has resulted in the three, somewhat
-experimental, options added by @command{g77} to the @command{gcc}
-compiler and its back end.
-
-(These, in turn, had made their way into the @code{egcs}
-version of the compiler, and do not exist in @command{gcc}
-version 2.8 or versions of @command{g77} based on that version
-of @command{gcc}.)
-
-@item
-John Carr (@email{jfc@@mit.edu}) wrote the alias analysis improvements.
-
-@item
-Thanks to Mary Cortani and the staff at Craftwork Solutions
-(@email{support@@craftwork.com}) for all of their support.
-
-@item
-Many other individuals have helped debug, test, and improve @command{g77}
-over the past several years, and undoubtedly more people
-will be doing so in the future.
-If you have done so, and would like
-to see your name listed in the above list, please ask!
-The default is that people wish to remain anonymous.
-@end itemize
-
-@include funding.texi
-
-@node Funding GNU Fortran
-@chapter Funding GNU Fortran
-@cindex funding improvements
-@cindex improvements, funding
-
-James Craig Burley (@email{@value{email-burley}}), the original author
-of @command{g77}, stopped working on it in September 1999
-(He has a web page at @uref{@value{www-burley}}.)
-
-GNU Fortran is currently maintained by Toon Moene
-(@email{toon@@moene.indiv.nluug.nl}), with the help of countless other
-volunteers.
-
-As with other GNU software, funding is important because it can pay for
-needed equipment, personnel, and so on.
-
-@cindex FSF, funding the
-@cindex funding the FSF
-The FSF provides information on the best way to fund ongoing
-development of GNU software (such as GNU Fortran) in documents
-such as the ``GNUS Bulletin''.
-Email @email{gnu@@gnu.org} for information on funding the FSF.
-
-Another important way to support work on GNU Fortran is to volunteer
-to help out.
-
-Email @email{@value{email-general}} to volunteer for this work.
-
-However, we strongly expect that there will never be a version 0.6
-of @command{g77}. Work on this compiler has stopped as of the release
-of GCC 3.1, except for bug fixing. @command{g77} will be succeeded by
-@command{g95} - see @uref{http://g95.sourceforge.net}.
-
-@xref{Funding,,Funding Free Software}, for more information.
-
-@node Getting Started
-@chapter Getting Started
-@cindex getting started
-@cindex new users
-@cindex newbies
-@cindex beginners
-
-If you don't need help getting started reading the portions
-of this manual that are most important to you, you should skip
-this portion of the manual.
-
-If you are new to compilers, especially Fortran compilers, or
-new to how compilers are structured under UNIX and UNIX-like
-systems, you'll want to see @ref{What is GNU Fortran?}.
-
-If you are new to GNU compilers, or have used only one GNU
-compiler in the past and not had to delve into how it lets
-you manage various versions and configurations of @command{gcc},
-you should see @ref{G77 and GCC}.
-
-Everyone except experienced @command{g77} users should
-see @ref{Invoking G77}.
-
-If you're acquainted with previous versions of @command{g77},
-you should see @ref{News,,News About GNU Fortran}.
-Further, if you've actually used previous versions of @command{g77},
-especially if you've written or modified Fortran code to
-be compiled by previous versions of @command{g77}, you
-should see @ref{Changes}.
-
-If you intend to write or otherwise compile code that is
-not already strictly conforming ANSI FORTRAN 77---and this
-is probably everyone---you should see @ref{Language}.
-
-If you run into trouble getting Fortran code to compile,
-link, run, or work properly, you might find answers
-if you see @ref{Debugging and Interfacing},
-see @ref{Collected Fortran Wisdom},
-and see @ref{Trouble}.
-You might also find that the problems you are encountering
-are bugs in @command{g77}---see @ref{Bugs}, for information on
-reporting them, after reading the other material.
-
-If you need further help with @command{g77}, or with
-freely redistributable software in general,
-see @ref{Service}.
-
-If you would like to help the @command{g77} project,
-see @ref{Funding GNU Fortran}, for information on
-helping financially, and see @ref{Projects}, for information
-on helping in other ways.
-
-If you're generally curious about the future of
-@command{g77}, see @ref{Projects}.
-If you're curious about its past,
-see @ref{Contributors},
-and see @ref{Funding GNU Fortran}.
-
-To see a few of the questions maintainers of @command{g77} have,
-and that you might be able to answer,
-see @ref{Open Questions}.
-
-@ifset USING
-@node What is GNU Fortran?
-@chapter What is GNU Fortran?
-@cindex concepts, basic
-@cindex basic concepts
-
-GNU Fortran, or @command{g77}, is designed initially as a free replacement
-for, or alternative to, the UNIX @command{f77} command.
-(Similarly, @command{gcc} is designed as a replacement
-for the UNIX @command{cc} command.)
-
-@command{g77} also is designed to fit in well with the other
-fine GNU compilers and tools.
-
-Sometimes these design goals conflict---in such cases, resolution
-often is made in favor of fitting in well with Project GNU.
-These cases are usually identified in the appropriate
-sections of this manual.
-
-@cindex compilers
-As compilers, @command{g77}, @command{gcc}, and @command{f77}
-share the following characteristics:
-
-@itemize @bullet
-@cindex source code
-@cindex file, source
-@cindex code, source
-@cindex source file
-@item
-They read a user's program, stored in a file and
-containing instructions written in the appropriate
-language (Fortran, C, and so on).
-This file contains @dfn{source code}.
-
-@cindex translation of user programs
-@cindex machine code
-@cindex code, machine
-@cindex mistakes
-@item
-They translate the user's program into instructions
-a computer can carry out more quickly than it takes
-to translate the instructions in the first place.
-These instructions are called @dfn{machine code}---code
-designed to be efficiently translated and processed
-by a machine such as a computer.
-Humans usually aren't as good writing machine code
-as they are at writing Fortran or C, because
-it is easy to make tiny mistakes writing machine code.
-When writing Fortran or C, it is easy
-to make big mistakes.
-
-@cindex debugger
-@cindex bugs, finding
-@cindex @command{gdb}, command
-@cindex commands, @command{gdb}
-@item
-They provide information in the generated machine code
-that can make it easier to find bugs in the program
-(using a debugging tool, called a @dfn{debugger},
-such as @command{gdb}).
-
-@cindex libraries
-@cindex linking
-@cindex @command{ld} command
-@cindex commands, @command{ld}
-@item
-They locate and gather machine code already generated
-to perform actions requested by statements in
-the user's program.
-This machine code is organized
-into @dfn{libraries} and is located and gathered
-during the @dfn{link} phase of the compilation
-process.
-(Linking often is thought of as a separate
-step, because it can be directly invoked via the
-@command{ld} command.
-However, the @command{g77} and @command{gcc}
-commands, as with most compiler commands, automatically
-perform the linking step by calling on @command{ld}
-directly, unless asked to not do so by the user.)
-
-@cindex language, incorrect use of
-@cindex incorrect use of language
-@item
-They attempt to diagnose cases where the user's
-program contains incorrect usages of the language.
-The @dfn{diagnostics} produced by the compiler
-indicate the problem and the location in the user's
-source file where the problem was first noticed.
-The user can use this information to locate and
-fix the problem.
-@cindex diagnostics, incorrect
-@cindex incorrect diagnostics
-@cindex error messages, incorrect
-@cindex incorrect error messages
-(Sometimes an incorrect usage
-of the language leads to a situation where the
-compiler can no longer make any sense of what
-follows---while a human might be able to---and
-thus ends up complaining about many ``problems''
-it encounters that, in fact, stem from just one
-problem, usually the first one reported.)
-
-@cindex warnings
-@cindex questionable instructions
-@item
-They attempt to diagnose cases where the user's
-program contains a correct usage of the language,
-but instructs the computer to do something questionable.
-These diagnostics often are in the form of @dfn{warnings},
-instead of the @dfn{errors} that indicate incorrect
-usage of the language.
-@end itemize
-
-How these actions are performed is generally under the
-control of the user.
-Using command-line options, the user can specify
-how persnickety the compiler is to be regarding
-the program (whether to diagnose questionable usage
-of the language), how much time to spend making
-the generated machine code run faster, and so on.
-
-@cindex components of @command{g77}
-@cindex @command{g77}, components of
-@command{g77} consists of several components:
-
-@cindex @command{gcc}, command
-@cindex commands, @command{gcc}
-@itemize @bullet
-@item
-A modified version of the @command{gcc} command, which also might be
-installed as the system's @command{cc} command.
-(In many cases, @command{cc} refers to the
-system's ``native'' C compiler, which
-might be a non-GNU compiler, or an older version
-of @command{gcc} considered more stable or that is
-used to build the operating system kernel.)
-
-@cindex @command{g77}, command
-@cindex commands, @command{g77}
-@item
-The @command{g77} command itself, which also might be installed as the
-system's @command{f77} command.
-
-@cindex libg2c library
-@cindex libf2c library
-@cindex libraries, libf2c
-@cindex libraries, libg2c
-@cindex run-time, library
-@item
-The @code{libg2c} run-time library.
-This library contains the machine code needed to support
-capabilities of the Fortran language that are not directly
-provided by the machine code generated by the @command{g77}
-compilation phase.
-
-@code{libg2c} is just the unique name @command{g77} gives
-to its version of @code{libf2c} to distinguish it from
-any copy of @code{libf2c} installed from @command{f2c}
-(or versions of @command{g77} that built @code{libf2c} under
-that same name)
-on the system.
-
-The maintainer of @code{libf2c} currently is
-@email{dmg@@bell-labs.com}.
-
-@cindex @code{f771}, program
-@cindex programs, @code{f771}
-@cindex assembler
-@cindex @command{as} command
-@cindex commands, @command{as}
-@cindex assembly code
-@cindex code, assembly
-@item
-The compiler itself, internally named @code{f771}.
-
-Note that @code{f771} does not generate machine code directly---it
-generates @dfn{assembly code} that is a more readable form
-of machine code, leaving the conversion to actual machine code
-to an @dfn{assembler}, usually named @command{as}.
-@end itemize
-
-@command{gcc} is often thought of as ``the C compiler'' only,
-but it does more than that.
-Based on command-line options and the names given for files
-on the command line, @command{gcc} determines which actions to perform, including
-preprocessing, compiling (in a variety of possible languages), assembling,
-and linking.
-
-@cindex driver, gcc command as
-@cindex @command{gcc}, command as driver
-@cindex executable file
-@cindex files, executable
-@cindex cc1 program
-@cindex programs, cc1
-@cindex preprocessor
-@cindex cpp program
-@cindex programs, cpp
-For example, the command @samp{gcc foo.c} @dfn{drives} the file
-@file{foo.c} through the preprocessor @command{cpp}, then
-the C compiler (internally named
-@code{cc1}), then the assembler (usually @command{as}), then the linker
-(@command{ld}), producing an executable program named @file{a.out} (on
-UNIX systems).
-
-@cindex cc1plus program
-@cindex programs, cc1plus
-As another example, the command @samp{gcc foo.cc} would do much the same as
-@samp{gcc foo.c}, but instead of using the C compiler named @code{cc1},
-@command{gcc} would use the C++ compiler (named @code{cc1plus}).
-
-@cindex @code{f771}, program
-@cindex programs, @code{f771}
-In a GNU Fortran installation, @command{gcc} recognizes Fortran source
-files by name just like it does C and C++ source files.
-It knows to use the Fortran compiler named @code{f771}, instead of
-@code{cc1} or @code{cc1plus}, to compile Fortran files.
-
-@cindex @command{gcc}, not recognizing Fortran source
-@cindex unrecognized file format
-@cindex file format not recognized
-Non-Fortran-related operation of @command{gcc} is generally
-unaffected by installing the GNU Fortran version of @command{gcc}.
-However, without the installed version of @command{gcc} being the
-GNU Fortran version, @command{gcc} will not be able to compile
-and link Fortran programs---and since @command{g77} uses @command{gcc}
-to do most of the actual work, neither will @command{g77}!
-
-@cindex @command{g77}, command
-@cindex commands, @command{g77}
-The @command{g77} command is essentially just a front-end for
-the @command{gcc} command.
-Fortran users will normally use @command{g77} instead of @command{gcc},
-because @command{g77}
-knows how to specify the libraries needed to link with Fortran programs
-(@code{libg2c} and @code{lm}).
-@command{g77} can still compile and link programs and
-source files written in other languages, just like @command{gcc}.
-
-@cindex printing version information
-@cindex version information, printing
-The command @samp{g77 -v} is a quick
-way to display lots of version information for the various programs
-used to compile a typical preprocessed Fortran source file---this
-produces much more output than @samp{gcc -v} currently does.
-(If it produces an error message near the end of the output---diagnostics
-from the linker, usually @command{ld}---you might
-have an out-of-date @code{libf2c} that improperly handles
-complex arithmetic.)
-In the output of this command, the line beginning @samp{GNU Fortran Front
-End} identifies the version number of GNU Fortran; immediately
-preceding that line is a line identifying the version of @command{gcc}
-with which that version of @command{g77} was built.
-
-@cindex libf2c library
-@cindex libraries, libf2c
-The @code{libf2c} library is distributed with GNU Fortran for
-the convenience of its users, but is not part of GNU Fortran.
-It contains the procedures
-needed by Fortran programs while they are running.
-
-@cindex in-line code
-@cindex code, in-line
-For example, while code generated by @command{g77} is likely
-to do additions, subtractions, and multiplications @dfn{in line}---in
-the actual compiled code---it is not likely to do trigonometric
-functions this way.
-
-Instead, operations like trigonometric
-functions are compiled by the @code{f771} compiler
-(invoked by @command{g77} when compiling Fortran code) into machine
-code that, when run, calls on functions in @code{libg2c}, so
-@code{libg2c} must be linked with almost every useful program
-having any component compiled by GNU Fortran.
-(As mentioned above, the @command{g77} command takes
-care of all this for you.)
-
-The @code{f771} program represents most of what is unique to GNU Fortran.
-While much of the @code{libg2c} component comes from
-the @code{libf2c} component of @command{f2c},
-a free Fortran-to-C converter distributed by Bellcore (AT&T),
-plus @code{libU77}, provided by Dave Love,
-and the @command{g77} command is just a small front-end to @command{gcc},
-@code{f771} is a combination of two rather
-large chunks of code.
-
-@cindex GNU Back End (GBE)
-@cindex GBE
-@cindex @command{gcc}, back end
-@cindex back end, gcc
-@cindex code generator
-One chunk is the so-called @dfn{GNU Back End}, or GBE,
-which knows how to generate fast code for a wide variety of processors.
-The same GBE is used by the C, C++, and Fortran compiler programs @code{cc1},
-@code{cc1plus}, and @code{f771}, plus others.
-Often the GBE is referred to as the ``gcc back end'' or
-even just ``gcc''---in this manual, the term GBE is used
-whenever the distinction is important.
-
-@cindex GNU Fortran Front End (FFE)
-@cindex FFE
-@cindex @command{g77}, front end
-@cindex front end, @command{g77}
-The other chunk of @code{f771} is the
-majority of what is unique about GNU Fortran---the code that knows how
-to interpret Fortran programs to determine what they are intending to
-do, and then communicate that knowledge to the GBE for actual compilation
-of those programs.
-This chunk is called the @dfn{Fortran Front End} (FFE).
-The @code{cc1} and @code{cc1plus} programs have their own front ends,
-for the C and C++ languages, respectively.
-These fronts ends are responsible for diagnosing
-incorrect usage of their respective languages by the
-programs the process, and are responsible for most of
-the warnings about questionable constructs as well.
-(The GBE handles producing some warnings, like those
-concerning possible references to undefined variables.)
-
-Because so much is shared among the compilers for various languages,
-much of the behavior and many of the user-selectable options for these
-compilers are similar.
-For example, diagnostics (error messages and
-warnings) are similar in appearance; command-line
-options like @option{-Wall} have generally similar effects; and the quality
-of generated code (in terms of speed and size) is roughly similar
-(since that work is done by the shared GBE).
-
-@node G77 and GCC
-@chapter Compile Fortran, C, or Other Programs
-@cindex compiling programs
-@cindex programs, compiling
-
-@cindex @command{gcc}, command
-@cindex commands, @command{gcc}
-A GNU Fortran installation includes a modified version of the @command{gcc}
-command.
-
-In a non-Fortran installation, @command{gcc} recognizes C, C++,
-and Objective-C source files.
-
-In a GNU Fortran installation, @command{gcc} also recognizes Fortran source
-files and accepts Fortran-specific command-line options, plus some
-command-line options that are designed to cater to Fortran users
-but apply to other languages as well.
-
-@xref{G++ and GCC,,Programming Languages Supported by GCC,gcc,Using
-the GNU Compiler Collection (GCC)},
-for information on the way different languages are handled
-by the GCC compiler (@command{gcc}).
-
-@cindex @command{g77}, command
-@cindex commands, @command{g77}
-Also provided as part of GNU Fortran is the @command{g77} command.
-The @command{g77} command is designed to make compiling and linking Fortran
-programs somewhat easier than when using the @command{gcc} command for
-these tasks.
-It does this by analyzing the command line somewhat and changing it
-appropriately before submitting it to the @command{gcc} command.
-
-@cindex -v option
-@cindex @command{g77} options, -v
-@cindex options, -v
-Use the @option{-v} option with @command{g77}
-to see what is going on---the first line of output is the invocation
-of the @command{gcc} command.
-
-@include invoke.texi
-
-@include news.texi
-
-@set USERVISONLY
-@include news.texi
-@clear USERVISONLY
-
-@node Language
-@chapter The GNU Fortran Language
-
-@cindex standard, ANSI FORTRAN 77
-@cindex ANSI FORTRAN 77 standard
-@cindex reference works
-GNU Fortran supports a variety of extensions to, and dialects
-of, the Fortran language.
-Its primary base is the ANSI FORTRAN 77 standard, currently available on
-the network at
-@uref{http://www.fortran.com/fortran/F77_std/rjcnf0001.html}
-or as monolithic text at
-@uref{http://www.fortran.com/fortran/F77_std/f77_std.html}.
-It offers some extensions that are popular among users
-of UNIX @command{f77} and @command{f2c} compilers, some that
-are popular among users of other compilers (such as Digital
-products), some that are popular among users of the
-newer Fortran 90 standard, and some that are introduced
-by GNU Fortran.
-
-@cindex textbooks
-(If you need a text on Fortran,
-a few freely available electronic references have pointers from
-@uref{http://www.fortran.com/F/books.html}. There is a `cooperative
-net project', @cite{User Notes on Fortran Programming} at
-@uref{ftp://vms.huji.ac.il/fortran/} and mirrors elsewhere; some of this
-material might not apply specifically to @command{g77}.)
-
-Part of what defines a particular implementation of a Fortran
-system, such as @command{g77}, is the particular characteristics
-of how it supports types, constants, and so on.
-Much of this is left up to the implementation by the various
-Fortran standards and accepted practice in the industry.
-
-The GNU Fortran @emph{language} is described below.
-Much of the material is organized along the same lines
-as the ANSI FORTRAN 77 standard itself.
-
-@xref{Other Dialects}, for information on features @command{g77} supports
-that are not part of the GNU Fortran language.
-
-@emph{Note}: This portion of the documentation definitely needs a lot
-of work!
-
-@menu
-Relationship to the ANSI FORTRAN 77 standard:
-* Direction of Language Development:: Where GNU Fortran is headed.
-* Standard Support:: Degree of support for the standard.
-
-Extensions to the ANSI FORTRAN 77 standard:
-* Conformance::
-* Notation Used::
-* Terms and Concepts::
-* Characters Lines Sequence::
-* Data Types and Constants::
-* Expressions::
-* Specification Statements::
-* Control Statements::
-* Functions and Subroutines::
-* Scope and Classes of Names::
-* I/O::
-* Fortran 90 Features::
-@end menu
-
-@node Direction of Language Development
-@section Direction of Language Development
-@cindex direction of language development
-@cindex features, language
-@cindex language, features
-
-The purpose of the following description of the GNU Fortran
-language is to promote wide portability of GNU Fortran programs.
-
-GNU Fortran is an evolving language, due to the
-fact that @command{g77} itself is in beta test.
-Some current features of the language might later
-be redefined as dialects of Fortran supported by @command{g77}
-when better ways to express these features are added to @command{g77},
-for example.
-Such features would still be supported by
-@command{g77}, but would be available only when
-one or more command-line options were used.
-
-The GNU Fortran @emph{language} is distinct from the
-GNU Fortran @emph{compilation system} (@command{g77}).
-
-For example, @command{g77} supports various dialects of
-Fortran---in a sense, these are languages other than
-GNU Fortran---though its primary
-purpose is to support the GNU Fortran language, which also is
-described in its documentation and by its implementation.
-
-On the other hand, non-GNU compilers might offer
-support for the GNU Fortran language, and are encouraged
-to do so.
-
-Currently, the GNU Fortran language is a fairly fuzzy object.
-It represents something of a cross between what @command{g77} accepts
-when compiling using the prevailing defaults and what this
-document describes as being part of the language.
-
-Future versions of @command{g77} are expected to clarify the
-definition of the language in the documentation.
-Often, this will mean adding new features to the language, in the form
-of both new documentation and new support in @command{g77}.
-However, it might occasionally mean removing a feature
-from the language itself to ``dialect'' status.
-In such a case, the documentation would be adjusted
-to reflect the change, and @command{g77} itself would likely be changed
-to require one or more command-line options to continue supporting
-the feature.
-
-The development of the GNU Fortran language is intended to strike
-a balance between:
-
-@itemize @bullet
-@item
-Serving as a mostly-upwards-compatible language from the
-de facto UNIX Fortran dialect as supported by @command{f77}.
-
-@item
-Offering new, well-designed language features.
-Attributes of such features include
-not making existing code any harder to read
-(for those who might be unaware that the new
-features are not in use) and
-not making state-of-the-art
-compilers take longer to issue diagnostics,
-among others.
-
-@item
-Supporting existing, well-written code without gratuitously
-rejecting non-standard constructs, regardless of the origin
-of the code (its dialect).
-
-@item
-Offering default behavior and command-line options to reduce
-and, where reasonable, eliminate the need for programmers to make
-any modifications to code that already works in existing
-production environments.
-
-@item
-Diagnosing constructs that have different meanings in different
-systems, languages, and dialects, while offering clear,
-less ambiguous ways to express each of the different meanings
-so programmers can change their code appropriately.
-@end itemize
-
-One of the biggest practical challenges for the developers of the
-GNU Fortran language is meeting the sometimes contradictory demands
-of the above items.
-
-For example, a feature might be widely used in one popular environment,
-but the exact same code that utilizes that feature might not work
-as expected---perhaps it might mean something entirely different---in
-another popular environment.
-
-Traditionally, Fortran compilers---even portable ones---have solved this
-problem by simply offering the appropriate feature to users of
-the respective systems.
-This approach treats users of various Fortran systems and dialects
-as remote ``islands'', or camps, of programmers, and assume that these
-camps rarely come into contact with each other (or,
-especially, with each other's code).
-
-Project GNU takes a radically different approach to software and language
-design, in that it assumes that users of GNU software do not necessarily
-care what kind of underlying system they are using, regardless
-of whether they are using software (at the user-interface
-level) or writing it (for example, writing Fortran or C code).
-
-As such, GNU users rarely need consider just what kind of underlying
-hardware (or, in many cases, operating system) they are using at any
-particular time.
-They can use and write software designed for a general-purpose,
-widely portable, heterogeneous environment---the GNU environment.
-
-In line with this philosophy, GNU Fortran must evolve into a product
-that is widely ported and portable not only in the sense that it can
-be successfully built, installed, and run by users, but in the larger
-sense that its users can use it in the same way, and expect largely the
-same behaviors from it, regardless of the kind of system they are using
-at any particular time.
-
-This approach constrains the solutions @command{g77} can use to resolve
-conflicts between various camps of Fortran users.
-If these two camps disagree about what a particular construct should
-mean, @command{g77} cannot simply be changed to treat that particular construct as
-having one meaning without comment (such as a warning), lest the users
-expecting it to have the other meaning are unpleasantly surprised that
-their code misbehaves when executed.
-
-The use of the ASCII backslash character in character constants is
-an excellent (and still somewhat unresolved) example of this kind of
-controversy.
-@xref{Backslash in Constants}.
-Other examples are likely to arise in the future, as @command{g77} developers
-strive to improve its ability to accept an ever-wider variety of existing
-Fortran code without requiring significant modifications to said code.
-
-Development of GNU Fortran is further constrained by the desire
-to avoid requiring programmers to change their code.
-This is important because it allows programmers, administrators,
-and others to more faithfully evaluate and validate @command{g77}
-(as an overall product and as new versions are distributed)
-without having to support multiple versions of their programs
-so that they continue to work the same way on their existing
-systems (non-GNU perhaps, but possibly also earlier versions
-of @command{g77}).
-
-@node Standard Support
-@section ANSI FORTRAN 77 Standard Support
-@cindex ANSI FORTRAN 77 support
-@cindex standard, support for
-@cindex support, FORTRAN 77
-@cindex compatibility, FORTRAN 77
-@cindex FORTRAN 77 compatibility
-
-GNU Fortran supports ANSI FORTRAN 77 with the following caveats.
-In summary, the only ANSI FORTRAN 77 features @command{g77} doesn't
-support are those that are probably rarely used in actual code,
-some of which are explicitly disallowed by the Fortran 90 standard.
-
-@menu
-* No Passing External Assumed-length:: CHAR*(*) CFUNC restriction.
-* No Passing Dummy Assumed-length:: CHAR*(*) CFUNC restriction.
-* No Pathological Implied-DO:: No @samp{((@dots{}, I=@dots{}), I=@dots{})}.
-* No Useless Implied-DO:: No @samp{(A, I=1, 1)}.
-@end menu
-
-@node No Passing External Assumed-length
-@subsection No Passing External Assumed-length
-
-@command{g77} disallows passing of an external procedure
-as an actual argument if the procedure's
-type is declared @code{CHARACTER*(*)}. For example:
-
-@example
-CHARACTER*(*) CFUNC
-EXTERNAL CFUNC
-CALL FOO(CFUNC)
-END
-@end example
-
-@noindent
-It isn't clear whether the standard considers this conforming.
-
-@node No Passing Dummy Assumed-length
-@subsection No Passing Dummy Assumed-length
-
-@command{g77} disallows passing of a dummy procedure
-as an actual argument if the procedure's
-type is declared @code{CHARACTER*(*)}.
-
-@example
-SUBROUTINE BAR(CFUNC)
-CHARACTER*(*) CFUNC
-EXTERNAL CFUNC
-CALL FOO(CFUNC)
-END
-@end example
-
-@noindent
-It isn't clear whether the standard considers this conforming.
-
-@node No Pathological Implied-DO
-@subsection No Pathological Implied-DO
-
-The @code{DO} variable for an implied-@code{DO} construct in a
-@code{DATA} statement may not be used as the @code{DO} variable
-for an outer implied-@code{DO} construct. For example, this
-fragment is disallowed by @command{g77}:
-
-@smallexample
-DATA ((A(I, I), I= 1, 10), I= 1, 10) /@dots{}/
-@end smallexample
-
-@noindent
-This also is disallowed by Fortran 90, as it offers no additional
-capabilities and would have a variety of possible meanings.
-
-Note that it is @emph{very} unlikely that any production Fortran code
-tries to use this unsupported construct.
-
-@node No Useless Implied-DO
-@subsection No Useless Implied-DO
-
-An array element initializer in an implied-@code{DO} construct in a
-@code{DATA} statement must contain at least one reference to the @code{DO}
-variables of each outer implied-@code{DO} construct. For example,
-this fragment is disallowed by @command{g77}:
-
-@smallexample
-DATA (A, I= 1, 1) /1./
-@end smallexample
-
-@noindent
-This also is disallowed by Fortran 90, as FORTRAN 77's more permissive
-requirements offer no additional capabilities.
-However, @command{g77} doesn't necessarily diagnose all cases
-where this requirement is not met.
-
-Note that it is @emph{very} unlikely that any production Fortran code
-tries to use this unsupported construct.
-
-@node Conformance
-@section Conformance
-
-(The following information augments or overrides the information in
-Section 1.4 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 1 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-The definition of the GNU Fortran language is akin to that of
-the ANSI FORTRAN 77 language in that it does not generally require
-conforming implementations to diagnose cases where programs do
-not conform to the language.
-
-However, @command{g77} as a compiler is being developed in a way that
-is intended to enable it to diagnose such cases in an easy-to-understand
-manner.
-
-A program that conforms to the GNU Fortran language should, when
-compiled, linked, and executed using a properly installed @command{g77}
-system, perform as described by the GNU Fortran language definition.
-Reasons for different behavior include, among others:
-
-@itemize @bullet
-@item
-Use of resources (memory---heap, stack, and so on; disk space; CPU
-time; etc.) exceeds those of the system.
-
-@item
-Range and/or precision of calculations required by the program
-exceeds that of the system.
-
-@item
-Excessive reliance on behaviors that are system-dependent
-(non-portable Fortran code).
-
-@item
-Bugs in the program.
-
-@item
-Bug in @command{g77}.
-
-@item
-Bugs in the system.
-@end itemize
-
-Despite these ``loopholes'', the availability of a clear specification
-of the language of programs submitted to @command{g77}, as this document
-is intended to provide, is considered an important aspect of providing
-a robust, clean, predictable Fortran implementation.
-
-The definition of the GNU Fortran language, while having no special
-legal status, can therefore be viewed as a sort of contract, or agreement.
-This agreement says, in essence, ``if you write a program in this language,
-and run it in an environment (such as a @command{g77} system) that supports
-this language, the program should behave in a largely predictable way''.
-
-@node Notation Used
-@section Notation Used in This Chapter
-
-(The following information augments or overrides the information in
-Section 1.5 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 1 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-In this chapter, ``must'' denotes a requirement, ``may'' denotes permission,
-and ``must not'' and ``may not'' denote prohibition.
-Terms such as ``might'', ``should'', and ``can'' generally add little or
-nothing in the way of weight to the GNU Fortran language itself,
-but are used to explain or illustrate the language.
-
-For example:
-
-@display
-``The @code{FROBNITZ} statement must precede all executable
-statements in a program unit, and may not specify any dummy
-arguments. It may specify local or common variables and arrays.
-Its use should be limited to portions of the program designed to
-be non-portable and system-specific, because it might cause the
-containing program unit to behave quite differently on different
-systems.''
-@end display
-
-Insofar as the GNU Fortran language is specified,
-the requirements and permissions denoted by the above sample statement
-are limited to the placement of the statement and the kinds of
-things it may specify.
-The rest of the statement---the content regarding non-portable portions
-of the program and the differing behavior of program units containing
-the @code{FROBNITZ} statement---does not pertain the GNU Fortran
-language itself.
-That content offers advice and warnings about the @code{FROBNITZ}
-statement.
-
-@emph{Remember:} The GNU Fortran language definition specifies
-both what constitutes a valid GNU Fortran program and how,
-given such a program, a valid GNU Fortran implementation is
-to interpret that program.
-
-It is @emph{not} incumbent upon a valid GNU Fortran implementation
-to behave in any particular way, any consistent way, or any
-predictable way when it is asked to interpret input that is
-@emph{not} a valid GNU Fortran program.
-
-Such input is said to have @dfn{undefined} behavior when
-interpreted by a valid GNU Fortran implementation, though
-an implementation may choose to specify behaviors for some
-cases of inputs that are not valid GNU Fortran programs.
-
-Other notation used herein is that of the GNU texinfo format,
-which is used to generate printed hardcopy, on-line hypertext
-(Info), and on-line HTML versions, all from a single source
-document.
-This notation is used as follows:
-
-@itemize @bullet
-@item
-Keywords defined by the GNU Fortran language are shown
-in uppercase, as in: @code{COMMON}, @code{INTEGER}, and
-@code{BLOCK DATA}.
-
-Note that, in practice, many Fortran programs are written
-in lowercase---uppercase is used in this manual as a
-means to readily distinguish keywords and sample Fortran-related
-text from the prose in this document.
-
-@item
-Portions of actual sample program, input, or output text
-look like this: @samp{Actual program text}.
-
-Generally, uppercase is used for all Fortran-specific and
-Fortran-related text, though this does not always include
-literal text within Fortran code.
-
-For example: @samp{PRINT *, 'My name is Bob'}.
-
-@item
-A metasyntactic variable---that is, a name used in this document
-to serve as a placeholder for whatever text is used by the
-user or programmer---appears as shown in the following example:
-
-``The @code{INTEGER @var{ivar}} statement specifies that
-@var{ivar} is a variable or array of type @code{INTEGER}.''
-
-In the above example, any valid text may be substituted for
-the metasyntactic variable @var{ivar} to make the statement
-apply to a specific instance, as long as the same text is
-substituted for @emph{both} occurrences of @var{ivar}.
-
-@item
-Ellipses (``@dots{}'') are used to indicate further text that
-is either unimportant or expanded upon further, elsewhere.
-
-@item
-Names of data types are in the style of Fortran 90, in most
-cases.
-
-@xref{Kind Notation}, for information on the relationship
-between Fortran 90 nomenclature (such as @code{INTEGER(KIND=1)})
-and the more traditional, less portably concise nomenclature
-(such as @code{INTEGER*4}).
-@end itemize
-
-@node Terms and Concepts
-@section Fortran Terms and Concepts
-
-(The following information augments or overrides the information in
-Chapter 2 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 2 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-@menu
-* Syntactic Items::
-* Statements Comments Lines::
-* Scope of Names and Labels::
-@end menu
-
-@node Syntactic Items
-@subsection Syntactic Items
-
-(Corresponds to Section 2.2 of ANSI X3.9-1978 FORTRAN 77.)
-
-@cindex limits, lengths of names
-In GNU Fortran, a symbolic name is at least one character long,
-and has no arbitrary upper limit on length.
-However, names of entities requiring external linkage (such as
-external functions, external subroutines, and @code{COMMON} areas)
-might be restricted to some arbitrary length by the system.
-Such a restriction is no more constrained than that of one
-through six characters.
-
-Underscores (@samp{_}) are accepted in symbol names after the first
-character (which must be a letter).
-
-@node Statements Comments Lines
-@subsection Statements, Comments, and Lines
-
-(Corresponds to Section 2.3 of ANSI X3.9-1978 FORTRAN 77.)
-
-@cindex trailing comment
-@cindex comment
-@cindex characters, comment
-@cindex !
-@cindex exclamation point
-@cindex continuation character
-@cindex characters, continuation
-Use of an exclamation point (@samp{!}) to begin a
-trailing comment (a comment that extends to the end of the same
-source line) is permitted under the following conditions:
-
-@itemize @bullet
-@item
-The exclamation point does not appear in column 6.
-Otherwise, it is treated as an indicator of a continuation
-line.
-
-@item
-The exclamation point appears outside a character or Hollerith
-constant.
-Otherwise, the exclamation point is considered part of the
-constant.
-
-@item
-The exclamation point appears to the left of any other possible
-trailing comment.
-That is, a trailing comment may contain exclamation points
-in their commentary text.
-@end itemize
-
-@cindex ;
-@cindex semicolon
-@cindex statements, separated by semicolon
-Use of a semicolon (@samp{;}) as a statement separator
-is permitted under the following conditions:
-
-@itemize @bullet
-@item
-The semicolon appears outside a character or Hollerith
-constant.
-Otherwise, the semicolon is considered part of the
-constant.
-
-@item
-The semicolon appears to the left of a trailing comment.
-Otherwise, the semicolon is considered part of that
-comment.
-
-@item
-Neither a logical @code{IF} statement nor a non-construct
-@code{WHERE} statement (a Fortran 90 feature) may be
-followed (in the same, possibly continued, line) by
-a semicolon used as a statement separator.
-
-This restriction avoids the confusion
-that can result when reading a line such as:
-
-@smallexample
-IF (VALIDP) CALL FOO; CALL BAR
-@end smallexample
-
-@noindent
-Some readers might think the @samp{CALL BAR} is executed
-only if @samp{VALIDP} is @code{.TRUE.}, while others might
-assume its execution is unconditional.
-
-(At present, @command{g77} does not diagnose code that
-violates this restriction.)
-@end itemize
-
-@node Scope of Names and Labels
-@subsection Scope of Symbolic Names and Statement Labels
-@cindex scope
-
-(Corresponds to Section 2.9 of ANSI X3.9-1978 FORTRAN 77.)
-
-Included in the list of entities that have a scope of a
-program unit are construct names (a Fortran 90 feature).
-@xref{Construct Names}, for more information.
-
-@node Characters Lines Sequence
-@section Characters, Lines, and Execution Sequence
-
-(The following information augments or overrides the information in
-Chapter 3 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 3 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-@menu
-* Character Set::
-* Lines::
-* Continuation Line::
-* Statements::
-* Statement Labels::
-* Order::
-* INCLUDE::
-* Cpp-style directives::
-@end menu
-
-@node Character Set
-@subsection GNU Fortran Character Set
-@cindex characters
-
-(Corresponds to Section 3.1 of ANSI X3.9-1978 FORTRAN 77.)
-
-Letters include uppercase letters (the twenty-six characters
-of the English alphabet) and lowercase letters (their lowercase
-equivalent).
-Generally, lowercase letters may be used in place of uppercase
-letters, though in character and Hollerith constants, they
-are distinct.
-
-Special characters include:
-
-@itemize @bullet
-@item
-@cindex ;
-@cindex semicolon
-Semicolon (@samp{;})
-
-@item
-@cindex !
-@cindex exclamation point
-Exclamation point (@samp{!})
-
-@item
-@cindex "
-@cindex double quote
-Double quote (@samp{"})
-
-@item
-@cindex \
-@cindex backslash
-Backslash (@samp{\})
-
-@item
-@cindex ?
-@cindex question mark
-Question mark (@samp{?})
-
-@item
-@cindex #
-@cindex hash mark
-@cindex pound sign
-Hash mark (@samp{#})
-
-@item
-@cindex &
-@cindex ampersand
-Ampersand (@samp{&})
-
-@item
-@cindex %
-@cindex percent sign
-Percent sign (@samp{%})
-
-@item
-@cindex _
-@cindex underscore
-Underscore (@samp{_})
-
-@item
-@cindex <
-@cindex open angle
-@cindex left angle
-@cindex open bracket
-@cindex left bracket
-Open angle (@samp{<})
-
-@item
-@cindex >
-@cindex close angle
-@cindex right angle
-@cindex close bracket
-@cindex right bracket
-Close angle (@samp{>})
-
-@item
-The FORTRAN 77 special characters (@key{SPC}, @samp{=},
-@samp{+}, @samp{-}, @samp{*}, @samp{/}, @samp{(},
-@samp{)}, @samp{,}, @samp{.}, @samp{$}, @samp{'},
-and @samp{:})
-@end itemize
-
-@cindex blank
-@cindex space
-@cindex SPC
-Note that this document refers to @key{SPC} as @dfn{space},
-while X3.9-1978 FORTRAN 77 refers to it as @dfn{blank}.
-
-@node Lines
-@subsection Lines
-@cindex lines
-@cindex source file format
-@cindex source format
-@cindex file, source
-@cindex source code
-@cindex code, source
-@cindex fixed form
-@cindex free form
-
-(Corresponds to Section 3.2 of ANSI X3.9-1978 FORTRAN 77.)
-
-The way a Fortran compiler views source files depends entirely on the
-implementation choices made for the compiler, since those choices
-are explicitly left to the implementation by the published Fortran
-standards.
-
-The GNU Fortran language mandates a view applicable to UNIX-like
-text files---files that are made up of an arbitrary number of lines,
-each with an arbitrary number of characters (sometimes called stream-based
-files).
-
-This view does not apply to types of files that are specified as
-having a particular number of characters on every single line (sometimes
-referred to as record-based files).
-
-Because a ``line in a program unit is a sequence of 72 characters'',
-to quote X3.9-1978, the GNU Fortran language specifies that a
-stream-based text file is translated to GNU Fortran lines as follows:
-
-@itemize @bullet
-@item
-A newline in the file is the character that represents the end of
-a line of text to the underlying system.
-For example, on ASCII-based systems, a newline is the @key{NL}
-character, which has ASCII value 10 (decimal).
-
-@item
-Each newline in the file serves to end the line of text that precedes
-it (and that does not contain a newline).
-
-@item
-The end-of-file marker (@code{EOF}) also serves to end the line
-of text that precedes it (and that does not contain a newline).
-
-@item
-@cindex blank
-@cindex space
-@cindex SPC
-Any line of text that is shorter than 72 characters is padded to that length
-with spaces (called ``blanks'' in the standard).
-
-@item
-Any line of text that is longer than 72 characters is truncated to that
-length, but the truncated remainder must consist entirely of spaces.
-
-@item
-Characters other than newline and the GNU Fortran character set
-are invalid.
-@end itemize
-
-For the purposes of the remainder of this description of the GNU
-Fortran language, the translation described above has already
-taken place, unless otherwise specified.
-
-The result of the above translation is that the source file appears,
-in terms of the remainder of this description of the GNU Fortran language,
-as if it had an arbitrary
-number of 72-character lines, each character being among the GNU Fortran
-character set.
-
-For example, if the source file itself has two newlines in a row,
-the second newline becomes, after the above translation, a single
-line containing 72 spaces.
-
-@node Continuation Line
-@subsection Continuation Line
-@cindex continuation line, number of
-@cindex lines, continuation
-@cindex number of continuation lines
-@cindex limits, continuation lines
-
-(Corresponds to Section 3.2.3 of ANSI X3.9-1978 FORTRAN 77.)
-
-A continuation line is any line that both
-
-@itemize @bullet
-@item
-Contains a continuation character, and
-
-@item
-Contains only spaces in columns 1 through 5
-@end itemize
-
-A continuation character is any character of the GNU Fortran character set
-other than space (@key{SPC}) or zero (@samp{0})
-in column 6, or a digit (@samp{0} through @samp{9}) in column
-7 through 72 of a line that has only spaces to the left of that
-digit.
-
-The continuation character is ignored as far as the content of
-the statement is concerned.
-
-The GNU Fortran language places no limit on the number of
-continuation lines in a statement.
-In practice, the limit depends on a variety of factors, such as
-available memory, statement content, and so on, but no
-GNU Fortran system may impose an arbitrary limit.
-
-@node Statements
-@subsection Statements
-
-(Corresponds to Section 3.3 of ANSI X3.9-1978 FORTRAN 77.)
-
-Statements may be written using an arbitrary number of continuation
-lines.
-
-Statements may be separated using the semicolon (@samp{;}), except
-that the logical @code{IF} and non-construct @code{WHERE} statements
-may not be separated from subsequent statements using only a semicolon
-as statement separator.
-
-The @code{END PROGRAM}, @code{END SUBROUTINE}, @code{END FUNCTION},
-and @code{END BLOCK DATA} statements are alternatives to the @code{END}
-statement.
-These alternatives may be written as normal statements---they are not
-subject to the restrictions of the @code{END} statement.
-
-However, no statement other than @code{END} may have an initial line
-that appears to be an @code{END} statement---even @code{END PROGRAM},
-for example, must not be written as:
-
-@example
- END
- &PROGRAM
-@end example
-
-@node Statement Labels
-@subsection Statement Labels
-
-(Corresponds to Section 3.4 of ANSI X3.9-1978 FORTRAN 77.)
-
-A statement separated from its predecessor via a semicolon may be
-labeled as follows:
-
-@itemize @bullet
-@item
-The semicolon is followed by the label for the statement,
-which in turn follows the label.
-
-@item
-The label must be no more than five digits in length.
-
-@item
-The first digit of the label for the statement is not
-the first non-space character on a line.
-Otherwise, that character is treated as a continuation
-character.
-@end itemize
-
-A statement may have only one label defined for it.
-
-@node Order
-@subsection Order of Statements and Lines
-
-(Corresponds to Section 3.5 of ANSI X3.9-1978 FORTRAN 77.)
-
-Generally, @code{DATA} statements may precede executable statements.
-However, specification statements pertaining to any entities
-initialized by a @code{DATA} statement must precede that @code{DATA}
-statement.
-For example,
-after @samp{DATA I/1/}, @samp{INTEGER I} is not permitted, but
-@samp{INTEGER J} is permitted.
-
-The last line of a program unit may be an @code{END} statement,
-or may be:
-
-@itemize @bullet
-@item
-An @code{END PROGRAM} statement, if the program unit is a main program.
-
-@item
-An @code{END SUBROUTINE} statement, if the program unit is a subroutine.
-
-@item
-An @code{END FUNCTION} statement, if the program unit is a function.
-
-@item
-An @code{END BLOCK DATA} statement, if the program unit is a block data.
-@end itemize
-
-@node INCLUDE
-@subsection Including Source Text
-@cindex INCLUDE directive
-
-Additional source text may be included in the processing of
-the source file via the @code{INCLUDE} directive:
-
-@example
-INCLUDE @var{filename}
-@end example
-
-@noindent
-The source text to be included is identified by @var{filename},
-which is a literal GNU Fortran character constant.
-The meaning and interpretation of @var{filename} depends on the
-implementation, but typically is a filename.
-
-(@command{g77} treats it as a filename that it searches for
-in the current directory and/or directories specified
-via the @option{-I} command-line option.)
-
-The effect of the @code{INCLUDE} directive is as if the
-included text directly replaced the directive in the source
-file prior to interpretation of the program.
-Included text may itself use @code{INCLUDE}.
-The depth of nested @code{INCLUDE} references depends on
-the implementation, but typically is a positive integer.
-
-This virtual replacement treats the statements and @code{INCLUDE}
-directives in the included text as syntactically distinct from
-those in the including text.
-
-Therefore, the first non-comment line of the included text
-must not be a continuation line.
-The included text must therefore have, after the non-comment
-lines, either an initial line (statement), an @code{INCLUDE}
-directive, or nothing (the end of the included text).
-
-Similarly, the including text may end the @code{INCLUDE}
-directive with a semicolon or the end of the line, but it
-cannot follow an @code{INCLUDE} directive at the end of its
-line with a continuation line.
-Thus, the last statement in an included text may not be
-continued.
-
-Any statements between two @code{INCLUDE} directives on the
-same line are treated as if they appeared in between the
-respective included texts.
-For example:
-
-@smallexample
-INCLUDE 'A'; PRINT *, 'B'; INCLUDE 'C'; END PROGRAM
-@end smallexample
-
-@noindent
-If the text included by @samp{INCLUDE 'A'} constitutes
-a @samp{PRINT *, 'A'} statement and the text included by
-@samp{INCLUDE 'C'} constitutes a @samp{PRINT *, 'C'} statement,
-then the output of the above sample program would be
-
-@example
-A
-B
-C
-@end example
-
-@noindent
-(with suitable allowances for how an implementation defines
-its handling of output).
-
-Included text must not include itself directly or indirectly,
-regardless of whether the @var{filename} used to reference
-the text is the same.
-
-Note that @code{INCLUDE} is @emph{not} a statement.
-As such, it is neither a non-executable or executable
-statement.
-However, if the text it includes constitutes one or more
-executable statements, then the placement of @code{INCLUDE}
-is subject to effectively the same restrictions as those
-on executable statements.
-
-An @code{INCLUDE} directive may be continued across multiple
-lines as if it were a statement.
-This permits long names to be used for @var{filename}.
-
-@node Cpp-style directives
-@subsection Cpp-style directives
-@cindex #
-@cindex preprocessor
-
-@code{cpp} output-style @code{#} directives
-(@pxref{C Preprocessor Output,,, cpp, The C Preprocessor})
-are recognized by the compiler even
-when the preprocessor isn't run on the input (as it is when compiling
-@samp{.F} files). (Note the distinction between these @command{cpp}
-@code{#} @emph{output} directives and @code{#line} @emph{input}
-directives.)
-
-@node Data Types and Constants
-@section Data Types and Constants
-
-(The following information augments or overrides the information in
-Chapter 4 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 4 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-To more concisely express the appropriate types for
-entities, this document uses the more concise
-Fortran 90 nomenclature such as @code{INTEGER(KIND=1)}
-instead of the more traditional, but less portably concise,
-byte-size-based nomenclature such as @code{INTEGER*4},
-wherever reasonable.
-
-When referring to generic types---in contexts where the
-specific precision and range of a type are not important---this
-document uses the generic type names @code{INTEGER}, @code{LOGICAL},
-@code{REAL}, @code{COMPLEX}, and @code{CHARACTER}.
-
-In some cases, the context requires specification of a
-particular type.
-This document uses the @samp{KIND=} notation to accomplish
-this throughout, sometimes supplying the more traditional
-notation for clarification, though the traditional notation
-might not work the same way on all GNU Fortran implementations.
-
-Use of @samp{KIND=} makes this document more concise because
-@command{g77} is able to define values for @samp{KIND=} that
-have the same meanings on all systems, due to the way the
-Fortran 90 standard specifies these values are to be used.
-
-(In particular, that standard permits an implementation to
-arbitrarily assign nonnegative values.
-There are four distinct sets of assignments: one to the @code{CHARACTER}
-type; one to the @code{INTEGER} type; one to the @code{LOGICAL} type;
-and the fourth to both the @code{REAL} and @code{COMPLEX} types.
-Implementations are free to assign these values in any order,
-leave gaps in the ordering of assignments, and assign more than
-one value to a representation.)
-
-This makes @samp{KIND=} values superior to the values used
-in non-standard statements such as @samp{INTEGER*4}, because
-the meanings of the values in those statements vary from machine
-to machine, compiler to compiler, even operating system to
-operating system.
-
-However, use of @samp{KIND=} is @emph{not} generally recommended
-when writing portable code (unless, for example, the code is
-going to be compiled only via @command{g77}, which is a widely
-ported compiler).
-GNU Fortran does not yet have adequate language constructs to
-permit use of @samp{KIND=} in a fashion that would make the
-code portable to Fortran 90 implementations; and, this construct
-is known to @emph{not} be accepted by many popular FORTRAN 77
-implementations, so it cannot be used in code that is to be ported
-to those.
-
-The distinction here is that this document is able to use
-specific values for @samp{KIND=} to concisely document the
-types of various operations and operands.
-
-A Fortran program should use the FORTRAN 77 designations for the
-appropriate GNU Fortran types---such as @code{INTEGER} for
-@code{INTEGER(KIND=1)}, @code{REAL} for @code{REAL(KIND=1)},
-and @code{DOUBLE COMPLEX} for @code{COMPLEX(KIND=2)}---and,
-where no such designations exist, make use of appropriate
-techniques (preprocessor macros, parameters, and so on)
-to specify the types in a fashion that may be easily adjusted
-to suit each particular implementation to which the program
-is ported.
-(These types generally won't need to be adjusted for ports of
-@command{g77}.)
-
-Further details regarding GNU Fortran data types and constants
-are provided below.
-
-@menu
-* Types::
-* Constants::
-* Integer Type::
-* Character Type::
-@end menu
-
-@node Types
-@subsection Data Types
-
-(Corresponds to Section 4.1 of ANSI X3.9-1978 FORTRAN 77.)
-
-GNU Fortran supports these types:
-
-@enumerate
-@item
-Integer (generic type @code{INTEGER})
-
-@item
-Real (generic type @code{REAL})
-
-@item
-Double precision
-
-@item
-Complex (generic type @code{COMPLEX})
-
-@item
-Logical (generic type @code{LOGICAL})
-
-@item
-Character (generic type @code{CHARACTER})
-
-@item
-Double Complex
-@end enumerate
-
-(The types numbered 1 through 6 above are standard FORTRAN 77 types.)
-
-The generic types shown above are referred to in this document
-using only their generic type names.
-Such references usually indicate that any specific type (kind)
-of that generic type is valid.
-
-For example, a context described in this document as accepting
-the @code{COMPLEX} type also is likely to accept the
-@code{DOUBLE COMPLEX} type.
-
-The GNU Fortran language supports three ways to specify
-a specific kind of a generic type.
-
-@menu
-* Double Notation:: As in @code{DOUBLE COMPLEX}.
-* Star Notation:: As in @code{INTEGER*4}.
-* Kind Notation:: As in @code{INTEGER(KIND=1)}.
-@end menu
-
-@node Double Notation
-@subsubsection Double Notation
-
-The GNU Fortran language supports two uses of the keyword
-@code{DOUBLE} to specify a specific kind of type:
-
-@itemize @bullet
-@item
-@code{DOUBLE PRECISION}, equivalent to @code{REAL(KIND=2)}
-
-@item
-@code{DOUBLE COMPLEX}, equivalent to @code{COMPLEX(KIND=2)}
-@end itemize
-
-Use one of the above forms where a type name is valid.
-
-While use of this notation is popular, it doesn't scale
-well in a language or dialect rich in intrinsic types,
-as is the case for the GNU Fortran language (especially
-planned future versions of it).
-
-After all, one rarely sees type names such as @samp{DOUBLE INTEGER},
-@samp{QUADRUPLE REAL}, or @samp{QUARTER INTEGER}.
-Instead, @code{INTEGER*8}, @code{REAL*16}, and @code{INTEGER*1}
-often are substituted for these, respectively, even though they
-do not always have the same meanings on all systems.
-(And, the fact that @samp{DOUBLE REAL} does not exist as such
-is an inconsistency.)
-
-Therefore, this document uses ``double notation'' only on occasion
-for the benefit of those readers who are accustomed to it.
-
-@node Star Notation
-@subsubsection Star Notation
-@cindex *@var{n} notation
-
-The following notation specifies the storage size for a type:
-
-@smallexample
-@var{generic-type}*@var{n}
-@end smallexample
-
-@noindent
-@var{generic-type} must be a generic type---one of
-@code{INTEGER}, @code{REAL}, @code{COMPLEX}, @code{LOGICAL},
-or @code{CHARACTER}.
-@var{n} must be one or more digits comprising a decimal
-integer number greater than zero.
-
-Use the above form where a type name is valid.
-
-The @samp{*@var{n}} notation specifies that the amount of storage
-occupied by variables and array elements of that type is @var{n}
-times the storage occupied by a @code{CHARACTER*1} variable.
-
-This notation might indicate a different degree of precision and/or
-range for such variables and array elements, and the functions that
-return values of types using this notation.
-It does not limit the precision or range of values of that type
-in any particular way---use explicit code to do that.
-
-Further, the GNU Fortran language requires no particular values
-for @var{n} to be supported by an implementation via the @samp{*@var{n}}
-notation.
-@command{g77} supports @code{INTEGER*1} (as @code{INTEGER(KIND=3)})
-on all systems, for example,
-but not all implementations are required to do so, and @command{g77}
-is known to not support @code{REAL*1} on most (or all) systems.
-
-As a result, except for @var{generic-type} of @code{CHARACTER},
-uses of this notation should be limited to isolated
-portions of a program that are intended to handle system-specific
-tasks and are expected to be non-portable.
-
-(Standard FORTRAN 77 supports the @samp{*@var{n}} notation for
-only @code{CHARACTER}, where it signifies not only the amount
-of storage occupied, but the number of characters in entities
-of that type.
-However, almost all Fortran compilers have supported this
-notation for generic types, though with a variety of meanings
-for @var{n}.)
-
-Specifications of types using the @samp{*@var{n}} notation
-always are interpreted as specifications of the appropriate
-types described in this document using the @samp{KIND=@var{n}}
-notation, described below.
-
-While use of this notation is popular, it doesn't serve well
-in the context of a widely portable dialect of Fortran, such as
-the GNU Fortran language.
-
-For example, even on one particular machine, two or more popular
-Fortran compilers might well disagree on the size of a type
-declared @code{INTEGER*2} or @code{REAL*16}.
-Certainly there
-is known to be disagreement over such things among Fortran
-compilers on @emph{different} systems.
-
-Further, this notation offers no elegant way to specify sizes
-that are not even multiples of the ``byte size'' typically
-designated by @code{INTEGER*1}.
-Use of ``absurd'' values (such as @code{INTEGER*1000}) would
-certainly be possible, but would perhaps be stretching the original
-intent of this notation beyond the breaking point in terms
-of widespread readability of documentation and code making use
-of it.
-
-Therefore, this document uses ``star notation'' only on occasion
-for the benefit of those readers who are accustomed to it.
-
-@node Kind Notation
-@subsubsection Kind Notation
-@cindex KIND= notation
-
-The following notation specifies the kind-type selector of a type:
-
-@smallexample
-@var{generic-type}(KIND=@var{n})
-@end smallexample
-
-@noindent
-Use the above form where a type name is valid.
-
-@var{generic-type} must be a generic type---one of
-@code{INTEGER}, @code{REAL}, @code{COMPLEX}, @code{LOGICAL},
-or @code{CHARACTER}.
-@var{n} must be an integer initialization expression that
-is a positive, nonzero value.
-
-Programmers are discouraged from writing these values directly
-into their code.
-Future versions of the GNU Fortran language will offer
-facilities that will make the writing of code portable
-to @command{g77} @emph{and} Fortran 90 implementations simpler.
-
-However, writing code that ports to existing FORTRAN 77
-implementations depends on avoiding the @samp{KIND=} construct.
-
-The @samp{KIND=} construct is thus useful in the context
-of GNU Fortran for two reasons:
-
-@itemize @bullet
-@item
-It provides a means to specify a type in a fashion that
-is portable across all GNU Fortran implementations (though
-not other FORTRAN 77 and Fortran 90 implementations).
-
-@item
-It provides a sort of Rosetta stone for this document to use
-to concisely describe the types of various operations and
-operands.
-@end itemize
-
-The values of @var{n} in the GNU Fortran language are
-assigned using a scheme that:
-
-@itemize @bullet
-@item
-Attempts to maximize the ability of readers
-of this document to quickly familiarize themselves
-with assignments for popular types
-
-@item
-Provides a unique value for each specific desired
-meaning
-
-@item
-Provides a means to automatically assign new values so
-they have a ``natural'' relationship to existing values,
-if appropriate, or, if no such relationship exists, will
-not interfere with future values assigned on the basis
-of such relationships
-
-@item
-Avoids using values that are similar to values used
-in the existing, popular @samp{*@var{n}} notation,
-to prevent readers from expecting that these implied
-correspondences work on all GNU Fortran implementations
-@end itemize
-
-The assignment system accomplishes this by assigning
-to each ``fundamental meaning'' of a specific type a
-unique prime number.
-Combinations of fundamental meanings---for example, a type
-that is two times the size of some other type---are assigned
-values of @var{n} that are the products of the values for
-those fundamental meanings.
-
-A prime value of @var{n} is never given more than one fundamental
-meaning, to avoid situations where some code or system
-cannot reasonably provide those meanings in the form of a
-single type.
-
-The values of @var{n} assigned so far are:
-
-@table @code
-@item KIND=0
-This value is reserved for future use.
-
-The planned future use is for this value to designate,
-explicitly, context-sensitive kind-type selection.
-For example, the expression @samp{1D0 * 0.1_0} would
-be equivalent to @samp{1D0 * 0.1D0}.
-
-@item KIND=1
-This corresponds to the default types for
-@code{REAL}, @code{INTEGER}, @code{LOGICAL}, @code{COMPLEX},
-and @code{CHARACTER}, as appropriate.
-
-These are the ``default'' types described in the Fortran 90 standard,
-though that standard does not assign any particular @samp{KIND=}
-value to these types.
-
-(Typically, these are @code{REAL*4}, @code{INTEGER*4},
-@code{LOGICAL*4}, and @code{COMPLEX*8}.)
-
-@item KIND=2
-This corresponds to types that occupy twice as much
-storage as the default types.
-@code{REAL(KIND=2)} is @code{DOUBLE PRECISION} (typically @code{REAL*8}),
-@code{COMPLEX(KIND=2)} is @code{DOUBLE COMPLEX} (typically @code{COMPLEX*16}),
-
-These are the ``double precision'' types described in the Fortran 90
-standard,
-though that standard does not assign any particular @samp{KIND=}
-value to these types.
-
-@var{n} of 4 thus corresponds to types that occupy four times
-as much storage as the default types, @var{n} of 8 to types that
-occupy eight times as much storage, and so on.
-
-The @code{INTEGER(KIND=2)} and @code{LOGICAL(KIND=2)} types
-are not necessarily supported by every GNU Fortran implementation.
-
-@item KIND=3
-This corresponds to types that occupy as much
-storage as the default @code{CHARACTER} type,
-which is the same effective type as @code{CHARACTER(KIND=1)}
-(making that type effectively the same as @code{CHARACTER(KIND=3)}).
-
-(Typically, these are @code{INTEGER*1} and @code{LOGICAL*1}.)
-
-@var{n} of 6 thus corresponds to types that occupy twice as
-much storage as the @var{n}=3 types, @var{n} of 12 to types
-that occupy four times as much storage, and so on.
-
-These are not necessarily supported by every GNU Fortran
-implementation.
-
-@item KIND=5
-This corresponds to types that occupy half the
-storage as the default (@var{n}=1) types.
-
-(Typically, these are @code{INTEGER*2} and @code{LOGICAL*2}.)
-
-@var{n} of 25 thus corresponds to types that occupy one-quarter
-as much storage as the default types.
-
-These are not necessarily supported by every GNU Fortran
-implementation.
-
-@item KIND=7
-@cindex pointers
-This is valid only as @code{INTEGER(KIND=7)} and
-denotes the @code{INTEGER} type that has the smallest
-storage size that holds a pointer on the system.
-
-A pointer representable by this type is capable of uniquely
-addressing a @code{CHARACTER*1} variable, array, array element,
-or substring.
-
-(Typically this is equivalent to @code{INTEGER*4} or,
-on 64-bit systems, @code{INTEGER*8}.
-In a compatible C implementation, it typically would
-be the same size and semantics of the C type @code{void *}.)
-@end table
-
-Note that these are @emph{proposed} correspondences and might change
-in future versions of @command{g77}---avoid writing code depending
-on them while @command{g77}, and therefore the GNU Fortran language
-it defines, is in beta testing.
-
-Values not specified in the above list are reserved to
-future versions of the GNU Fortran language.
-
-Implementation-dependent meanings will be assigned new,
-unique prime numbers so as to not interfere with other
-implementation-dependent meanings, and offer the possibility
-of increasing the portability of code depending on such
-types by offering support for them in other GNU Fortran
-implementations.
-
-Other meanings that might be given unique values are:
-
-@itemize @bullet
-@item
-Types that make use of only half their storage size for
-representing precision and range.
-
-For example, some compilers offer options that cause
-@code{INTEGER} types to occupy the amount of storage
-that would be needed for @code{INTEGER(KIND=2)} types, but the
-range remains that of @code{INTEGER(KIND=1)}.
-
-@item
-The IEEE single floating-point type.
-
-@item
-Types with a specific bit pattern (endianness), such as the
-little-endian form of @code{INTEGER(KIND=1)}.
-These could permit, conceptually, use of portable code and
-implementations on data files written by existing systems.
-@end itemize
-
-Future @emph{prime} numbers should be given meanings in as incremental
-a fashion as possible, to allow for flexibility and
-expressiveness in combining types.
-
-For example, instead of defining a prime number for little-endian
-IEEE doubles, one prime number might be assigned the meaning
-``little-endian'', another the meaning ``IEEE double'', and the
-value of @var{n} for a little-endian IEEE double would thus
-naturally be the product of those two respective assigned values.
-(It could even be reasonable to have IEEE values result from the
-products of prime values denoting exponent and fraction sizes
-and meanings, hidden bit usage, availability and representations
-of special values such as subnormals, infinities, and Not-A-Numbers
-(NaNs), and so on.)
-
-This assignment mechanism, while not inherently required for
-future versions of the GNU Fortran language, is worth using
-because it could ease management of the ``space'' of supported
-types much easier in the long run.
-
-The above approach suggests a mechanism for specifying inheritance
-of intrinsic (built-in) types for an entire, widely portable
-product line.
-It is certainly reasonable that, unlike programmers of other languages
-offering inheritance mechanisms that employ verbose names for classes
-and subclasses, along with graphical browsers to elucidate the
-relationships, Fortran programmers would employ
-a mechanism that works by multiplying prime numbers together
-and finding the prime factors of such products.
-
-Most of the advantages for the above scheme have been explained
-above.
-One disadvantage is that it could lead to the defining,
-by the GNU Fortran language, of some fairly large prime numbers.
-This could lead to the GNU Fortran language being declared
-``munitions'' by the United States Department of Defense.
-
-@node Constants
-@subsection Constants
-@cindex constants
-@cindex types, constants
-
-(Corresponds to Section 4.2 of ANSI X3.9-1978 FORTRAN 77.)
-
-A @dfn{typeless constant} has one of the following forms:
-
-@smallexample
-'@var{binary-digits}'B
-'@var{octal-digits}'O
-'@var{hexadecimal-digits}'Z
-'@var{hexadecimal-digits}'X
-@end smallexample
-
-@noindent
-@var{binary-digits}, @var{octal-digits}, and @var{hexadecimal-digits}
-are nonempty strings of characters in the set @samp{01}, @samp{01234567},
-and @samp{0123456789ABCDEFabcdef}, respectively.
-(The value for @samp{A} (and @samp{a}) is 10, for @samp{B} and @samp{b}
-is 11, and so on.)
-
-A prefix-radix constant, such as @samp{Z'ABCD'}, can optionally be
-treated as typeless. @xref{Fortran Dialect Options,, Options
-Controlling Fortran Dialect}, for information on the
-@option{-ftypeless-boz} option.
-
-Typeless constants have values that depend on the context in which
-they are used.
-
-All other constants, called @dfn{typed constants}, are interpreted---converted
-to internal form---according to their inherent type.
-Thus, context is @emph{never} a determining factor for the type, and hence
-the interpretation, of a typed constant.
-(All constants in the ANSI FORTRAN 77 language are typed constants.)
-
-For example, @samp{1} is always type @code{INTEGER(KIND=1)} in GNU
-Fortran (called default INTEGER in Fortran 90),
-@samp{9.435784839284958} is always type @code{REAL(KIND=1)} (even if the
-additional precision specified is lost, and even when used in a
-@code{REAL(KIND=2)} context), @samp{1E0} is always type @code{REAL(KIND=2)},
-and @samp{1D0} is always type @code{REAL(KIND=2)}.
-
-@node Integer Type
-@subsection Integer Type
-
-(Corresponds to Section 4.3 of ANSI X3.9-1978 FORTRAN 77.)
-
-An integer constant also may have one of the following forms:
-
-@smallexample
-B'@var{binary-digits}'
-O'@var{octal-digits}'
-Z'@var{hexadecimal-digits}'
-X'@var{hexadecimal-digits}'
-@end smallexample
-
-@noindent
-@var{binary-digits}, @var{octal-digits}, and @var{hexadecimal-digits}
-are nonempty strings of characters in the set @samp{01}, @samp{01234567},
-and @samp{0123456789ABCDEFabcdef}, respectively.
-(The value for @samp{A} (and @samp{a}) is 10, for @samp{B} and @samp{b}
-is 11, and so on.)
-
-@node Character Type
-@subsection Character Type
-
-(Corresponds to Section 4.8 of ANSI X3.9-1978 FORTRAN 77.)
-
-@cindex double quoted character constants
-A character constant may be delimited by a pair of double quotes
-(@samp{"}) instead of apostrophes.
-In this case, an apostrophe within the constant represents
-a single apostrophe, while a double quote is represented in
-the source text of the constant by two consecutive double
-quotes with no intervening spaces.
-
-@cindex zero-length CHARACTER
-@cindex null CHARACTER strings
-@cindex empty CHARACTER strings
-@cindex strings, empty
-@cindex CHARACTER, null
-A character constant may be empty (have a length of zero).
-
-A character constant may include a substring specification,
-The value of such a constant is the value of the substring---for
-example, the value of @samp{'hello'(3:5)} is the same
-as the value of @samp{'llo'}.
-
-@node Expressions
-@section Expressions
-
-(The following information augments or overrides the information in
-Chapter 6 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 6 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-@menu
-* %LOC()::
-@end menu
-
-@node %LOC()
-@subsection The @code{%LOC()} Construct
-@cindex %LOC() construct
-
-@example
-%LOC(@var{arg})
-@end example
-
-The @code{%LOC()} construct is an expression
-that yields the value of the location of its argument,
-@var{arg}, in memory.
-The size of the type of the expression depends on the system---typically,
-it is equivalent to either @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=2)},
-though it is actually type @code{INTEGER(KIND=7)}.
-
-The argument to @code{%LOC()} must be suitable as the
-left-hand side of an assignment statement.
-That is, it may not be a general expression involving
-operators such as addition, subtraction, and so on,
-nor may it be a constant.
-
-Use of @code{%LOC()} is recommended only for code that
-is accessing facilities outside of GNU Fortran, such as
-operating system or windowing facilities.
-It is best to constrain such uses to isolated portions of
-a program---portions that deal specifically and exclusively
-with low-level, system-dependent facilities.
-Such portions might well provide a portable interface for
-use by the program as a whole, but are themselves not
-portable, and should be thoroughly tested each time they
-are rebuilt using a new compiler or version of a compiler.
-
-Do not depend on @code{%LOC()} returning a pointer that
-can be safely used to @emph{define} (change) the argument.
-While this might work in some circumstances, it is hard
-to predict whether it will continue to work when a program
-(that works using this unsafe behavior)
-is recompiled using different command-line options or
-a different version of @command{g77}.
-
-Generally, @code{%LOC()} is safe when used as an argument
-to a procedure that makes use of the value of the corresponding
-dummy argument only during its activation, and only when
-such use is restricted to referencing (reading) the value
-of the argument to @code{%LOC()}.
-
-@emph{Implementation Note:} Currently, @command{g77} passes
-arguments (those not passed using a construct such as @code{%VAL()})
-by reference or descriptor, depending on the type of
-the actual argument.
-Thus, given @samp{INTEGER I}, @samp{CALL FOO(I)} would
-seem to mean the same thing as @samp{CALL FOO(%VAL(%LOC(I)))}, and
-in fact might compile to identical code.
-
-However, @samp{CALL FOO(%VAL(%LOC(I)))} emphatically means
-``pass, by value, the address of @samp{I} in memory''.
-While @samp{CALL FOO(I)} might use that same approach in a
-particular version of @command{g77}, another version or compiler
-might choose a different implementation, such as copy-in/copy-out,
-to effect the desired behavior---and which will therefore not
-necessarily compile to the same code as would
-@samp{CALL FOO(%VAL(%LOC(I)))}
-using the same version or compiler.
-
-@xref{Debugging and Interfacing}, for detailed information on
-how this particular version of @command{g77} implements various
-constructs.
-
-@node Specification Statements
-@section Specification Statements
-
-(The following information augments or overrides the information in
-Chapter 8 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 8 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-@menu
-* NAMELIST::
-* DOUBLE COMPLEX::
-@end menu
-
-@node NAMELIST
-@subsection @code{NAMELIST} Statement
-@cindex NAMELIST statement
-@cindex statements, NAMELIST
-
-The @code{NAMELIST} statement, and related I/O constructs, are
-supported by the GNU Fortran language in essentially the same
-way as they are by @command{f2c}.
-
-This follows Fortran 90 with the restriction that on @code{NAMELIST}
-input, subscripts must have the form
-@smallexample
-@var{subscript} [ @code{:} @var{subscript} [ @code{:} @var{stride}]]
-@end smallexample
-i.e.@:
-@smallexample
-&xx x(1:3,8:10:2)=1,2,3,4,5,6/
-@end smallexample
-is allowed, but not, say,
-@smallexample
-&xx x(:3,8::2)=1,2,3,4,5,6/
-@end smallexample
-
-As an extension of the Fortran 90 form, @code{$} and @code{$END} may be
-used in place of @code{&} and @code{/} in @code{NAMELIST} input, so that
-@smallexample
-$&xx x(1:3,8:10:2)=1,2,3,4,5,6 $end
-@end smallexample
-could be used instead of the example above.
-
-@node DOUBLE COMPLEX
-@subsection @code{DOUBLE COMPLEX} Statement
-@cindex DOUBLE COMPLEX
-
-@code{DOUBLE COMPLEX} is a type-statement (and type) that
-specifies the type @code{COMPLEX(KIND=2)} in GNU Fortran.
-
-@node Control Statements
-@section Control Statements
-
-(The following information augments or overrides the information in
-Chapter 11 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 11 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-@menu
-* DO WHILE::
-* END DO::
-* Construct Names::
-* CYCLE and EXIT::
-@end menu
-
-@node DO WHILE
-@subsection DO WHILE
-@cindex DO WHILE
-@cindex DO
-@cindex MIL-STD 1753
-
-The @code{DO WHILE} statement, a feature of both the MIL-STD 1753 and
-Fortran 90 standards, is provided by the GNU Fortran language.
-The Fortran 90 ``do forever'' statement comprising just @code{DO} is
-also supported.
-
-@node END DO
-@subsection END DO
-@cindex END DO
-@cindex MIL-STD 1753
-
-The @code{END DO} statement is provided by the GNU Fortran language.
-
-This statement is used in one of two ways:
-
-@itemize @bullet
-@item
-The Fortran 90 meaning, in which it specifies the termination
-point of a single @code{DO} loop started with a @code{DO} statement
-that specifies no termination label.
-
-@item
-The MIL-STD 1753 meaning, in which it specifies the termination
-point of one or more @code{DO} loops, all of which start with a
-@code{DO} statement that specify the label defined for the
-@code{END DO} statement.
-
-This kind of @code{END DO} statement is merely a synonym for
-@code{CONTINUE}, except it is permitted only when the statement
-is labeled and a target of one or more labeled @code{DO} loops.
-
-It is expected that this use of @code{END DO} will be removed from
-the GNU Fortran language in the future, though it is likely that
-it will long be supported by @command{g77} as a dialect form.
-@end itemize
-
-@node Construct Names
-@subsection Construct Names
-@cindex construct names
-
-The GNU Fortran language supports construct names as defined
-by the Fortran 90 standard.
-These names are local to the program unit and are defined
-as follows:
-
-@smallexample
-@var{construct-name}: @var{block-statement}
-@end smallexample
-
-@noindent
-Here, @var{construct-name} is the construct name itself;
-its definition is connoted by the single colon (@samp{:}); and
-@var{block-statement} is an @code{IF}, @code{DO},
-or @code{SELECT CASE} statement that begins a block.
-
-A block that is given a construct name must also specify the
-same construct name in its termination statement:
-
-@example
-END @var{block} @var{construct-name}
-@end example
-
-@noindent
-Here, @var{block} must be @code{IF}, @code{DO}, or @code{SELECT},
-as appropriate.
-
-@node CYCLE and EXIT
-@subsection The @code{CYCLE} and @code{EXIT} Statements
-
-@cindex CYCLE statement
-@cindex EXIT statement
-@cindex statements, CYCLE
-@cindex statements, EXIT
-The @code{CYCLE} and @code{EXIT} statements specify that
-the remaining statements in the current iteration of a
-particular active (enclosing) @code{DO} loop are to be skipped.
-
-@code{CYCLE} specifies that these statements are skipped,
-but the @code{END DO} statement that marks the end of the
-@code{DO} loop be executed---that is, the next iteration,
-if any, is to be started.
-If the statement marking the end of the @code{DO} loop is
-not @code{END DO}---in other words, if the loop is not
-a block @code{DO}---the @code{CYCLE} statement does not
-execute that statement, but does start the next iteration (if any).
-
-@code{EXIT} specifies that the loop specified by the
-@code{DO} construct is terminated.
-
-The @code{DO} loop affected by @code{CYCLE} and @code{EXIT}
-is the innermost enclosing @code{DO} loop when the following
-forms are used:
-
-@example
-CYCLE
-EXIT
-@end example
-
-Otherwise, the following forms specify the construct name
-of the pertinent @code{DO} loop:
-
-@example
-CYCLE @var{construct-name}
-EXIT @var{construct-name}
-@end example
-
-@code{CYCLE} and @code{EXIT} can be viewed as glorified @code{GO TO}
-statements.
-However, they cannot be easily thought of as @code{GO TO} statements
-in obscure cases involving FORTRAN 77 loops.
-For example:
-
-@smallexample
- DO 10 I = 1, 5
- DO 10 J = 1, 5
- IF (J .EQ. 5) EXIT
- DO 10 K = 1, 5
- IF (K .EQ. 3) CYCLE
-10 PRINT *, 'I=', I, ' J=', J, ' K=', K
-20 CONTINUE
-@end smallexample
-
-@noindent
-In particular, neither the @code{EXIT} nor @code{CYCLE} statements
-above are equivalent to a @code{GO TO} statement to either label
-@samp{10} or @samp{20}.
-
-To understand the effect of @code{CYCLE} and @code{EXIT} in the
-above fragment, it is helpful to first translate it to its equivalent
-using only block @code{DO} loops:
-
-@smallexample
- DO I = 1, 5
- DO J = 1, 5
- IF (J .EQ. 5) EXIT
- DO K = 1, 5
- IF (K .EQ. 3) CYCLE
-10 PRINT *, 'I=', I, ' J=', J, ' K=', K
- END DO
- END DO
- END DO
-20 CONTINUE
-@end smallexample
-
-Adding new labels allows translation of @code{CYCLE} and @code{EXIT}
-to @code{GO TO} so they may be more easily understood by programmers
-accustomed to FORTRAN coding:
-
-@smallexample
- DO I = 1, 5
- DO J = 1, 5
- IF (J .EQ. 5) GOTO 18
- DO K = 1, 5
- IF (K .EQ. 3) GO TO 12
-10 PRINT *, 'I=', I, ' J=', J, ' K=', K
-12 END DO
- END DO
-18 END DO
-20 CONTINUE
-@end smallexample
-
-@noindent
-Thus, the @code{CYCLE} statement in the innermost loop skips over
-the @code{PRINT} statement as it begins the next iteration of the
-loop, while the @code{EXIT} statement in the middle loop ends that
-loop but @emph{not} the outermost loop.
-
-@node Functions and Subroutines
-@section Functions and Subroutines
-
-(The following information augments or overrides the information in
-Chapter 15 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 15 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-@menu
-* %VAL()::
-* %REF()::
-* %DESCR()::
-* Generics and Specifics::
-* REAL() and AIMAG() of Complex::
-* CMPLX() of DOUBLE PRECISION::
-* MIL-STD 1753::
-* f77/f2c Intrinsics::
-* Table of Intrinsic Functions::
-@end menu
-
-@node %VAL()
-@subsection The @code{%VAL()} Construct
-@cindex %VAL() construct
-
-@example
-%VAL(@var{arg})
-@end example
-
-The @code{%VAL()} construct specifies that an argument,
-@var{arg}, is to be passed by value, instead of by reference
-or descriptor.
-
-@code{%VAL()} is restricted to actual arguments in
-invocations of external procedures.
-
-Use of @code{%VAL()} is recommended only for code that
-is accessing facilities outside of GNU Fortran, such as
-operating system or windowing facilities.
-It is best to constrain such uses to isolated portions of
-a program---portions the deal specifically and exclusively
-with low-level, system-dependent facilities.
-Such portions might well provide a portable interface for
-use by the program as a whole, but are themselves not
-portable, and should be thoroughly tested each time they
-are rebuilt using a new compiler or version of a compiler.
-
-@emph{Implementation Note:} Currently, @command{g77} passes
-all arguments either by reference or by descriptor.
-
-Thus, use of @code{%VAL()} tends to be restricted to cases
-where the called procedure is written in a language other
-than Fortran that supports call-by-value semantics.
-(C is an example of such a language.)
-
-@xref{Procedures,,Procedures (SUBROUTINE and FUNCTION)},
-for detailed information on
-how this particular version of @command{g77} passes arguments
-to procedures.
-
-@node %REF()
-@subsection The @code{%REF()} Construct
-@cindex %REF() construct
-
-@example
-%REF(@var{arg})
-@end example
-
-The @code{%REF()} construct specifies that an argument,
-@var{arg}, is to be passed by reference, instead of by
-value or descriptor.
-
-@code{%REF()} is restricted to actual arguments in
-invocations of external procedures.
-
-Use of @code{%REF()} is recommended only for code that
-is accessing facilities outside of GNU Fortran, such as
-operating system or windowing facilities.
-It is best to constrain such uses to isolated portions of
-a program---portions the deal specifically and exclusively
-with low-level, system-dependent facilities.
-Such portions might well provide a portable interface for
-use by the program as a whole, but are themselves not
-portable, and should be thoroughly tested each time they
-are rebuilt using a new compiler or version of a compiler.
-
-Do not depend on @code{%REF()} supplying a pointer to the
-procedure being invoked.
-While that is a likely implementation choice, other
-implementation choices are available that preserve Fortran
-pass-by-reference semantics without passing a pointer to
-the argument, @var{arg}.
-(For example, a copy-in/copy-out implementation.)
-
-@emph{Implementation Note:} Currently, @command{g77} passes
-all arguments
-(other than variables and arrays of type @code{CHARACTER})
-by reference.
-Future versions of, or dialects supported by, @command{g77} might
-not pass @code{CHARACTER} functions by reference.
-
-Thus, use of @code{%REF()} tends to be restricted to cases
-where @var{arg} is type @code{CHARACTER} but the called
-procedure accesses it via a means other than the method
-used for Fortran @code{CHARACTER} arguments.
-
-@xref{Procedures,,Procedures (SUBROUTINE and FUNCTION)}, for detailed information on
-how this particular version of @command{g77} passes arguments
-to procedures.
-
-@node %DESCR()
-@subsection The @code{%DESCR()} Construct
-@cindex %DESCR() construct
-
-@example
-%DESCR(@var{arg})
-@end example
-
-The @code{%DESCR()} construct specifies that an argument,
-@var{arg}, is to be passed by descriptor, instead of by
-value or reference.
-
-@code{%DESCR()} is restricted to actual arguments in
-invocations of external procedures.
-
-Use of @code{%DESCR()} is recommended only for code that
-is accessing facilities outside of GNU Fortran, such as
-operating system or windowing facilities.
-It is best to constrain such uses to isolated portions of
-a program---portions the deal specifically and exclusively
-with low-level, system-dependent facilities.
-Such portions might well provide a portable interface for
-use by the program as a whole, but are themselves not
-portable, and should be thoroughly tested each time they
-are rebuilt using a new compiler or version of a compiler.
-
-Do not depend on @code{%DESCR()} supplying a pointer
-and/or a length passed by value
-to the procedure being invoked.
-While that is a likely implementation choice, other
-implementation choices are available that preserve the
-pass-by-reference semantics without passing a pointer to
-the argument, @var{arg}.
-(For example, a copy-in/copy-out implementation.)
-And, future versions of @command{g77} might change the
-way descriptors are implemented, such as passing a
-single argument pointing to a record containing the
-pointer/length information instead of passing that same
-information via two arguments as it currently does.
-
-@emph{Implementation Note:} Currently, @command{g77} passes
-all variables and arrays of type @code{CHARACTER}
-by descriptor.
-Future versions of, or dialects supported by, @command{g77} might
-pass @code{CHARACTER} functions by descriptor as well.
-
-Thus, use of @code{%DESCR()} tends to be restricted to cases
-where @var{arg} is not type @code{CHARACTER} but the called
-procedure accesses it via a means similar to the method
-used for Fortran @code{CHARACTER} arguments.
-
-@xref{Procedures,,Procedures (SUBROUTINE and FUNCTION)}, for detailed information on
-how this particular version of @command{g77} passes arguments
-to procedures.
-
-@node Generics and Specifics
-@subsection Generics and Specifics
-@cindex generic intrinsics
-@cindex intrinsics, generic
-
-The ANSI FORTRAN 77 language defines generic and specific
-intrinsics.
-In short, the distinctions are:
-
-@itemize @bullet
-@item
-@emph{Specific} intrinsics have
-specific types for their arguments and a specific return
-type.
-
-@item
-@emph{Generic} intrinsics are treated,
-on a case-by-case basis in the program's source code,
-as one of several possible specific intrinsics.
-
-Typically, a generic intrinsic has a return type that
-is determined by the type of one or more of its arguments.
-@end itemize
-
-The GNU Fortran language generalizes these concepts somewhat,
-especially by providing intrinsic subroutines and generic
-intrinsics that are treated as either a specific intrinsic subroutine
-or a specific intrinsic function (e.g. @code{SECOND}).
-
-However, GNU Fortran avoids generalizing this concept to
-the point where existing code would be accepted as meaning
-something possibly different than what was intended.
-
-For example, @code{ABS} is a generic intrinsic, so all working
-code written using @code{ABS} of an @code{INTEGER} argument
-expects an @code{INTEGER} return value.
-Similarly, all such code expects that @code{ABS} of an @code{INTEGER*2}
-argument returns an @code{INTEGER*2} return value.
-
-Yet, @code{IABS} is a @emph{specific} intrinsic that accepts only
-an @code{INTEGER(KIND=1)} argument.
-Code that passes something other than an @code{INTEGER(KIND=1)}
-argument to @code{IABS} is not valid GNU Fortran code, because
-it is not clear what the author intended.
-
-For example, if @samp{J} is @code{INTEGER(KIND=6)}, @samp{IABS(J)}
-is not defined by the GNU Fortran language, because the programmer
-might have used that construct to mean any of the following, subtly
-different, things:
-
-@itemize @bullet
-@item
-Convert @samp{J} to @code{INTEGER(KIND=1)} first
-(as if @samp{IABS(INT(J))} had been written).
-
-@item
-Convert the result of the intrinsic to @code{INTEGER(KIND=1)}
-(as if @samp{INT(ABS(J))} had been written).
-
-@item
-No conversion (as if @samp{ABS(J)} had been written).
-@end itemize
-
-The distinctions matter especially when types and values wider than
-@code{INTEGER(KIND=1)} (such as @code{INTEGER(KIND=2)}), or when
-operations performing more ``arithmetic'' than absolute-value, are involved.
-
-The following sample program is not a valid GNU Fortran program, but
-might be accepted by other compilers.
-If so, the output is likely to be revealing in terms of how a given
-compiler treats intrinsics (that normally are specific) when they
-are given arguments that do not conform to their stated requirements:
-
-@cindex JCB002 program
-@smallexample
- PROGRAM JCB002
-C Version 1:
-C Modified 1999-02-15 (Burley) to delete my email address.
-C Modified 1997-05-21 (Burley) to accommodate compilers that implement
-C INT(I1-I2) as INT(I1)-INT(I2) given INTEGER*2 I1,I2.
-C
-C Version 0:
-C Written by James Craig Burley 1997-02-20.
-C
-C Purpose:
-C Determine how compilers handle non-standard IDIM
-C on INTEGER*2 operands, which presumably can be
-C extrapolated into understanding how the compiler
-C generally treats specific intrinsics that are passed
-C arguments not of the correct types.
-C
-C If your compiler implements INTEGER*2 and INTEGER
-C as the same type, change all INTEGER*2 below to
-C INTEGER*1.
-C
- INTEGER*2 I0, I4
- INTEGER I1, I2, I3
- INTEGER*2 ISMALL, ILARGE
- INTEGER*2 ITOOLG, ITWO
- INTEGER*2 ITMP
- LOGICAL L2, L3, L4
-C
-C Find smallest INTEGER*2 number.
-C
- ISMALL=0
- 10 I0 = ISMALL-1
- IF ((I0 .GE. ISMALL) .OR. (I0+1 .NE. ISMALL)) GOTO 20
- ISMALL = I0
- GOTO 10
- 20 CONTINUE
-C
-C Find largest INTEGER*2 number.
-C
- ILARGE=0
- 30 I0 = ILARGE+1
- IF ((I0 .LE. ILARGE) .OR. (I0-1 .NE. ILARGE)) GOTO 40
- ILARGE = I0
- GOTO 30
- 40 CONTINUE
-C
-C Multiplying by two adds stress to the situation.
-C
- ITWO = 2
-C
-C Need a number that, added to -2, is too wide to fit in I*2.
-C
- ITOOLG = ISMALL
-C
-C Use IDIM the straightforward way.
-C
- I1 = IDIM (ILARGE, ISMALL) * ITWO + ITOOLG
-C
-C Calculate result for first interpretation.
-C
- I2 = (INT (ILARGE) - INT (ISMALL)) * ITWO + ITOOLG
-C
-C Calculate result for second interpretation.
-C
- ITMP = ILARGE - ISMALL
- I3 = (INT (ITMP)) * ITWO + ITOOLG
-C
-C Calculate result for third interpretation.
-C
- I4 = (ILARGE - ISMALL) * ITWO + ITOOLG
-C
-C Print results.
-C
- PRINT *, 'ILARGE=', ILARGE
- PRINT *, 'ITWO=', ITWO
- PRINT *, 'ITOOLG=', ITOOLG
- PRINT *, 'ISMALL=', ISMALL
- PRINT *, 'I1=', I1
- PRINT *, 'I2=', I2
- PRINT *, 'I3=', I3
- PRINT *, 'I4=', I4
- PRINT *
- L2 = (I1 .EQ. I2)
- L3 = (I1 .EQ. I3)
- L4 = (I1 .EQ. I4)
- IF (L2 .AND. .NOT.L3 .AND. .NOT.L4) THEN
- PRINT *, 'Interp 1: IDIM(I*2,I*2) => IDIM(INT(I*2),INT(I*2))'
- STOP
- END IF
- IF (L3 .AND. .NOT.L2 .AND. .NOT.L4) THEN
- PRINT *, 'Interp 2: IDIM(I*2,I*2) => INT(DIM(I*2,I*2))'
- STOP
- END IF
- IF (L4 .AND. .NOT.L2 .AND. .NOT.L3) THEN
- PRINT *, 'Interp 3: IDIM(I*2,I*2) => DIM(I*2,I*2)'
- STOP
- END IF
- PRINT *, 'Results need careful analysis.'
- END
-@end smallexample
-
-No future version of the GNU Fortran language
-will likely permit specific intrinsic invocations with wrong-typed
-arguments (such as @code{IDIM} in the above example), since
-it has been determined that disagreements exist among
-many production compilers on the interpretation of
-such invocations.
-These disagreements strongly suggest that Fortran programmers,
-and certainly existing Fortran programs, disagree about the
-meaning of such invocations.
-
-The first version of @code{JCB002} didn't accommodate some compilers'
-treatment of @samp{INT(I1-I2)} where @samp{I1} and @samp{I2} are
-@code{INTEGER*2}.
-In such a case, these compilers apparently convert both
-operands to @code{INTEGER*4} and then do an @code{INTEGER*4} subtraction,
-instead of doing an @code{INTEGER*2} subtraction on the
-original values in @samp{I1} and @samp{I2}.
-
-However, the results of the careful analyses done on the outputs
-of programs compiled by these various compilers show that they
-all implement either @samp{Interp 1} or @samp{Interp 2} above.
-
-Specifically, it is believed that the new version of @code{JCB002}
-above will confirm that:
-
-@itemize @bullet
-@item
-Digital Semiconductor (``DEC'') Alpha OSF/1, HP-UX 10.0.1, AIX 3.2.5
-@command{f77} compilers all implement @samp{Interp 1}.
-
-@item
-IRIX 5.3 @command{f77} compiler implements @samp{Interp 2}.
-
-@item
-Solaris 2.5, SunOS 4.1.3, DECstation ULTRIX 4.3,
-and IRIX 6.1 @command{f77} compilers all implement @samp{Interp 3}.
-@end itemize
-
-If you get different results than the above for the stated
-compilers, or have results for other compilers that might be
-worth adding to the above list, please let us know the details
-(compiler product, version, machine, results, and so on).
-
-@node REAL() and AIMAG() of Complex
-@subsection @code{REAL()} and @code{AIMAG()} of Complex
-@cindex @code{Real} intrinsic
-@cindex intrinsics, @code{Real}
-@cindex @code{AImag} intrinsic
-@cindex intrinsics, @code{AImag}
-
-The GNU Fortran language disallows @code{REAL(@var{expr})}
-and @code{AIMAG(@var{expr})},
-where @var{expr} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)},
-except when they are used in the following way:
-
-@example
-REAL(REAL(@var{expr}))
-REAL(AIMAG(@var{expr}))
-@end example
-
-@noindent
-The above forms explicitly specify that the desired effect
-is to convert the real or imaginary part of @var{expr}, which might
-be some @code{REAL} type other than @code{REAL(KIND=1)},
-to type @code{REAL(KIND=1)},
-and have that serve as the value of the expression.
-
-The GNU Fortran language offers clearly named intrinsics to extract the
-real and imaginary parts of a complex entity without any
-conversion:
-
-@example
-REALPART(@var{expr})
-IMAGPART(@var{expr})
-@end example
-
-To express the above using typical extended FORTRAN 77,
-use the following constructs
-(when @var{expr} is @code{COMPLEX(KIND=2)}):
-
-@example
-DBLE(@var{expr})
-DIMAG(@var{expr})
-@end example
-
-The FORTRAN 77 language offers no way
-to explicitly specify the real and imaginary parts of a complex expression of
-arbitrary type, apparently as a result of requiring support for
-only one @code{COMPLEX} type (@code{COMPLEX(KIND=1)}).
-The concepts of converting an expression to type @code{REAL(KIND=1)} and
-of extracting the real part of a complex expression were
-thus ``smooshed'' by FORTRAN 77 into a single intrinsic, since
-they happened to have the exact same effect in that language
-(due to having only one @code{COMPLEX} type).
-
-@emph{Note:} When @option{-ff90} is in effect,
-@command{g77} treats @samp{REAL(@var{expr})}, where @var{expr} is of
-type @code{COMPLEX}, as @samp{REALPART(@var{expr})},
-whereas with @samp{-fugly-complex -fno-f90} in effect, it is
-treated as @samp{REAL(REALPART(@var{expr}))}.
-
-@xref{Ugly Complex Part Extraction}, for more information.
-
-@node CMPLX() of DOUBLE PRECISION
-@subsection @code{CMPLX()} of @code{DOUBLE PRECISION}
-@cindex @code{Cmplx} intrinsic
-@cindex intrinsics, @code{Cmplx}
-
-In accordance with Fortran 90 and at least some (perhaps all)
-other compilers, the GNU Fortran language defines @code{CMPLX()}
-as always returning a result that is type @code{COMPLEX(KIND=1)}.
-
-This means @samp{CMPLX(D1,D2)}, where @samp{D1} and @samp{D2}
-are @code{REAL(KIND=2)} (@code{DOUBLE PRECISION}), is treated as:
-
-@example
-CMPLX(SNGL(D1), SNGL(D2))
-@end example
-
-(It was necessary for Fortran 90 to specify this behavior
-for @code{DOUBLE PRECISION} arguments, since that is
-the behavior mandated by FORTRAN 77.)
-
-The GNU Fortran language also provides the @code{DCMPLX()} intrinsic,
-which is provided by some FORTRAN 77 compilers to construct
-a @code{DOUBLE COMPLEX} entity from of @code{DOUBLE PRECISION}
-operands.
-However, this solution does not scale well when more @code{COMPLEX} types
-(having various precisions and ranges) are offered by Fortran implementations.
-
-Fortran 90 extends the @code{CMPLX()} intrinsic by adding
-an extra argument used to specify the desired kind of complex
-result.
-However, this solution is somewhat awkward to use, and
-@command{g77} currently does not support it.
-
-The GNU Fortran language provides a simple way to build a complex
-value out of two numbers, with the precise type of the value
-determined by the types of the two numbers (via the usual
-type-promotion mechanism):
-
-@example
-COMPLEX(@var{real}, @var{imag})
-@end example
-
-When @var{real} and @var{imag} are the same @code{REAL} types, @code{COMPLEX()}
-performs no conversion other than to put them together to form a
-complex result of the same (complex version of real) type.
-
-@xref{Complex Intrinsic}, for more information.
-
-@node MIL-STD 1753
-@subsection MIL-STD 1753 Support
-@cindex MIL-STD 1753
-
-The GNU Fortran language includes the MIL-STD 1753 intrinsics
-@code{BTEST}, @code{IAND}, @code{IBCLR}, @code{IBITS},
-@code{IBSET}, @code{IEOR}, @code{IOR}, @code{ISHFT},
-@code{ISHFTC}, @code{MVBITS}, and @code{NOT}.
-
-@node f77/f2c Intrinsics
-@subsection @command{f77}/@command{f2c} Intrinsics
-
-The bit-manipulation intrinsics supported by traditional
-@command{f77} and by @command{f2c} are available in the GNU Fortran language.
-These include @code{AND}, @code{LSHIFT}, @code{OR}, @code{RSHIFT},
-and @code{XOR}.
-
-Also supported are the intrinsics @code{CDABS},
-@code{CDCOS}, @code{CDEXP}, @code{CDLOG}, @code{CDSIN},
-@code{CDSQRT}, @code{DCMPLX}, @code{DCONJG}, @code{DFLOAT},
-@code{DIMAG}, @code{DREAL}, and @code{IMAG},
-@code{ZABS}, @code{ZCOS}, @code{ZEXP}, @code{ZLOG}, @code{ZSIN},
-and @code{ZSQRT}.
-
-@node Table of Intrinsic Functions
-@subsection Table of Intrinsic Functions
-@cindex intrinsics, table of
-@cindex table of intrinsics
-
-(Corresponds to Section 15.10 of ANSI X3.9-1978 FORTRAN 77.)
-
-The GNU Fortran language adds various functions, subroutines, types,
-and arguments to the set of intrinsic functions in ANSI FORTRAN 77.
-The complete set of intrinsics supported by the GNU Fortran language
-is described below.
-
-Note that a name is not treated as that of an intrinsic if it is
-specified in an @code{EXTERNAL} statement in the same program unit;
-if a command-line option is used to disable the groups to which
-the intrinsic belongs; or if the intrinsic is not named in an
-@code{INTRINSIC} statement and a command-line option is used to
-hide the groups to which the intrinsic belongs.
-
-So, it is recommended that any reference in a program unit to
-an intrinsic procedure that is not a standard FORTRAN 77
-intrinsic be accompanied by an appropriate @code{INTRINSIC}
-statement in that program unit.
-This sort of defensive programming makes it more
-likely that an implementation will issue a diagnostic rather
-than generate incorrect code for such a reference.
-
-The terminology used below is based on that of the Fortran 90
-standard, so that the text may be more concise and accurate:
-
-@itemize @bullet
-@item
-@code{OPTIONAL} means the argument may be omitted.
-
-@item
-@samp{A-1, A-2, @dots{}, A-n} means more than one argument
-(generally named @samp{A}) may be specified.
-
-@item
-@samp{scalar} means the argument must not be an array (must
-be a variable or array element, or perhaps a constant if expressions
-are permitted).
-
-@item
-@samp{DIMENSION(4)} means the argument must be an array having 4 elements.
-
-@item
-@code{INTENT(IN)} means the argument must be an expression
-(such as a constant or a variable that is defined upon invocation
-of the intrinsic).
-
-@item
-@code{INTENT(OUT)} means the argument must be definable by the
-invocation of the intrinsic (that is, must not be a constant nor
-an expression involving operators other than array reference and
-substring reference).
-
-@item
-@code{INTENT(INOUT)} means the argument must be defined prior to,
-and definable by, invocation of the intrinsic (a combination of
-the requirements of @code{INTENT(IN)} and @code{INTENT(OUT)}.
-
-@item
-@xref{Kind Notation}, for an explanation of @code{KIND}.
-@end itemize
-
-@ifinfo
-(Note that the empty lines appearing in the menu below
-are not intentional---they result from a bug in the
-GNU @command{makeinfo} program@dots{}a program that, if it
-did not exist, would leave this document in far worse shape!)
-@end ifinfo
-
-@c The actual documentation for intrinsics comes from
-@c intdoc.texi, which in turn is automatically generated
-@c from the internal g77 tables in intrin.def _and_ the
-@c largely hand-written text in intdoc.h. So, if you want
-@c to change or add to existing documentation on intrinsics,
-@c you probably want to edit intdoc.h.
-@c
-@set familyF77
-@set familyGNU
-@set familyASC
-@set familyMIL
-@set familyF90
-@clear familyVXT
-@clear familyFVZ
-@set familyF2C
-@set familyF2U
-@clear familyBADU77
-@include intdoc.texi
-
-@node Scope and Classes of Names
-@section Scope and Classes of Symbolic Names
-@cindex symbol names, scope and classes
-@cindex scope
-
-(The following information augments or overrides the information in
-Chapter 18 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran
-language.
-Chapter 18 of that document otherwise serves as the basis
-for the relevant aspects of GNU Fortran.)
-
-@menu
-* Underscores in Symbol Names::
-@end menu
-
-@node Underscores in Symbol Names
-@subsection Underscores in Symbol Names
-@cindex underscore
-
-Underscores (@samp{_}) are accepted in symbol names after the first
-character (which must be a letter).
-
-@node I/O
-@section I/O
-
-@cindex dollar sign
-A dollar sign at the end of an output format specification suppresses
-the newline at the end of the output.
-
-@cindex <> edit descriptor
-@cindex edit descriptor, <>
-Edit descriptors in @code{FORMAT} statements may contain compile-time
-@code{INTEGER} constant expressions in angle brackets, such as
-@smallexample
-10 FORMAT (I<WIDTH>)
-@end smallexample
-
-The @code{OPEN} specifier @code{NAME=} is equivalent to @code{FILE=}.
-
-These Fortran 90 features are supported:
-@itemize @bullet
-@item
-@cindex FORMAT descriptors
-@cindex Z edit descriptor
-@cindex edit descriptor, Z
-@cindex O edit descriptor
-@cindex edit descriptor, O
-The @code{O} and @code{Z} edit descriptors are supported for I/O of
-integers in octal and hexadecimal formats, respectively.
-@item
-The @code{FILE=} specifier may be omitted in an @code{OPEN} statement if
-@code{STATUS='SCRATCH'} is supplied. The @code{STATUS='REPLACE'}
-specifier is supported.
-@end itemize
-
-@node Fortran 90 Features
-@section Fortran 90 Features
-@cindex Fortran 90
-@cindex extensions, from Fortran 90
-
-For convenience this section collects a list (probably incomplete) of
-the Fortran 90 features supported by the GNU Fortran language, even if
-they are documented elsewhere.
-@xref{Characters Lines Sequence,,@asis{Characters, Lines, and Execution Sequence}},
-for information on additional fixed source form lexical issues.
-@cindex @option{-ffree-form}
-Further, the free source form is supported through the
-@option{-ffree-form} option.
-@cindex @option{-ff90}
-Other Fortran 90 features can be turned on by the @option{-ff90} option;
-see @ref{Fortran 90}.
-For information on the Fortran 90 intrinsics available,
-see @ref{Table of Intrinsic Functions}.
-
-@table @asis
-@item Automatic arrays in procedures
-@item Character assignments
-@cindex character assignments
-In character assignments, the variable being assigned may occur on the
-right hand side of the assignment.
-@item Character strings
-@cindex double quoted character constants
-Strings may have zero length and substrings of character constants are
-permitted. Character constants may be enclosed in double quotes
-(@code{"}) as well as single quotes. @xref{Character Type}.
-@item Construct names
-(Symbolic tags on blocks.) @xref{Construct Names}.
-@item @code{CYCLE} and @code{EXIT}
-@xref{CYCLE and EXIT,,The @code{CYCLE} and @code{EXIT} Statements}.
-@item @code{DOUBLE COMPLEX}
-@xref{DOUBLE COMPLEX,,@code{DOUBLE COMPLEX} Statement}.
-@item @code{DO WHILE}
-@xref{DO WHILE}.
-@item @code{END} decoration
-@xref{Statements}.
-@item @code{END DO}
-@xref{END DO}.
-@item @code{KIND}
-@item @code{IMPLICIT NONE}
-@item @code{INCLUDE} statements
-@xref{INCLUDE}.
-@item List-directed and namelist I/O on internal files
-@item Binary, octal and hexadecimal constants
-These are supported more generally than required by Fortran 90.
-@xref{Integer Type}.
-@item @samp{O} and @samp{Z} edit descriptors
-@item @code{NAMELIST}
-@xref{NAMELIST}.
-@item @code{OPEN} specifiers
-@code{STATUS='REPLACE'} is supported.
-The @code{FILE=} specifier may be omitted in an @code{OPEN} statement if
-@code{STATUS='SCRATCH'} is supplied.
-@item @code{FORMAT} edit descriptors
-@cindex FORMAT descriptors
-@cindex Z edit descriptor
-@cindex edit descriptor, Z
-The @code{Z} edit descriptor is supported.
-@item Relational operators
-The operators @code{<}, @code{<=}, @code{==}, @code{/=}, @code{>} and
-@code{>=} may be used instead of @code{.LT.}, @code{.LE.}, @code{.EQ.},
-@code{.NE.}, @code{.GT.} and @code{.GE.} respectively.
-@item @code{SELECT CASE}
-Not fully implemented.
-@xref{SELECT CASE on CHARACTER Type,, @code{SELECT CASE} on @code{CHARACTER} Type}.
-@item Specification statements
-A limited subset of the Fortran 90 syntax and semantics for variable
-declarations is supported, including @code{KIND}. @xref{Kind Notation}.
-(@code{KIND} is of limited usefulness in the absence of the
-@code{KIND}-related intrinsics, since these intrinsics permit writing
-more widely portable code.) An example of supported @code{KIND} usage
-is:
-@smallexample
-INTEGER (KIND=1) :: FOO=1, BAR=2
-CHARACTER (LEN=3) FOO
-@end smallexample
-@code{PARAMETER} and @code{DIMENSION} attributes aren't supported.
-@end table
-
-@node Other Dialects
-@chapter Other Dialects
-
-GNU Fortran supports a variety of features that are not
-considered part of the GNU Fortran language itself, but
-are representative of various dialects of Fortran that
-@command{g77} supports in whole or in part.
-
-Any of the features listed below might be disallowed by
-@command{g77} unless some command-line option is specified.
-Currently, some of the features are accepted using the
-default invocation of @command{g77}, but that might change
-in the future.
-
-@emph{Note: This portion of the documentation definitely needs a lot
-of work!}
-
-@menu
-* Source Form:: Details of fixed-form and free-form source.
-* Trailing Comment:: Use of @samp{/*} to start a comment.
-* Debug Line:: Use of @samp{D} in column 1.
-* Dollar Signs:: Use of @samp{$} in symbolic names.
-* Case Sensitivity:: Uppercase and lowercase in source files.
-* VXT Fortran:: @dots{}versus the GNU Fortran language.
-* Fortran 90:: @dots{}versus the GNU Fortran language.
-* Pedantic Compilation:: Enforcing the standard.
-* Distensions:: Misfeatures supported by GNU Fortran.
-@end menu
-
-@node Source Form
-@section Source Form
-@cindex source file format
-@cindex source format
-@cindex file, source
-@cindex source code
-@cindex code, source
-@cindex fixed form
-@cindex free form
-
-GNU Fortran accepts programs written in either fixed form or
-free form.
-
-Fixed form
-corresponds to ANSI FORTRAN 77 (plus popular extensions, such as
-allowing tabs) and Fortran 90's fixed form.
-
-Free form corresponds to
-Fortran 90's free form (though possibly not entirely up-to-date, and
-without complaining about some things that for which Fortran 90 requires
-diagnostics, such as the spaces in the constant in @samp{R = 3 . 1}).
-
-The way a Fortran compiler views source files depends entirely on the
-implementation choices made for the compiler, since those choices
-are explicitly left to the implementation by the published Fortran
-standards.
-GNU Fortran currently tries to be somewhat like a few popular compilers
-(@command{f2c}, Digital (``DEC'') Fortran, and so on).
-
-This section describes how @command{g77} interprets source lines.
-
-@menu
-* Carriage Returns:: Carriage returns ignored.
-* Tabs:: Tabs converted to spaces.
-* Short Lines:: Short lines padded with spaces (fixed-form only).
-* Long Lines:: Long lines truncated.
-* Ampersands:: Special Continuation Lines.
-@end menu
-
-@node Carriage Returns
-@subsection Carriage Returns
-@cindex carriage returns
-
-Carriage returns (@samp{\r}) in source lines are ignored.
-This is somewhat different from @command{f2c}, which seems to treat them as
-spaces outside character/Hollerith constants, and encodes them as @samp{\r}
-inside such constants.
-
-@node Tabs
-@subsection Tabs
-@cindex tab character
-@cindex horizontal tab
-
-A source line with a @key{TAB} character anywhere in it is treated as
-entirely significant---however long it is---instead of ending in
-column 72 (for fixed-form source) or 132 (for free-form source).
-This also is different from @command{f2c}, which encodes tabs as
-@samp{\t} (the ASCII @key{TAB} character) inside character
-and Hollerith constants, but nevertheless seems to treat the column
-position as if it had been affected by the canonical tab positioning.
-
-@command{g77} effectively
-translates tabs to the appropriate number of spaces (a la the default
-for the UNIX @command{expand} command) before doing any other processing, other
-than (currently) noting whether a tab was found on a line and using this
-information to decide how to interpret the length of the line and continued
-constants.
-
-@node Short Lines
-@subsection Short Lines
-@cindex short source lines
-@cindex space, padding with
-@cindex source lines, short
-@cindex lines, short
-
-Source lines shorter than the applicable fixed-form length are treated as
-if they were padded with spaces to that length.
-(None of this is relevant to source files written in free form.)
-
-This affects only
-continued character and Hollerith constants, and is a different
-interpretation than provided by some other popular compilers
-(although a bit more consistent with the traditional punched-card
-basis of Fortran and the way the Fortran standard expressed fixed
-source form).
-
-@command{g77} might someday offer an option to warn about cases where differences
-might be seen as a result of this treatment, and perhaps an option to
-specify the alternate behavior as well.
-
-Note that this padding cannot apply to lines that are effectively of
-infinite length---such lines are specified using command-line options
-like @option{-ffixed-line-length-none}, for example.
-
-@node Long Lines
-@subsection Long Lines
-@cindex long source lines
-@cindex truncation, of long lines
-@cindex lines, long
-@cindex source lines, long
-
-Source lines longer than the applicable length are truncated to that
-length.
-Currently, @command{g77} does not warn if the truncated characters are
-not spaces, to accommodate existing code written for systems that
-treated truncated text as commentary (especially in columns 73 through 80).
-
-@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect},
-for information on the @option{-ffixed-line-length-@var{n}} option,
-which can be used to set the line length applicable to fixed-form
-source files.
-
-@node Ampersands
-@subsection Ampersand Continuation Line
-@cindex ampersand continuation line
-@cindex continuation line, ampersand
-
-A @samp{&} in column 1 of fixed-form source denotes an arbitrary-length
-continuation line, imitating the behavior of @command{f2c}.
-
-@node Trailing Comment
-@section Trailing Comment
-
-@cindex trailing comment
-@cindex comment
-@cindex characters, comment
-@cindex /*
-@cindex !
-@cindex exclamation point
-@command{g77} supports use of @samp{/*} to start a trailing
-comment.
-In the GNU Fortran language, @samp{!} is used for this purpose.
-
-@samp{/*} is not in the GNU Fortran language
-because the use of @samp{/*} in a program might
-suggest to some readers that a block, not trailing, comment is
-started (and thus ended by @samp{*/}, not end of line),
-since that is the meaning of @samp{/*} in C.
-
-Also, such readers might think they can use @samp{//} to start
-a trailing comment as an alternative to @samp{/*}, but
-@samp{//} already denotes concatenation, and such a ``comment''
-might actually result in a program that compiles without
-error (though it would likely behave incorrectly).
-
-@node Debug Line
-@section Debug Line
-@cindex debug line
-@cindex comment line, debug
-
-Use of @samp{D} or @samp{d} as the first character (column 1) of
-a source line denotes a debug line.
-
-In turn, a debug line is treated as either a comment line
-or a normal line, depending on whether debug lines are enabled.
-
-When treated as a comment line, a line beginning with @samp{D} or
-@samp{d} is treated as if it the first character was @samp{C} or @samp{c}, respectively.
-When treated as a normal line, such a line is treated as if
-the first character was @key{SPC} (space).
-
-(Currently, @command{g77} provides no means for treating debug
-lines as normal lines.)
-
-@node Dollar Signs
-@section Dollar Signs in Symbol Names
-@cindex dollar sign
-@cindex $
-
-Dollar signs (@samp{$}) are allowed in symbol names (after the first character)
-when the @option{-fdollar-ok} option is specified.
-
-@node Case Sensitivity
-@section Case Sensitivity
-@cindex case sensitivity
-@cindex source file format
-@cindex code, source
-@cindex source code
-@cindex uppercase letters
-@cindex lowercase letters
-@cindex letters, uppercase
-@cindex letters, lowercase
-
-GNU Fortran offers the programmer way too much flexibility in deciding
-how source files are to be treated vis-a-vis uppercase and lowercase
-characters.
-There are 66 useful settings that affect case sensitivity, plus 10
-settings that are nearly useless, with the remaining 116 settings
-being either redundant or useless.
-
-None of these settings have any effect on the contents of comments
-(the text after a @samp{c} or @samp{C} in Column 1, for example)
-or of character or Hollerith constants.
-Note that things like the @samp{E} in the statement
-@samp{CALL FOO(3.2E10)} and the @samp{TO} in @samp{ASSIGN 10 TO LAB}
-are considered built-in keywords, and so are affected by
-these settings.
-
-Low-level switches are identified in this section as follows:
-
-@itemize @w{}
-@item A
-Source Case Conversion:
-
-@itemize @w{}
-@item 0
-Preserve (see Note 1)
-@item 1
-Convert to Upper Case
-@item 2
-Convert to Lower Case
-@end itemize
-
-@item B
-Built-in Keyword Matching:
-
-@itemize @w{}
-@item 0
-Match Any Case (per-character basis)
-@item 1
-Match Upper Case Only
-@item 2
-Match Lower Case Only
-@item 3
-Match InitialCaps Only (see tables for spellings)
-@end itemize
-
-@item C
-Built-in Intrinsic Matching:
-
-@itemize @w{}
-@item 0
-Match Any Case (per-character basis)
-@item 1
-Match Upper Case Only
-@item 2
-Match Lower Case Only
-@item 3
-Match InitialCaps Only (see tables for spellings)
-@end itemize
-
-@item D
-User-defined Symbol Possibilities (warnings only):
-
-@itemize @w{}
-@item 0
-Allow Any Case (per-character basis)
-@item 1
-Allow Upper Case Only
-@item 2
-Allow Lower Case Only
-@item 3
-Allow InitialCaps Only (see Note 2)
-@end itemize
-@end itemize
-
-Note 1: @command{g77} eventually will support @code{NAMELIST} in a manner that is
-consistent with these source switches---in the sense that input will be
-expected to meet the same requirements as source code in terms
-of matching symbol names and keywords (for the exponent letters).
-
-Currently, however, @code{NAMELIST} is supported by @code{libg2c},
-which uppercases @code{NAMELIST} input and symbol names for matching.
-This means not only that @code{NAMELIST} output currently shows symbol
-(and keyword) names in uppercase even if lower-case source
-conversion (option A2) is selected, but that @code{NAMELIST} cannot be
-adequately supported when source case preservation (option A0)
-is selected.
-
-If A0 is selected, a warning message will be
-output for each @code{NAMELIST} statement to this effect.
-The behavior
-of the program is undefined at run time if two or more symbol names
-appear in a given @code{NAMELIST} such that the names are identical
-when converted to upper case (e.g. @samp{NAMELIST /X/ VAR, Var, var}).
-For complete and total elegance, perhaps there should be a warning
-when option A2 is selected, since the output of NAMELIST is currently
-in uppercase but will someday be lowercase (when a @code{libg77} is written),
-but that seems to be overkill for a product in beta test.
-
-Note 2: Rules for InitialCaps names are:
-
-@itemize @minus
-@item
-Must be a single uppercase letter, @strong{or}
-@item
-Must start with an uppercase letter and contain at least one
-lowercase letter.
-@end itemize
-
-So @samp{A}, @samp{Ab}, @samp{ABc}, @samp{AbC}, and @samp{Abc} are
-valid InitialCaps names, but @samp{AB}, @samp{A2}, and @samp{ABC} are
-not.
-Note that most, but not all, built-in names meet these
-requirements---the exceptions are some of the two-letter format
-specifiers, such as @code{BN} and @code{BZ}.
-
-Here are the names of the corresponding command-line options:
-
-@smallexample
-A0: -fsource-case-preserve
-A1: -fsource-case-upper
-A2: -fsource-case-lower
-
-B0: -fmatch-case-any
-B1: -fmatch-case-upper
-B2: -fmatch-case-lower
-B3: -fmatch-case-initcap
-
-C0: -fintrin-case-any
-C1: -fintrin-case-upper
-C2: -fintrin-case-lower
-C3: -fintrin-case-initcap
-
-D0: -fsymbol-case-any
-D1: -fsymbol-case-upper
-D2: -fsymbol-case-lower
-D3: -fsymbol-case-initcap
-@end smallexample
-
-Useful combinations of the above settings, along with abbreviated
-option names that set some of these combinations all at once:
-
-@smallexample
- 1: A0-- B0--- C0--- D0--- -fcase-preserve
- 2: A0-- B0--- C0--- D-1--
- 3: A0-- B0--- C0--- D--2-
- 4: A0-- B0--- C0--- D---3
- 5: A0-- B0--- C-1-- D0---
- 6: A0-- B0--- C-1-- D-1--
- 7: A0-- B0--- C-1-- D--2-
- 8: A0-- B0--- C-1-- D---3
- 9: A0-- B0--- C--2- D0---
-10: A0-- B0--- C--2- D-1--
-11: A0-- B0--- C--2- D--2-
-12: A0-- B0--- C--2- D---3
-13: A0-- B0--- C---3 D0---
-14: A0-- B0--- C---3 D-1--
-15: A0-- B0--- C---3 D--2-
-16: A0-- B0--- C---3 D---3
-17: A0-- B-1-- C0--- D0---
-18: A0-- B-1-- C0--- D-1--
-19: A0-- B-1-- C0--- D--2-
-20: A0-- B-1-- C0--- D---3
-21: A0-- B-1-- C-1-- D0---
-22: A0-- B-1-- C-1-- D-1-- -fcase-strict-upper
-23: A0-- B-1-- C-1-- D--2-
-24: A0-- B-1-- C-1-- D---3
-25: A0-- B-1-- C--2- D0---
-26: A0-- B-1-- C--2- D-1--
-27: A0-- B-1-- C--2- D--2-
-28: A0-- B-1-- C--2- D---3
-29: A0-- B-1-- C---3 D0---
-30: A0-- B-1-- C---3 D-1--
-31: A0-- B-1-- C---3 D--2-
-32: A0-- B-1-- C---3 D---3
-33: A0-- B--2- C0--- D0---
-34: A0-- B--2- C0--- D-1--
-35: A0-- B--2- C0--- D--2-
-36: A0-- B--2- C0--- D---3
-37: A0-- B--2- C-1-- D0---
-38: A0-- B--2- C-1-- D-1--
-39: A0-- B--2- C-1-- D--2-
-40: A0-- B--2- C-1-- D---3
-41: A0-- B--2- C--2- D0---
-42: A0-- B--2- C--2- D-1--
-43: A0-- B--2- C--2- D--2- -fcase-strict-lower
-44: A0-- B--2- C--2- D---3
-45: A0-- B--2- C---3 D0---
-46: A0-- B--2- C---3 D-1--
-47: A0-- B--2- C---3 D--2-
-48: A0-- B--2- C---3 D---3
-49: A0-- B---3 C0--- D0---
-50: A0-- B---3 C0--- D-1--
-51: A0-- B---3 C0--- D--2-
-52: A0-- B---3 C0--- D---3
-53: A0-- B---3 C-1-- D0---
-54: A0-- B---3 C-1-- D-1--
-55: A0-- B---3 C-1-- D--2-
-56: A0-- B---3 C-1-- D---3
-57: A0-- B---3 C--2- D0---
-58: A0-- B---3 C--2- D-1--
-59: A0-- B---3 C--2- D--2-
-60: A0-- B---3 C--2- D---3
-61: A0-- B---3 C---3 D0---
-62: A0-- B---3 C---3 D-1--
-63: A0-- B---3 C---3 D--2-
-64: A0-- B---3 C---3 D---3 -fcase-initcap
-65: A-1- B01-- C01-- D01-- -fcase-upper
-66: A--2 B0-2- C0-2- D0-2- -fcase-lower
-@end smallexample
-
-Number 22 is the ``strict'' ANSI FORTRAN 77 model wherein all input
-(except comments, character constants, and Hollerith strings) must
-be entered in uppercase.
-Use @option{-fcase-strict-upper} to specify this
-combination.
-
-Number 43 is like Number 22 except all input must be lowercase. Use
-@option{-fcase-strict-lower} to specify this combination.
-
-Number 65 is the ``classic'' ANSI FORTRAN 77 model as implemented on many
-non-UNIX machines whereby all the source is translated to uppercase.
-Use @option{-fcase-upper} to specify this combination.
-
-Number 66 is the ``canonical'' UNIX model whereby all the source is
-translated to lowercase.
-Use @option{-fcase-lower} to specify this combination.
-
-There are a few nearly useless combinations:
-
-@smallexample
-67: A-1- B01-- C01-- D--2-
-68: A-1- B01-- C01-- D---3
-69: A-1- B01-- C--23 D01--
-70: A-1- B01-- C--23 D--2-
-71: A-1- B01-- C--23 D---3
-72: A--2 B01-- C0-2- D-1--
-73: A--2 B01-- C0-2- D---3
-74: A--2 B01-- C-1-3 D0-2-
-75: A--2 B01-- C-1-3 D-1--
-76: A--2 B01-- C-1-3 D---3
-@end smallexample
-
-The above allow some programs to be compiled but with restrictions that
-make most useful programs impossible: Numbers 67 and 72 warn about
-@emph{any} user-defined symbol names (such as @samp{SUBROUTINE FOO});
-Numbers
-68 and 73 warn about any user-defined symbol names longer than one
-character that don't have at least one non-alphabetic character after
-the first;
-Numbers 69 and 74 disallow any references to intrinsics;
-and Numbers 70, 71, 75, and 76 are combinations of the restrictions in
-67+69, 68+69, 72+74, and 73+74, respectively.
-
-All redundant combinations are shown in the above tables anyplace
-where more than one setting is shown for a low-level switch.
-For example, @samp{B0-2-} means either setting 0 or 2 is valid for switch B.
-The ``proper'' setting in such a case is the one that copies the setting
-of switch A---any other setting might slightly reduce the speed of
-the compiler, though possibly to an unmeasurable extent.
-
-All remaining combinations are useless in that they prevent successful
-compilation of non-null source files (source files with something other
-than comments).
-
-@node VXT Fortran
-@section VXT Fortran
-
-@cindex VXT extensions
-@cindex extensions, VXT
-@command{g77} supports certain constructs that
-have different meanings in VXT Fortran than they
-do in the GNU Fortran language.
-
-Generally, this manual uses the invented term VXT Fortran to refer
-VAX FORTRAN (circa v4).
-That compiler offered many popular features, though not necessarily
-those that are specific to the VAX processor architecture,
-the VMS operating system,
-or Digital Equipment Corporation's Fortran product line.
-(VAX and VMS probably are trademarks of Digital Equipment
-Corporation.)
-
-An extension offered by a Digital Fortran product that also is
-offered by several other Fortran products for different kinds of
-systems is probably going to be considered for inclusion in @command{g77}
-someday, and is considered a VXT Fortran feature.
-
-The @option{-fvxt} option generally specifies that, where
-the meaning of a construct is ambiguous (means one thing
-in GNU Fortran and another in VXT Fortran), the VXT Fortran
-meaning is to be assumed.
-
-@menu
-* Double Quote Meaning:: @samp{"2000} as octal constant.
-* Exclamation Point:: @samp{!} in column 6.
-@end menu
-
-@node Double Quote Meaning
-@subsection Meaning of Double Quote
-@cindex double quotes
-@cindex character constants
-@cindex constants, character
-@cindex octal constants
-@cindex constants, octal
-
-@command{g77} treats double-quote (@samp{"})
-as beginning an octal constant of @code{INTEGER(KIND=1)} type
-when the @option{-fvxt} option is specified.
-The form of this octal constant is
-
-@example
-"@var{octal-digits}
-@end example
-
-@noindent
-where @var{octal-digits} is a nonempty string of characters in
-the set @samp{01234567}.
-
-For example, the @option{-fvxt} option permits this:
-
-@example
-PRINT *, "20
-END
-@end example
-
-@noindent
-The above program would print the value @samp{16}.
-
-@xref{Integer Type}, for information on the preferred construct
-for integer constants specified using GNU Fortran's octal notation.
-
-(In the GNU Fortran language, the double-quote character (@samp{"})
-delimits a character constant just as does apostrophe (@samp{'}).
-There is no way to allow
-both constructs in the general case, since statements like
-@samp{PRINT *,"2000 !comment?"} would be ambiguous.)
-
-@node Exclamation Point
-@subsection Meaning of Exclamation Point in Column 6
-@cindex !
-@cindex exclamation point
-@cindex continuation character
-@cindex characters, continuation
-@cindex comment character
-@cindex characters, comment
-
-@command{g77} treats an exclamation point (@samp{!}) in column 6 of
-a fixed-form source file
-as a continuation character rather than
-as the beginning of a comment
-(as it does in any other column)
-when the @option{-fvxt} option is specified.
-
-The following program, when run, prints a message indicating
-whether it is interpreted according to GNU Fortran (and Fortran 90)
-rules or VXT Fortran rules:
-
-@smallexample
-C234567 (This line begins in column 1.)
- I = 0
- !1
- IF (I.EQ.0) PRINT *, ' I am a VXT Fortran program'
- IF (I.EQ.1) PRINT *, ' I am a Fortran 90 program'
- IF (I.LT.0 .OR. I.GT.1) PRINT *, ' I am a HAL 9000 computer'
- END
-@end smallexample
-
-(In the GNU Fortran and Fortran 90 languages, exclamation point is
-a valid character and, unlike space (@key{SPC}) or zero (@samp{0}),
-marks a line as a continuation line when it appears in column 6.)
-
-@node Fortran 90
-@section Fortran 90
-@cindex compatibility, Fortran 90
-@cindex Fortran 90, compatibility
-
-The GNU Fortran language includes a number of features that are
-part of Fortran 90, even when the @option{-ff90} option is not specified.
-The features enabled by @option{-ff90} are intended to be those that,
-when @option{-ff90} is not specified, would have another
-meaning to @command{g77}---usually meaning something invalid in the
-GNU Fortran language.
-
-So, the purpose of @option{-ff90} is not to specify whether @command{g77} is
-to gratuitously reject Fortran 90 constructs.
-The @option{-pedantic} option specified with @option{-fno-f90} is intended
-to do that, although its implementation is certainly incomplete at
-this point.
-
-When @option{-ff90} is specified:
-
-@itemize @bullet
-@item
-The type of @samp{REAL(@var{expr})} and @samp{AIMAG(@var{expr})},
-where @var{expr} is @code{COMPLEX} type,
-is the same type as the real part of @var{expr}.
-
-For example, assuming @samp{Z} is type @code{COMPLEX(KIND=2)},
-@samp{REAL(Z)} would return a value of type @code{REAL(KIND=2)},
-not of type @code{REAL(KIND=1)}, since @option{-ff90} is specified.
-@end itemize
-
-@node Pedantic Compilation
-@section Pedantic Compilation
-@cindex pedantic compilation
-@cindex compilation, pedantic
-
-The @option{-fpedantic} command-line option specifies that @command{g77}
-is to warn about code that is not standard-conforming.
-This is useful for finding
-some extensions @command{g77} accepts that other compilers might not accept.
-(Note that the @option{-pedantic} and @option{-pedantic-errors} options
-always imply @option{-fpedantic}.)
-
-With @option{-fno-f90} in force, ANSI FORTRAN 77 is used as the standard
-for conforming code.
-With @option{-ff90} in force, Fortran 90 is used.
-
-The constructs for which @command{g77} issues diagnostics when @option{-fpedantic}
-and @option{-fno-f90} are in force are:
-
-@itemize @bullet
-@item
-Automatic arrays, as in
-
-@example
-SUBROUTINE X(N)
-REAL A(N)
-@dots{}
-@end example
-
-@noindent
-where @samp{A} is not listed in any @code{ENTRY} statement,
-and thus is not a dummy argument.
-
-@item
-The commas in @samp{READ (5), I} and @samp{WRITE (10), J}.
-
-These commas are disallowed by FORTRAN 77, but, while strictly
-superfluous, are syntactically elegant,
-especially given that commas are required in statements such
-as @samp{READ 99, I} and @samp{PRINT *, J}.
-Many compilers permit the superfluous commas for this reason.
-
-@item
-@code{DOUBLE COMPLEX}, either explicitly or implicitly.
-
-An explicit use of this type is via a @code{DOUBLE COMPLEX} or
-@code{IMPLICIT DOUBLE COMPLEX} statement, for examples.
-
-An example of an implicit use is the expression @samp{C*D},
-where @samp{C} is @code{COMPLEX(KIND=1)}
-and @samp{D} is @code{DOUBLE PRECISION}.
-This expression is prohibited by ANSI FORTRAN 77
-because the rules of promotion would suggest that it
-produce a @code{DOUBLE COMPLEX} result---a type not
-provided for by that standard.
-
-@item
-Automatic conversion of numeric
-expressions to @code{INTEGER(KIND=1)} in contexts such as:
-
-@itemize @minus
-@item
-Array-reference indexes.
-@item
-Alternate-return values.
-@item
-Computed @code{GOTO}.
-@item
-@code{FORMAT} run-time expressions (not yet supported).
-@item
-Dimension lists in specification statements.
-@item
-Numbers for I/O statements (such as @samp{READ (UNIT=3.2), I})
-@item
-Sizes of @code{CHARACTER} entities in specification statements.
-@item
-Kind types in specification entities (a Fortran 90 feature).
-@item
-Initial, terminal, and incrementation parameters for implied-@code{DO}
-constructs in @code{DATA} statements.
-@end itemize
-
-@item
-Automatic conversion of @code{LOGICAL} expressions to @code{INTEGER}
-in contexts such as arithmetic @code{IF} (where @code{COMPLEX}
-expressions are disallowed anyway).
-
-@item
-Zero-size array dimensions, as in:
-
-@example
-INTEGER I(10,20,4:2)
-@end example
-
-@item
-Zero-length @code{CHARACTER} entities, as in:
-
-@example
-PRINT *, ''
-@end example
-
-@item
-Substring operators applied to character constants and named
-constants, as in:
-
-@example
-PRINT *, 'hello'(3:5)
-@end example
-
-@item
-Null arguments passed to statement function, as in:
-
-@example
-PRINT *, FOO(,3)
-@end example
-
-@item
-Disagreement among program units regarding whether a given @code{COMMON}
-area is @code{SAVE}d (for targets where program units in a single source
-file are ``glued'' together as they typically are for UNIX development
-environments).
-
-@item
-Disagreement among program units regarding the size of a
-named @code{COMMON} block.
-
-@item
-Specification statements following first @code{DATA} statement.
-
-(In the GNU Fortran language, @samp{DATA I/1/} may be followed by @samp{INTEGER J},
-but not @samp{INTEGER I}.
-The @option{-fpedantic} option disallows both of these.)
-
-@item
-Semicolon as statement separator, as in:
-
-@example
-CALL FOO; CALL BAR
-@end example
-@c
-@c @item
-@c Comma before list of I/O items in @code{WRITE}
-@c @c, @code{ENCODE}, @code{DECODE}, and @code{REWRITE}
-@c statements, as with @code{READ} (as explained above).
-
-@item
-Use of @samp{&} in column 1 of fixed-form source (to indicate continuation).
-
-@item
-Use of @code{CHARACTER} constants to initialize numeric entities, and vice
-versa.
-
-@item
-Expressions having two arithmetic operators in a row, such
-as @samp{X*-Y}.
-@end itemize
-
-If @option{-fpedantic} is specified along with @option{-ff90}, the
-following constructs result in diagnostics:
-
-@itemize @bullet
-@item
-Use of semicolon as a statement separator on a line
-that has an @code{INCLUDE} directive.
-@end itemize
-
-@node Distensions
-@section Distensions
-@cindex distensions
-@cindex ugly features
-@cindex features, ugly
-
-The @option{-fugly-*} command-line options determine whether certain
-features supported by VAX FORTRAN and other such compilers, but considered
-too ugly to be in code that can be changed to use safer and/or more
-portable constructs, are accepted.
-These are humorously referred to as ``distensions'',
-extensions that just plain look ugly in the harsh light of day.
-
-@menu
-* Ugly Implicit Argument Conversion:: Disabled via @option{-fno-ugly-args}.
-* Ugly Assumed-Size Arrays:: Enabled via @option{-fugly-assumed}.
-* Ugly Null Arguments:: Enabled via @option{-fugly-comma}.
-* Ugly Complex Part Extraction:: Enabled via @option{-fugly-complex}.
-* Ugly Conversion of Initializers:: Disabled via @option{-fno-ugly-init}.
-* Ugly Integer Conversions:: Enabled via @option{-fugly-logint}.
-* Ugly Assigned Labels:: Enabled via @option{-fugly-assign}.
-@end menu
-
-@node Ugly Implicit Argument Conversion
-@subsection Implicit Argument Conversion
-@cindex Hollerith constants
-@cindex constants, Hollerith
-
-The @option{-fno-ugly-args} option disables
-passing typeless and Hollerith constants as actual arguments
-in procedure invocations.
-For example:
-
-@example
-CALL FOO(4HABCD)
-CALL BAR('123'O)
-@end example
-
-@noindent
-These constructs can be too easily used to create non-portable
-code, but are not considered as ``ugly'' as others.
-Further, they are widely used in existing Fortran source code
-in ways that often are quite portable.
-Therefore, they are enabled by default.
-
-@node Ugly Assumed-Size Arrays
-@subsection Ugly Assumed-Size Arrays
-@cindex arrays, assumed-size
-@cindex assumed-size arrays
-@cindex DIMENSION X(1)
-
-The @option{-fugly-assumed} option enables
-the treatment of any array with a final dimension specified as @samp{1}
-as an assumed-size array, as if @samp{*} had been specified
-instead.
-
-For example, @samp{DIMENSION X(1)} is treated as if it
-had read @samp{DIMENSION X(*)} if @samp{X} is listed as
-a dummy argument in a preceding @code{SUBROUTINE}, @code{FUNCTION},
-or @code{ENTRY} statement in the same program unit.
-
-Use an explicit lower bound to avoid this interpretation.
-For example, @samp{DIMENSION X(1:1)} is never treated as if
-it had read @samp{DIMENSION X(*)} or @samp{DIMENSION X(1:*)}.
-Nor is @samp{DIMENSION X(2-1)} affected by this option,
-since that kind of expression is unlikely to have been
-intended to designate an assumed-size array.
-
-This option is used to prevent warnings being issued about apparent
-out-of-bounds reference such as @samp{X(2) = 99}.
-
-It also prevents the array from being used in contexts that
-disallow assumed-size arrays, such as @samp{PRINT *,X}.
-In such cases, a diagnostic is generated and the source file is
-not compiled.
-
-The construct affected by this option is used only in old code
-that pre-exists the widespread acceptance of adjustable and assumed-size
-arrays in the Fortran community.
-
-@emph{Note:} This option does not affect how @samp{DIMENSION X(1)} is
-treated if @samp{X} is listed as a dummy argument only
-@emph{after} the @code{DIMENSION} statement (presumably in
-an @code{ENTRY} statement).
-For example, @option{-fugly-assumed} has no effect on the
-following program unit:
-
-@example
-SUBROUTINE X
-REAL A(1)
-RETURN
-ENTRY Y(A)
-PRINT *, A
-END
-@end example
-
-@node Ugly Complex Part Extraction
-@subsection Ugly Complex Part Extraction
-@cindex complex values
-@cindex real part
-@cindex imaginary part
-
-The @option{-fugly-complex} option enables
-use of the @code{REAL()} and @code{AIMAG()}
-intrinsics with arguments that are
-@code{COMPLEX} types other than @code{COMPLEX(KIND=1)}.
-
-With @option{-ff90} in effect, these intrinsics return
-the unconverted real and imaginary parts (respectively)
-of their argument.
-
-With @option{-fno-f90} in effect, these intrinsics convert
-the real and imaginary parts to @code{REAL(KIND=1)}, and return
-the result of that conversion.
-
-Due to this ambiguity, the GNU Fortran language defines
-these constructs as invalid, except in the specific
-case where they are entirely and solely passed as an
-argument to an invocation of the @code{REAL()} intrinsic.
-For example,
-
-@example
-REAL(REAL(Z))
-@end example
-
-@noindent
-is permitted even when @samp{Z} is @code{COMPLEX(KIND=2)}
-and @option{-fno-ugly-complex} is in effect, because the
-meaning is clear.
-
-@command{g77} enforces this restriction, unless @option{-fugly-complex}
-is specified, in which case the appropriate interpretation is
-chosen and no diagnostic is issued.
-
-@xref{CMPAMBIG}, for information on how to cope with existing
-code with unclear expectations of @code{REAL()} and @code{AIMAG()}
-with @code{COMPLEX(KIND=2)} arguments.
-
-@xref{RealPart Intrinsic}, for information on the @code{REALPART()}
-intrinsic, used to extract the real part of a complex expression
-without conversion.
-@xref{ImagPart Intrinsic}, for information on the @code{IMAGPART()}
-intrinsic, used to extract the imaginary part of a complex expression
-without conversion.
-
-@node Ugly Null Arguments
-@subsection Ugly Null Arguments
-@cindex trailing comma
-@cindex comma, trailing
-@cindex characters, comma
-@cindex null arguments
-@cindex arguments, null
-
-The @option{-fugly-comma} option enables use of a single trailing comma
-to mean ``pass an extra trailing null argument''
-in a list of actual arguments to an external procedure,
-and use of an empty list of arguments to such a procedure
-to mean ``pass a single null argument''.
-
-@cindex omitting arguments
-@cindex arguments, omitting
-(Null arguments often are used in some procedure-calling
-schemes to indicate omitted arguments.)
-
-For example, @samp{CALL FOO(,)} means ``pass
-two null arguments'', rather than ``pass one null argument''.
-Also, @samp{CALL BAR()} means ``pass one null argument''.
-
-This construct is considered ``ugly'' because it does not
-provide an elegant way to pass a single null argument
-that is syntactically distinct from passing no arguments.
-That is, this construct changes the meaning of code that
-makes no use of the construct.
-
-So, with @option{-fugly-comma} in force, @samp{CALL FOO()}
-and @samp{I = JFUNC()} pass a single null argument, instead
-of passing no arguments as required by the Fortran 77 and
-90 standards.
-
-@emph{Note:} Many systems gracefully allow the case
-where a procedure call passes one extra argument that the
-called procedure does not expect.
-
-So, in practice, there might be no difference in
-the behavior of a program that does @samp{CALL FOO()}
-or @samp{I = JFUNC()} and is compiled with @option{-fugly-comma}
-in force as compared to its behavior when compiled
-with the default, @option{-fno-ugly-comma}, in force,
-assuming @samp{FOO} and @samp{JFUNC} do not expect any
-arguments to be passed.
-
-@node Ugly Conversion of Initializers
-@subsection Ugly Conversion of Initializers
-
-The constructs disabled by @option{-fno-ugly-init} are:
-
-@itemize @bullet
-@cindex Hollerith constants
-@cindex constants, Hollerith
-@item
-Use of Hollerith and typeless constants in contexts where they set
-initial (compile-time) values for variables, arrays, and named
-constants---that is, @code{DATA} and @code{PARAMETER} statements, plus
-type-declaration statements specifying initial values.
-
-Here are some sample initializations that are disabled by the
-@option{-fno-ugly-init} option:
-
-@example
-PARAMETER (VAL='9A304FFE'X)
-REAL*8 STRING/8HOUTPUT00/
-DATA VAR/4HABCD/
-@end example
-
-@cindex character constants
-@cindex constants, character
-@item
-In the same contexts as above, use of character constants to initialize
-numeric items and vice versa (one constant per item).
-
-Here are more sample initializations that are disabled by the
-@option{-fno-ugly-init} option:
-
-@example
-INTEGER IA
-CHARACTER BELL
-PARAMETER (IA = 'A')
-PARAMETER (BELL = 7)
-@end example
-
-@item
-Use of Hollerith and typeless constants on the right-hand side
-of assignment statements to numeric types, and in other
-contexts (such as passing arguments in invocations of
-intrinsic procedures and statement functions) that
-are treated as assignments to known types (the dummy
-arguments, in these cases).
-
-Here are sample statements that are disabled by the
-@option{-fno-ugly-init} option:
-
-@example
-IVAR = 4HABCD
-PRINT *, IMAX0(2HAB, 2HBA)
-@end example
-@end itemize
-
-The above constructs, when used,
-can tend to result in non-portable code.
-But, they are widely used in existing Fortran code in ways
-that often are quite portable.
-Therefore, they are enabled by default.
-
-@node Ugly Integer Conversions
-@subsection Ugly Integer Conversions
-
-The constructs enabled via @option{-fugly-logint} are:
-
-@itemize @bullet
-@item
-Automatic conversion between @code{INTEGER} and @code{LOGICAL} as
-dictated by
-context (typically implies nonportable dependencies on how a
-particular implementation encodes @code{.TRUE.} and @code{.FALSE.}).
-
-@item
-Use of a @code{LOGICAL} variable in @code{ASSIGN} and assigned-@code{GOTO}
-statements.
-@end itemize
-
-The above constructs are disabled by default because use
-of them tends to lead to non-portable code.
-Even existing Fortran code that uses that often turns out
-to be non-portable, if not outright buggy.
-
-Some of this is due to differences among implementations as
-far as how @code{.TRUE.} and @code{.FALSE.} are encoded as
-@code{INTEGER} values---Fortran code that assumes a particular
-coding is likely to use one of the above constructs, and is
-also likely to not work correctly on implementations using
-different encodings.
-
-@xref{Equivalence Versus Equality}, for more information.
-
-@node Ugly Assigned Labels
-@subsection Ugly Assigned Labels
-@cindex ASSIGN statement
-@cindex statements, ASSIGN
-@cindex assigned labels
-@cindex pointers
-
-The @option{-fugly-assign} option forces @command{g77} to use the
-same storage for assigned labels as it would for a normal
-assignment to the same variable.
-
-For example, consider the following code fragment:
-
-@example
-I = 3
-ASSIGN 10 TO I
-@end example
-
-@noindent
-Normally, for portability and improved diagnostics, @command{g77}
-reserves distinct storage for a ``sibling'' of @samp{I}, used
-only for @code{ASSIGN} statements to that variable (along with
-the corresponding assigned-@code{GOTO} and assigned-@code{FORMAT}-I/O
-statements that reference the variable).
-
-However, some code (that violates the ANSI FORTRAN 77 standard)
-attempts to copy assigned labels among variables involved with
-@code{ASSIGN} statements, as in:
-
-@example
-ASSIGN 10 TO I
-ISTATE(5) = I
-@dots{}
-J = ISTATE(ICUR)
-GOTO J
-@end example
-
-@noindent
-Such code doesn't work under @command{g77} unless @option{-fugly-assign}
-is specified on the command-line, ensuring that the value of @code{I}
-referenced in the second line is whatever value @command{g77} uses
-to designate statement label @samp{10}, so the value may be
-copied into the @samp{ISTATE} array, later retrieved into a
-variable of the appropriate type (@samp{J}), and used as the target of
-an assigned-@code{GOTO} statement.
-
-@emph{Note:} To avoid subtle program bugs,
-when @option{-fugly-assign} is specified,
-@command{g77} requires the type of variables
-specified in assigned-label contexts
-@emph{must} be the same type returned by @code{%LOC()}.
-On many systems, this type is effectively the same
-as @code{INTEGER(KIND=1)}, while, on others, it is
-effectively the same as @code{INTEGER(KIND=2)}.
-
-Do @emph{not} depend on @command{g77} actually writing valid pointers
-to these variables, however.
-While @command{g77} currently chooses that implementation, it might
-be changed in the future.
-
-@xref{Assigned Statement Labels,,Assigned Statement Labels (ASSIGN and GOTO)},
-for implementation details on assigned-statement labels.
-
-@node Compiler
-@chapter The GNU Fortran Compiler
-
-The GNU Fortran compiler, @command{g77}, supports programs written
-in the GNU Fortran language and in some other dialects of Fortran.
-
-Some aspects of how @command{g77} works are universal regardless
-of dialect, and yet are not properly part of the GNU Fortran
-language itself.
-These are described below.
-
-@emph{Note: This portion of the documentation definitely needs a lot
-of work!}
-
-@menu
-* Compiler Limits::
-* Run-time Environment Limits::
-* Compiler Types::
-* Compiler Constants::
-* Compiler Intrinsics::
-@end menu
-
-@node Compiler Limits
-@section Compiler Limits
-@cindex limits, compiler
-@cindex compiler limits
-
-@command{g77}, as with GNU tools in general, imposes few arbitrary restrictions
-on lengths of identifiers, number of continuation lines, number of external
-symbols in a program, and so on.
-
-@cindex options, -Nl
-@cindex -Nl option
-@cindex options, -Nx
-@cindex -Nx option
-@cindex limits, continuation lines
-@cindex limits, lengths of names
-For example, some other Fortran compiler have an option
-(such as @option{-Nl@var{x}}) to increase the limit on the
-number of continuation lines.
-Also, some Fortran compilation systems have an option
-(such as @option{-Nx@var{x}}) to increase the limit on the
-number of external symbols.
-
-@command{g77}, @command{gcc}, and GNU @command{ld} (the GNU linker) have
-no equivalent options, since they do not impose arbitrary
-limits in these areas.
-
-@cindex rank, maximum
-@cindex maximum rank
-@cindex number of dimensions, maximum
-@cindex maximum number of dimensions
-@cindex limits, rank
-@cindex limits, array dimensions
-@command{g77} does currently limit the number of dimensions in an array
-to the same degree as do the Fortran standards---seven (7).
-This restriction might be lifted in a future version.
-
-@node Run-time Environment Limits
-@section Run-time Environment Limits
-@cindex limits, run-time library
-@cindex wraparound
-
-As a portable Fortran implementation,
-@command{g77} offers its users direct access to,
-and otherwise depends upon,
-the underlying facilities of the system
-used to build @command{g77},
-the system on which @command{g77} itself is used to compile programs,
-and the system on which the @command{g77}-compiled program is actually run.
-(For most users, the three systems are of the same
-type---combination of operating environment and hardware---often
-the same physical system.)
-
-The run-time environment for a particular system
-inevitably imposes some limits on a program's use
-of various system facilities.
-These limits vary from system to system.
-
-Even when such limits might be well beyond the
-possibility of being encountered on a particular system,
-the @command{g77} run-time environment
-has certain built-in limits,
-usually, but not always, stemming from intrinsics
-with inherently limited interfaces.
-
-Currently, the @command{g77} run-time environment
-does not generally offer a less-limiting environment
-by augmenting the underlying system's own environment.
-
-Therefore, code written in the GNU Fortran language,
-while syntactically and semantically portable,
-might nevertheless make non-portable assumptions
-about the run-time environment---assumptions that
-prove to be false for some particular environments.
-
-The GNU Fortran language,
-the @command{g77} compiler and run-time environment,
-and the @command{g77} documentation
-do not yet offer comprehensive portable work-arounds for such limits,
-though programmers should be able to
-find their own in specific instances.
-
-Not all of the limitations are described in this document.
-Some of the known limitations include:
-
-@menu
-* Timer Wraparounds::
-* Year 2000 (Y2K) Problems::
-* Array Size::
-* Character-variable Length::
-* Year 10000 (Y10K) Problems::
-@end menu
-
-@node Timer Wraparounds
-@subsection Timer Wraparounds
-
-Intrinsics that return values computed from system timers,
-whether elapsed (wall-clock) timers,
-process CPU timers,
-or other kinds of timers,
-are prone to experiencing wrap-around errors
-(or returning wrapped-around values from successive calls)
-due to insufficient ranges
-offered by the underlying system's timers.
-
-@cindex negative time
-@cindex short time
-@cindex long time
-Some of the symptoms of such behaviors include
-apparently negative time being computed for a duration,
-an extremely short amount of time being computed for a long duration,
-and an extremely long amount of time being computed for a short duration.
-
-See the following for intrinsics
-known to have potential problems in these areas
-on at least some systems:
-@ref{CPU_Time Intrinsic},
-@ref{DTime Intrinsic (function)}, @ref{DTime Intrinsic (subroutine)},
-@ref{ETime Intrinsic (function)}, @ref{ETime Intrinsic (subroutine)},
-@ref{MClock Intrinsic}, @ref{MClock8 Intrinsic},
-@ref{Secnds Intrinsic},
-@ref{Second Intrinsic (function)}, @ref{Second Intrinsic (subroutine)},
-@ref{System_Clock Intrinsic},
-@ref{Time Intrinsic (UNIX)}, @ref{Time Intrinsic (VXT)},
-@ref{Time8 Intrinsic}.
-
-@node Year 2000 (Y2K) Problems
-@subsection Year 2000 (Y2K) Problems
-@cindex Y2K compliance
-@cindex Year 2000 compliance
-
-While the @command{g77} compiler itself is believed to
-be Year-2000 (Y2K) compliant,
-some intrinsics are not,
-and, potentially, some underlying systems are not,
-perhaps rendering some Y2K-compliant intrinsics
-non-compliant when used on those particular systems.
-
-Fortran code that uses non-Y2K-compliant intrinsics
-(listed below)
-is, itself, almost certainly not compliant,
-and should be modified to use Y2K-compliant intrinsics instead.
-
-Fortran code that uses no non-Y2K-compliant intrinsics,
-but which currently is running on a non-Y2K-compliant system,
-can be made more Y2K compliant by compiling and
-linking it for use on a new Y2K-compliant system,
-such as a new version of an old, non-Y2K-compliant, system.
-
-Currently, information on Y2K and related issues
-is being maintained at
-@uref{http://www.gnu.org/software/year2000-list.html}.
-
-See the following for intrinsics
-known to have potential problems in these areas
-on at least some systems:
-@ref{Date Intrinsic},
-@ref{IDate Intrinsic (VXT)}.
-
-@cindex y2kbuggy
-@cindex date_y2kbuggy_0
-@cindex vxtidate_y2kbuggy_0
-@cindex G77_date_y2kbuggy_0
-@cindex G77_vxtidate_y2kbuggy_0
-The @code{libg2c} library
-shipped with any @command{g77} that warns
-about invocation of a non-Y2K-compliant intrinsic
-has renamed the @code{EXTERNAL} procedure names
-of those intrinsics.
-This is done so that
-the @code{libg2c} implementations of these intrinsics
-cannot be directly linked to
-as @code{EXTERNAL} names
-(which normally would avoid the non-Y2K-intrinsic warning).
-
-The renamed forms of the @code{EXTERNAL} names
-of these renamed procedures
-may be linked to
-by appending the string @samp{_y2kbug}
-to the name of the procedure
-in the source code.
-For example:
-
-@smallexample
-CHARACTER*20 STR
-INTEGER YY, MM, DD
-EXTERNAL DATE_Y2KBUG, VXTIDATE_Y2KBUG
-CALL DATE_Y2KBUG (STR)
-CALL VXTIDATE_Y2KBUG (MM, DD, YY)
-@end smallexample
-
-(Note that the @code{EXTERNAL} statement
-is not actually required,
-since the modified names are not recognized as intrinsics
-by the current version of @command{g77}.
-But it is shown in this specific case,
-for purposes of illustration.)
-
-The renaming of @code{EXTERNAL} procedure names of these intrinsics
-causes unresolved references at link time.
-For example, @samp{EXTERNAL DATE; CALL DATE(STR)}
-is normally compiled by @command{g77}
-as, in C, @samp{date_(&str, 20);}.
-This, in turn, links to the @code{date_} procedure
-in the @code{libE77} portion of @code{libg2c},
-which purposely calls a nonexistent procedure
-named @code{G77_date_y2kbuggy_0}.
-The resulting link-time error is designed, via this name,
-to encourage the programmer to look up the
-index entries to this portion of the @command{g77} documentation.
-
-Generally, we recommend that the @code{EXTERNAL} method
-of invoking procedures in @code{libg2c}
-@emph{not} be used.
-When used, some of the correctness checking
-normally performed by @command{g77}
-is skipped.
-
-In particular, it is probably better to use the
-@code{INTRINSIC} method of invoking
-non-Y2K-compliant procedures,
-so anyone compiling the code
-can quickly notice the potential Y2K problems
-(via the warnings printing by @command{g77})
-without having to even look at the code itself.
-
-If there are problems linking @code{libg2c}
-to code compiled by @command{g77}
-that involve the string @samp{y2kbug},
-and these are not explained above,
-that probably indicates
-that a version of @code{libg2c}
-older than @command{g77}
-is being linked to,
-or that the new library is being linked
-to code compiled by an older version of @command{g77}.
-
-That's because, as of the version that warns about
-non-Y2K-compliant intrinsic invocation,
-@command{g77} references the @code{libg2c} implementations
-of those intrinsics
-using new names, containing the string @samp{y2kbug}.
-
-So, linking newly-compiled code
-(invoking one of the intrinsics in question)
-to an old library
-might yield an unresolved reference
-to @code{G77_date_y2kbug_0}.
-(The old library calls it @code{G77_date_0}.)
-
-Similarly, linking previously-compiled code
-to a new library
-might yield an unresolved reference
-to @code{G77_vxtidate_0}.
-(The new library calls it @code{G77_vxtidate_y2kbug_0}.)
-
-The proper fix for the above problems
-is to obtain the latest release of @command{g77}
-and related products
-(including @code{libg2c})
-and install them on all systems,
-then recompile, relink, and install
-(as appropriate)
-all existing Fortran programs.
-
-(Normally, this sort of renaming is steadfastly avoided.
-In this case, however, it seems more important to highlight
-potential Y2K problems
-than to ease the transition
-of potentially non-Y2K-compliant code
-to new versions of @command{g77} and @code{libg2c}.)
-
-@node Array Size
-@subsection Array Size
-@cindex limits, array size
-@cindex array size
-
-Currently, @command{g77} uses the default @code{INTEGER} type
-for array indexes,
-which limits the sizes of single-dimension arrays
-on systems offering a larger address space
-than can be addressed by that type.
-(That @command{g77} puts all arrays in memory
-could be considered another limitation---it
-could use large temporary files---but that decision
-is left to the programmer as an implementation choice
-by most Fortran implementations.)
-
-@c ??? Investigate this, to offer a more clear statement
-@c than the following paragraphs do. -- burley 1999-02-17
-It is not yet clear whether this limitation
-never, sometimes, or always applies to the
-sizes of multiple-dimension arrays as a whole.
-
-For example, on a system with 64-bit addresses
-and 32-bit default @code{INTEGER},
-an array with a size greater than can be addressed
-by a 32-bit offset
-can be declared using multiple dimensions.
-Such an array is therefore larger
-than a single-dimension array can be,
-on the same system.
-
-@cindex limits, multi-dimension arrays
-@cindex multi-dimension arrays
-@cindex arrays, dimensioning
-Whether large multiple-dimension arrays are reliably supported
-depends mostly on the @command{gcc} back end (code generator)
-used by @command{g77}, and has not yet been fully investigated.
-
-@node Character-variable Length
-@subsection Character-variable Length
-@cindex limits, on character-variable length
-@cindex character-variable length
-
-Currently, @command{g77} uses the default @code{INTEGER} type
-for the lengths of @code{CHARACTER} variables
-and array elements.
-
-This means that, for example,
-a system with a 64-bit address space
-and a 32-bit default @code{INTEGER} type
-does not, under @command{g77},
-support a @code{CHARACTER*@var{n}} declaration
-where @var{n} is greater than 2147483647.
-
-@node Year 10000 (Y10K) Problems
-@subsection Year 10000 (Y10K) Problems
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-
-Most intrinsics returning, or computing values based on,
-date information are prone to Year-10000 (Y10K) problems,
-due to supporting only 4 digits for the year.
-
-See the following for examples:
-@ref{FDate Intrinsic (function)}, @ref{FDate Intrinsic (subroutine)},
-@ref{IDate Intrinsic (UNIX)},
-@ref{Time Intrinsic (VXT)},
-@ref{Date_and_Time Intrinsic}.
-
-@node Compiler Types
-@section Compiler Types
-@cindex types, of data
-@cindex data types
-
-Fortran implementations have a fair amount of freedom given them by the
-standard as far as how much storage space is used and how much precision
-and range is offered by the various types such as @code{LOGICAL(KIND=1)},
-@code{INTEGER(KIND=1)}, @code{REAL(KIND=1)}, @code{REAL(KIND=2)},
-@code{COMPLEX(KIND=1)}, and @code{CHARACTER}.
-Further, many compilers offer so-called @samp{*@var{n}} notation, but
-the interpretation of @var{n} varies across compilers and target architectures.
-
-The standard requires that @code{LOGICAL(KIND=1)}, @code{INTEGER(KIND=1)},
-and @code{REAL(KIND=1)}
-occupy the same amount of storage space, and that @code{COMPLEX(KIND=1)}
-and @code{REAL(KIND=2)} take twice as much storage space as @code{REAL(KIND=1)}.
-Further, it requires that @code{COMPLEX(KIND=1)}
-entities be ordered such that when a @code{COMPLEX(KIND=1)} variable is
-storage-associated (such as via @code{EQUIVALENCE})
-with a two-element @code{REAL(KIND=1)} array named @samp{R}, @samp{R(1)}
-corresponds to the real element and @samp{R(2)} to the imaginary
-element of the @code{COMPLEX(KIND=1)} variable.
-
-(Few requirements as to precision or ranges of any of these are
-placed on the implementation, nor is the relationship of storage sizes of
-these types to the @code{CHARACTER} type specified, by the standard.)
-
-@command{g77} follows the above requirements, warning when compiling
-a program requires placement of items in memory that contradict the
-requirements of the target architecture.
-(For example, a program can require placement of a @code{REAL(KIND=2)}
-on a boundary that is not an even multiple of its size, but still an
-even multiple of the size of a @code{REAL(KIND=1)} variable.
-On some target architectures, using the canonical
-mapping of Fortran types to underlying architectural types, such
-placement is prohibited by the machine definition or
-the Application Binary Interface (ABI) in force for
-the configuration defined for building @command{gcc} and @command{g77}.
-@command{g77} warns about such
-situations when it encounters them.)
-
-@command{g77} follows consistent rules for configuring the mapping between Fortran
-types, including the @samp{*@var{n}} notation, and the underlying architectural
-types as accessed by a similarly-configured applicable version of the
-@command{gcc} compiler.
-These rules offer a widely portable, consistent Fortran/C
-environment, although they might well conflict with the expectations of
-users of Fortran compilers designed and written for particular
-architectures.
-
-These rules are based on the configuration that is in force for the
-version of @command{gcc} built in the same release as @command{g77} (and
-which was therefore used to build both the @command{g77} compiler
-components and the @code{libg2c} run-time library):
-
-@table @code
-@cindex REAL(KIND=1) type
-@cindex types, REAL(KIND=1)
-@item REAL(KIND=1)
-Same as @code{float} type.
-
-@cindex REAL(KIND=2) type
-@cindex types, REAL(KIND=2)
-@item REAL(KIND=2)
-Same as whatever floating-point type that is twice the size
-of a @code{float}---usually, this is a @code{double}.
-
-@cindex INTEGER(KIND=1) type
-@cindex types, INTEGER(KIND=1)
-@item INTEGER(KIND=1)
-Same as an integral type that is occupies the same amount
-of memory storage as @code{float}---usually, this is either
-an @code{int} or a @code{long int}.
-
-@cindex LOGICAL(KIND=1) type
-@cindex types, LOGICAL(KIND=1)
-@item LOGICAL(KIND=1)
-Same @command{gcc} type as @code{INTEGER(KIND=1)}.
-
-@cindex INTEGER(KIND=2) type
-@cindex types, INTEGER(KIND=2)
-@item INTEGER(KIND=2)
-Twice the size, and usually nearly twice the range,
-as @code{INTEGER(KIND=1)}---usually, this is either
-a @code{long int} or a @code{long long int}.
-
-@cindex LOGICAL(KIND=2) type
-@cindex types, LOGICAL(KIND=2)
-@item LOGICAL(KIND=2)
-Same @command{gcc} type as @code{INTEGER(KIND=2)}.
-
-@cindex INTEGER(KIND=3) type
-@cindex types, INTEGER(KIND=3)
-@item INTEGER(KIND=3)
-Same @command{gcc} type as signed @code{char}.
-
-@cindex LOGICAL(KIND=3) type
-@cindex types, LOGICAL(KIND=3)
-@item LOGICAL(KIND=3)
-Same @command{gcc} type as @code{INTEGER(KIND=3)}.
-
-@cindex INTEGER(KIND=6) type
-@cindex types, INTEGER(KIND=6)
-@item INTEGER(KIND=6)
-Twice the size, and usually nearly twice the range,
-as @code{INTEGER(KIND=3)}---usually, this is
-a @code{short}.
-
-@cindex LOGICAL(KIND=6) type
-@cindex types, LOGICAL(KIND=6)
-@item LOGICAL(KIND=6)
-Same @command{gcc} type as @code{INTEGER(KIND=6)}.
-
-@cindex COMPLEX(KIND=1) type
-@cindex types, COMPLEX(KIND=1)
-@item COMPLEX(KIND=1)
-Two @code{REAL(KIND=1)} scalars (one for the real part followed by
-one for the imaginary part).
-
-@cindex COMPLEX(KIND=2) type
-@cindex types, COMPLEX(KIND=2)
-@item COMPLEX(KIND=2)
-Two @code{REAL(KIND=2)} scalars.
-
-@cindex *@var{n} notation
-@item @var{numeric-type}*@var{n}
-(Where @var{numeric-type} is any type other than @code{CHARACTER}.)
-Same as whatever @command{gcc} type occupies @var{n} times the storage
-space of a @command{gcc} @code{char} item.
-
-@cindex DOUBLE PRECISION type
-@cindex types, DOUBLE PRECISION
-@item DOUBLE PRECISION
-Same as @code{REAL(KIND=2)}.
-
-@cindex DOUBLE COMPLEX type
-@cindex types, DOUBLE COMPLEX
-@item DOUBLE COMPLEX
-Same as @code{COMPLEX(KIND=2)}.
-@end table
-
-Note that the above are proposed correspondences and might change
-in future versions of @command{g77}---avoid writing code depending
-on them.
-
-Other types supported by @command{g77}
-are derived from gcc types such as @code{char}, @code{short},
-@code{int}, @code{long int}, @code{long long int}, @code{long double},
-and so on.
-That is, whatever types @command{gcc} already supports, @command{g77} supports
-now or probably will support in a future version.
-The rules for the @samp{@var{numeric-type}*@var{n}} notation
-apply to these types,
-and new values for @samp{@var{numeric-type}(KIND=@var{n})} will be
-assigned in a way that encourages clarity, consistency, and portability.
-
-@node Compiler Constants
-@section Compiler Constants
-@cindex constants
-@cindex types, constants
-
-@command{g77} strictly assigns types to @emph{all} constants not
-documented as ``typeless'' (typeless constants including @samp{'1'Z},
-for example).
-Many other Fortran compilers attempt to assign types to typed constants
-based on their context.
-This results in hard-to-find bugs, nonportable
-code, and is not in the spirit (though it strictly follows the letter)
-of the 77 and 90 standards.
-
-@command{g77} might offer, in a future release, explicit constructs by
-which a wider variety of typeless constants may be specified, and/or
-user-requested warnings indicating places where @command{g77} might differ
-from how other compilers assign types to constants.
-
-@xref{Context-Sensitive Constants}, for more information on this issue.
-
-@node Compiler Intrinsics
-@section Compiler Intrinsics
-
-@command{g77} offers an ever-widening set of intrinsics.
-Currently these all are procedures (functions and subroutines).
-
-Some of these intrinsics are unimplemented, but their names reserved
-to reduce future problems with existing code as they are implemented.
-Others are implemented as part of the GNU Fortran language, while
-yet others are provided for compatibility with other dialects of
-Fortran but are not part of the GNU Fortran language.
-
-To manage these distinctions, @command{g77} provides intrinsic @emph{groups},
-a facility that is simply an extension of the intrinsic groups provided
-by the GNU Fortran language.
-
-@menu
-* Intrinsic Groups:: How intrinsics are grouped for easy management.
-* Other Intrinsics:: Intrinsics other than those in the GNU
- Fortran language.
-@end menu
-
-@node Intrinsic Groups
-@subsection Intrinsic Groups
-@cindex groups of intrinsics
-@cindex intrinsics, groups
-
-A given specific intrinsic belongs in one or more groups.
-Each group is deleted, disabled, hidden, or enabled
-by default or a command-line option.
-The meaning of each term follows.
-
-@table @b
-@cindex deleted intrinsics
-@cindex intrinsics, deleted
-@item Deleted
-No intrinsics are recognized as belonging to that group.
-
-@cindex disabled intrinsics
-@cindex intrinsics, disabled
-@item Disabled
-Intrinsics are recognized as belonging to the group, but
-references to them (other than via the @code{INTRINSIC} statement)
-are disallowed through that group.
-
-@cindex hidden intrinsics
-@cindex intrinsics, hidden
-@item Hidden
-Intrinsics in that group are recognized and enabled (if implemented)
-@emph{only} if the first mention of the actual name of an intrinsic
-in a program unit is in an @code{INTRINSIC} statement.
-
-@cindex enabled intrinsics
-@cindex intrinsics, enabled
-@item Enabled
-Intrinsics in that group are recognized and enabled (if implemented).
-@end table
-
-The distinction between deleting and disabling a group is illustrated
-by the following example.
-Assume intrinsic @samp{FOO} belongs only to group @samp{FGR}.
-If group @samp{FGR} is deleted, the following program unit will
-successfully compile, because @samp{FOO()} will be seen as a
-reference to an external function named @samp{FOO}:
-
-@example
-PRINT *, FOO()
-END
-@end example
-
-@noindent
-If group @samp{FGR} is disabled, compiling the above program will produce
-diagnostics, either because the @samp{FOO} intrinsic is improperly invoked
-or, if properly invoked, it is not enabled.
-To change the above program so it references an external function @samp{FOO}
-instead of the disabled @samp{FOO} intrinsic,
-add the following line to the top:
-
-@example
-EXTERNAL FOO
-@end example
-
-@noindent
-So, deleting a group tells @command{g77} to pretend as though the intrinsics in
-that group do not exist at all, whereas disabling it tells @command{g77} to
-recognize them as (disabled) intrinsics in intrinsic-like contexts.
-
-Hiding a group is like enabling it, but the intrinsic must be first
-named in an @code{INTRINSIC} statement to be considered a reference to the
-intrinsic rather than to an external procedure.
-This might be the ``safest'' way to treat a new group of intrinsics
-when compiling old
-code, because it allows the old code to be generally written as if
-those new intrinsics never existed, but to be changed to use them
-by inserting @code{INTRINSIC} statements in the appropriate places.
-However, it should be the goal of development to use @code{EXTERNAL}
-for all names of external procedures that might be intrinsic names.
-
-If an intrinsic is in more than one group, it is enabled if any of its
-containing groups are enabled; if not so enabled, it is hidden if
-any of its containing groups are hidden; if not so hidden, it is disabled
-if any of its containing groups are disabled; if not so disabled, it is
-deleted.
-This extra complication is necessary because some intrinsics,
-such as @code{IBITS}, belong to more than one group, and hence should be
-enabled if any of the groups to which they belong are enabled, and so
-on.
-
-The groups are:
-
-@cindex intrinsics, groups of
-@cindex groups of intrinsics
-@table @code
-@cindex @code{badu77} intrinsics group
-@item badu77
-UNIX intrinsics having inappropriate forms (usually functions that
-have intended side effects).
-
-@cindex @code{gnu} intrinsics group
-@item gnu
-Intrinsics the GNU Fortran language supports that are extensions to
-the Fortran standards (77 and 90).
-
-@cindex @command{f2c} intrinsics group
-@item f2c
-Intrinsics supported by AT&T's @command{f2c} converter and/or @code{libf2c}.
-
-@cindex @code{f90} intrinsics group
-@item f90
-Fortran 90 intrinsics.
-
-@cindex @code{mil} intrinsics group
-@item mil
-MIL-STD 1753 intrinsics (@code{MVBITS}, @code{IAND}, @code{BTEST}, and so on).
-
-@cindex @code{mil} intrinsics group
-@item unix
-UNIX intrinsics (@code{IARGC}, @code{EXIT}, @code{ERF}, and so on).
-
-@cindex @code{mil} intrinsics group
-@item vxt
-VAX/VMS FORTRAN (current as of v4) intrinsics.
-@end table
-
-@node Other Intrinsics
-@subsection Other Intrinsics
-@cindex intrinsics, others
-@cindex other intrinsics
-
-@command{g77} supports intrinsics other than those in the GNU Fortran
-language proper.
-This set of intrinsics is described below.
-
-@ifinfo
-(Note that the empty lines appearing in the menu below
-are not intentional---they result from a bug in the
-@code{makeinfo} program.)
-@end ifinfo
-
-@c The actual documentation for intrinsics comes from
-@c intdoc.texi, which in turn is automatically generated
-@c from the internal g77 tables in intrin.def _and_ the
-@c largely hand-written text in intdoc.h. So, if you want
-@c to change or add to existing documentation on intrinsics,
-@c you probably want to edit intdoc.h.
-@c
-@clear familyF77
-@clear familyGNU
-@clear familyASC
-@clear familyMIL
-@clear familyF90
-@set familyVXT
-@set familyFVZ
-@clear familyF2C
-@clear familyF2U
-@set familyBADU77
-@include intdoc.texi
-
-@node Other Compilers
-@chapter Other Compilers
-
-An individual Fortran source file can be compiled to
-an object (@file{*.o}) file instead of to the final
-program executable.
-This allows several portions of a program to be compiled
-at different times and linked together whenever a new
-version of the program is needed.
-However, it introduces the issue of @dfn{object compatibility}
-across the various object files (and libraries, or @file{*.a}
-files) that are linked together to produce any particular
-executable file.
-
-Object compatibility is an issue when combining, in one
-program, Fortran code compiled by more than one compiler
-(or more than one configuration of a compiler).
-If the compilers
-disagree on how to transform the names of procedures, there
-will normally be errors when linking such programs.
-Worse, if the compilers agree on naming, but disagree on issues
-like how to pass parameters, return arguments, and lay out
-@code{COMMON} areas, the earliest detected errors might be the
-incorrect results produced by the program (and that assumes
-these errors are detected, which is not always the case).
-
-Normally, @command{g77} generates code that is
-object-compatible with code generated by a version of
-@command{f2c} configured (with, for example, @file{f2c.h} definitions)
-to be generally compatible with @command{g77} as built by @command{gcc}.
-(Normally, @command{f2c} will, by default, conform to the appropriate
-configuration, but it is possible that older or perhaps even newer
-versions of @command{f2c}, or versions having certain configuration changes
-to @command{f2c} internals, will produce object files that are
-incompatible with @command{g77}.)
-
-For example, a Fortran string subroutine
-argument will become two arguments on the C side: a @code{char *}
-and an @code{int} length.
-
-Much of this compatibility results from the fact that
-@command{g77} uses the same run-time library,
-@code{libf2c}, used by @command{f2c},
-though @command{g77} gives its version the name @code{libg2c}
-so as to avoid conflicts when linking,
-installing them in the same directories,
-and so on.
-
-Other compilers might or might not generate code that
-is object-compatible with @code{libg2c} and current @command{g77},
-and some might offer such compatibility only when explicitly
-selected via a command-line option to the compiler.
-
-@emph{Note: This portion of the documentation definitely needs a lot
-of work!}
-
-@menu
-* Dropping f2c Compatibility:: When speed is more important.
-* Compilers Other Than f2c:: Interoperation with code from other compilers.
-@end menu
-
-@node Dropping f2c Compatibility
-@section Dropping @command{f2c} Compatibility
-
-Specifying @option{-fno-f2c} allows @command{g77} to generate, in
-some cases, faster code, by not needing to allow to the possibility
-of linking with code compiled by @command{f2c}.
-
-For example, this affects how @code{REAL(KIND=1)},
-@code{COMPLEX(KIND=1)}, and @code{COMPLEX(KIND=2)} functions are called.
-With @option{-fno-f2c}, they are
-compiled as returning the appropriate @command{gcc} type
-(@code{float}, @code{__complex__ float}, @code{__complex__ double},
-in many configurations).
-
-With @option{-ff2c} in force, they
-are compiled differently (with perhaps slower run-time performance)
-to accommodate the restrictions inherent in @command{f2c}'s use of K&R
-C as an intermediate language---@code{REAL(KIND=1)} functions
-return C's @code{double} type, while @code{COMPLEX} functions return
-@code{void} and use an extra argument pointing to a place for the functions to
-return their values.
-
-It is possible that, in some cases, leaving @option{-ff2c} in force
-might produce faster code than using @option{-fno-f2c}.
-Feel free to experiment, but remember to experiment with changing the way
-@emph{entire programs and their Fortran libraries are compiled} at
-a time, since this sort of experimentation affects the interface
-of code generated for a Fortran source file---that is, it affects
-object compatibility.
-
-Note that @command{f2c} compatibility is a fairly static target to achieve,
-though not necessarily perfectly so, since, like @command{g77}, it is
-still being improved.
-However, specifying @option{-fno-f2c} causes @command{g77}
-to generate code that will probably be incompatible with code
-generated by future versions of @command{g77} when the same option
-is in force.
-You should make sure you are always able to recompile complete
-programs from source code when upgrading to new versions of @command{g77}
-or @command{f2c}, especially when using options such as @option{-fno-f2c}.
-
-Therefore, if you are using @command{g77} to compile libraries and other
-object files for possible future use and you don't want to require
-recompilation for future use with subsequent versions of @command{g77},
-you might want to stick with @command{f2c} compatibility for now, and
-carefully watch for any announcements about changes to the
-@command{f2c}/@code{libf2c} interface that might affect existing programs
-(thus requiring recompilation).
-
-It is probable that a future version of @command{g77} will not,
-by default, generate object files compatible with @command{f2c},
-and that version probably would no longer use @code{libf2c}.
-If you expect to depend on this compatibility in the
-long term, use the options @samp{-ff2c -ff2c-library} when compiling
-all of the applicable code.
-This should cause future versions of @command{g77} either to produce
-compatible code (at the expense of the availability of some features and
-performance), or at the very least, to produce diagnostics.
-
-(The library @command{g77} produces will no longer be named @file{libg2c}
-when it is no longer generally compatible with @file{libf2c}.
-It will likely be referred to, and, if installed as a distinct
-library, named @code{libg77}, or some other as-yet-unused name.)
-
-@node Compilers Other Than f2c
-@section Compilers Other Than @command{f2c}
-
-On systems with Fortran compilers other than @command{f2c} and @command{g77},
-code compiled by @command{g77} is not expected to work
-well with code compiled by the native compiler.
-(This is true for @command{f2c}-compiled objects as well.)
-Libraries compiled with the native compiler probably will have
-to be recompiled with @command{g77} to be used with @command{g77}-compiled code.
-
-Reasons for such incompatibilities include:
-
-@itemize @bullet
-@item
-There might be differences in the way names of Fortran procedures
-are translated for use in the system's object-file format.
-For example, the statement @samp{CALL FOO} might be compiled
-by @command{g77} to call a procedure the linker @command{ld} sees
-given the name @samp{_foo_}, while the apparently corresponding
-statement @samp{SUBROUTINE FOO} might be compiled by the
-native compiler to define the linker-visible name @samp{_foo},
-or @samp{_FOO_}, and so on.
-
-@item
-There might be subtle type mismatches which cause subroutine arguments
-and function return values to get corrupted.
-
-This is why simply getting @command{g77} to
-transform procedure names the same way a native
-compiler does is not usually a good idea---unless
-some effort has been made to ensure that, aside
-from the way the two compilers transform procedure
-names, everything else about the way they generate
-code for procedure interfaces is identical.
-
-@item
-Native compilers
-use libraries of private I/O routines which will not be available
-at link time unless you have the native compiler---and you would
-have to explicitly ask for them.
-
-For example, on the Sun you
-would have to add @samp{-L/usr/lang/SCx.x -lF77 -lV77} to the link
-command.
-@end itemize
-
-@node Other Languages
-@chapter Other Languages
-
-@emph{Note: This portion of the documentation definitely needs a lot
-of work!}
-
-@menu
-* Interoperating with C and C++::
-@end menu
-
-@node Interoperating with C and C++
-@section Tools and advice for interoperating with C and C++
-
-@cindex C, linking with
-@cindex C++, linking with
-@cindex linking with C
-The following discussion assumes that you are running @command{g77} in @command{f2c}
-compatibility mode, i.e.@: not using @option{-fno-f2c}.
-It provides some
-advice about quick and simple techniques for linking Fortran and C (or
-C++), the most common requirement.
-For the full story consult the
-description of code generation.
-@xref{Debugging and Interfacing}.
-
-When linking Fortran and C, it's usually best to use @command{g77} to do
-the linking so that the correct libraries are included (including the
-maths one).
-If you're linking with C++ you will want to add
-@option{-lstdc++}, @option{-lg++} or whatever.
-If you need to use another
-driver program (or @command{ld} directly),
-you can find out what linkage
-options @command{g77} passes by running @samp{g77 -v}.
-
-@menu
-* C Interfacing Tools::
-* C Access to Type Information::
-* f2c Skeletons and Prototypes::
-* C++ Considerations::
-* Startup Code::
-@end menu
-
-@node C Interfacing Tools
-@subsection C Interfacing Tools
-@pindex f2c
-@cindex cfortran.h
-@cindex Netlib
-Even if you don't actually use it as a compiler, @command{f2c} from
-@uref{ftp://ftp.netlib.org/f2c/src}, can be a useful tool when you're
-interfacing (linking) Fortran and C@.
-@xref{f2c Skeletons and Prototypes,,Generating Skeletons and Prototypes with @command{f2c}}.
-
-To use @command{f2c} for this purpose you only need retrieve and
-build the @file{src} directory from the distribution, consult the
-@file{README} instructions there for machine-specifics, and install the
-@command{f2c} program on your path.
-
-Something else that might be useful is @samp{cfortran.h} from
-@uref{ftp://zebra.desy.de/cfortran}.
-This is a fairly general tool which
-can be used to generate interfaces for calling in both directions
-between Fortran and C@.
-It can be used in @command{f2c} mode with
-@command{g77}---consult its documentation for details.
-
-@node C Access to Type Information
-@subsection Accessing Type Information in C
-
-@cindex types, Fortran/C
-Generally, C code written to link with
-@command{g77} code---calling and/or being
-called from Fortran---should @samp{#include <g2c.h>} to define the C
-versions of the Fortran types.
-Don't assume Fortran @code{INTEGER} types
-correspond to C @code{int}s, for instance; instead, declare them as
-@code{integer}, a type defined by @file{g2c.h}.
-@file{g2c.h} is installed where @command{gcc} will find it by
-default, assuming you use a copy of @command{gcc} compatible with
-@command{g77}, probably built at the same time as @command{g77}.
-
-@node f2c Skeletons and Prototypes
-@subsection Generating Skeletons and Prototypes with @command{f2c}
-
-@pindex f2c
-@cindex -fno-second-underscore
-A simple and foolproof way to write @command{g77}-callable C routines---e.g.@: to
-interface with an existing library---is to write a file (named, for
-example, @file{fred.f}) of dummy Fortran
-skeletons comprising just the declaration of the routine(s) and dummy
-arguments plus @code{END} statements.
-Then run @command{f2c} on file @file{fred.f} to produce @file{fred.c}
-into which you can edit
-useful code, confident the calling sequence is correct, at least.
-(There are some errors otherwise commonly made in generating C
-interfaces with @command{f2c} conventions,
-such as not using @code{doublereal}
-as the return type of a @code{REAL} @code{FUNCTION}.)
-
-@pindex ftnchek
-@command{f2c} also can help with calling Fortran from C, using its
-@option{-P} option to generate C prototypes appropriate for calling the
-Fortran.@footnote{The files generated like this can also be used for
-inter-unit consistency checking of dummy and actual arguments, although
-the @command{ftnchek} tool from @uref{ftp://ftp.netlib.org/fortran}
-or @uref{ftp://ftp.dsm.fordham.edu} is
-probably better for this purpose.}
-If the Fortran code containing any
-routines to be called from C is in file @file{joe.f}, use the command
-@kbd{f2c -P joe.f} to generate the file @file{joe.P} containing
-prototype information.
-@code{#include} this in the C which has to call
-the Fortran routines to make sure you get it right.
-
-@xref{Arrays,,Arrays (DIMENSION)}, for information on the differences
-between the way Fortran (including compilers like @command{g77}) and
-C handle arrays.
-
-@node C++ Considerations
-@subsection C++ Considerations
-
-@cindex C++
-@command{f2c} can be used to generate suitable code for compilation with a
-C++ system using the @option{-C++} option.
-The important thing about linking @command{g77}-compiled
-code with C++ is that the prototypes for the @command{g77}
-routines must specify C linkage to avoid name mangling.
-So, use an @samp{extern "C"} declaration.
-@command{f2c}'s @option{-C++} option will not take care
-of this when generating skeletons or prototype files as above, however,
-it will avoid clashes with C++ reserved words in addition to those in C@.
-
-@node Startup Code
-@subsection Startup Code
-
-@cindex startup code
-@cindex run-time, initialization
-@cindex initialization, run-time
-Unlike with some runtime systems,
-it shouldn't be necessary
-(unless there are bugs)
-to use a Fortran main program unit to ensure the
-runtime---specifically the I/O system---is initialized.
-
-However, to use the @command{g77} intrinsics @code{GETARG} and @code{IARGC},
-either the @code{main} routine from the @file{libg2c} library must be used,
-or the @code{f_setarg} routine
-(new as of @code{egcs} version 1.1 and @command{g77} version 0.5.23)
-must be called with the appropriate @code{argc} and @code{argv} arguments
-prior to the program calling @code{GETARG} or @code{IARGC}.
-
-To provide more flexibility for mixed-language programming
-involving @command{g77} while allowing for shared libraries,
-as of @code{egcs} version 1.1 and @command{g77} version 0.5.23,
-@command{g77}'s @code{main} routine in @code{libg2c}
-does the following, in order:
-
-@enumerate
-@item
-Calls @code{f_setarg}
-with the incoming @code{argc} and @code{argv} arguments,
-in the same order as for @code{main} itself.
-
-This sets up the command-line environment
-for @code{GETARG} and @code{IARGC}.
-
-@item
-Calls @code{f_setsig} (with no arguments).
-
-This sets up the signaling and exception environment.
-
-@item
-Calls @code{f_init} (with no arguments).
-
-This initializes the I/O environment,
-though that should not be necessary,
-as all I/O functions in @code{libf2c}
-are believed to call @code{f_init} automatically,
-if necessary.
-
-(A future version of @command{g77} might skip this explicit step,
-to speed up normal exit of a program.)
-
-@item
-Arranges for @code{f_exit} to be called (with no arguments)
-when the program exits.
-
-This ensures that the I/O environment is properly shut down
-before the program exits normally.
-Otherwise, output buffers might not be fully flushed,
-scratch files might not be deleted, and so on.
-
-The simple way @code{main} does this is
-to call @code{f_exit} itself after calling
-@code{MAIN__} (in the next step).
-
-However, this does not catch the cases where the program
-might call @code{exit} directly,
-instead of using the @code{EXIT} intrinsic
-(implemented as @code{exit_} in @code{libf2c}).
-
-So, @code{main} attempts to use
-the operating environment's @code{onexit} or @code{atexit}
-facility, if available,
-to cause @code{f_exit} to be called automatically
-upon any invocation of @code{exit}.
-
-@item
-Calls @code{MAIN__} (with no arguments).
-
-This starts executing the Fortran main program unit for
-the application.
-(Both @command{g77} and @command{f2c} currently compile a main
-program unit so that its global name is @code{MAIN__}.)
-
-@item
-If no @code{onexit} or @code{atexit} is provided by the system,
-calls @code{f_exit}.
-
-@item
-Calls @code{exit} with a zero argument,
-to signal a successful program termination.
-
-@item
-Returns a zero value to the caller,
-to signal a successful program termination,
-in case @code{exit} doesn't exit on the system.
-@end enumerate
-
-All of the above names are C @code{extern} names,
-i.e.@: not mangled.
-
-When using the @code{main} procedure provided by @command{g77}
-without a Fortran main program unit,
-you need to provide @code{MAIN__}
-as the entry point for your C code.
-(Make sure you link the object file that defines that
-entry point with the rest of your program.)
-
-To provide your own @code{main} procedure
-in place of @command{g77}'s,
-make sure you specify the object file defining that procedure
-@emph{before} @option{-lg2c} on the @command{g77} command line.
-Since the @option{-lg2c} option is implicitly provided,
-this is usually straightforward.
-(Use the @option{--verbose} option to see how and where
-@command{g77} implicitly adds @option{-lg2c} in a command line
-that will link the program.
-Feel free to specify @option{-lg2c} explicitly,
-as appropriate.)
-
-However, when providing your own @code{main},
-make sure you perform the appropriate tasks in the
-appropriate order.
-For example, if your @code{main} does not call @code{f_setarg},
-make sure the rest of your application does not call
-@code{GETARG} or @code{IARGC}.
-
-And, if your @code{main} fails to ensure that @code{f_exit}
-is called upon program exit,
-some files might end up incompletely written,
-some scratch files might be left lying around,
-and some existing files being written might be left
-with old data not properly truncated at the end.
-
-Note that, generally, the @command{g77} operating environment
-does not depend on a procedure named @code{MAIN__} actually
-being called prior to any other @command{g77}-compiled code.
-That is, @code{MAIN__} does not, itself,
-set up any important operating-environment characteristics
-upon which other code might depend.
-This might change in future versions of @command{g77},
-with appropriate notification in the release notes.
-
-For more information, consult the source code for the above routines.
-These are in @file{@value{path-libf2c}/libF77/}, named @file{main.c},
-@file{setarg.c}, @file{setsig.c}, @file{getarg_.c}, and @file{iargc_.c}.
-
-Also, the file @file{@value{path-g77}/com.c} contains the code @command{g77}
-uses to open-code (inline) references to @code{IARGC}.
-
-@node Debugging and Interfacing
-@chapter Debugging and Interfacing
-@cindex debugging
-@cindex interfacing
-@cindex calling C routines
-@cindex C routines calling Fortran
-@cindex f2c compatibility
-
-GNU Fortran currently generates code that is object-compatible with
-the @command{f2c} converter.
-Also, it avoids limitations in the current GBE, such as the
-inability to generate a procedure with
-multiple entry points, by generating code that is structured
-differently (in terms of procedure names, scopes, arguments, and
-so on) than might be expected.
-
-As a result, writing code in other languages that calls on, is
-called by, or shares in-memory data with @command{g77}-compiled code generally
-requires some understanding of the way @command{g77} compiles code for
-various constructs.
-
-Similarly, using a debugger to debug @command{g77}-compiled
-code, even if that debugger supports native Fortran debugging, generally
-requires this sort of information.
-
-This section describes some of the basic information on how
-@command{g77} compiles code for constructs involving interfaces to other
-languages and to debuggers.
-
-@emph{Caution:} Much or all of this information pertains to only the current
-release of @command{g77}, sometimes even to using certain compiler options
-with @command{g77} (such as @option{-fno-f2c}).
-Do not write code that depends on this
-information without clearly marking said code as nonportable and
-subject to review for every new release of @command{g77}.
-This information
-is provided primarily to make debugging of code generated by this
-particular release of @command{g77} easier for the user, and partly to make
-writing (generally nonportable) interface code easier.
-Both of these
-activities require tracking changes in new version of @command{g77} as they
-are installed, because new versions can change the behaviors
-described in this section.
-
-@menu
-* Main Program Unit:: How @command{g77} compiles a main program unit.
-* Procedures:: How @command{g77} constructs parameter lists
- for procedures.
-* Functions:: Functions returning floating-point or character data.
-* Names:: Naming of user-defined variables, procedures, etc.
-* Common Blocks:: Accessing common variables while debugging.
-* Local Equivalence Areas:: Accessing @code{EQUIVALENCE} while debugging.
-* Complex Variables:: How @command{g77} performs complex arithmetic.
-* Arrays:: Dealing with (possibly multi-dimensional) arrays.
-* Adjustable Arrays:: Special consideration for adjustable arrays.
-* Alternate Entry Points:: How @command{g77} implements alternate @code{ENTRY}.
-* Alternate Returns:: How @command{g77} handles alternate returns.
-* Assigned Statement Labels:: How @command{g77} handles @code{ASSIGN}.
-* Run-time Library Errors:: Meanings of some @code{IOSTAT=} values.
-@end menu
-
-@node Main Program Unit
-@section Main Program Unit (PROGRAM)
-@cindex PROGRAM statement
-@cindex statements, PROGRAM
-
-When @command{g77} compiles a main program unit, it gives it the public
-procedure name @code{MAIN__}.
-The @code{libg2c} library has the actual @code{main()} procedure
-as is typical of C-based environments, and
-it is this procedure that performs some initial start-up
-activity and then calls @code{MAIN__}.
-
-Generally, @command{g77} and @code{libg2c} are designed so that you need not
-include a main program unit written in Fortran in your program---it
-can be written in C or some other language.
-Especially for I/O handling, this is the case, although @command{g77} version 0.5.16
-includes a bug fix for @code{libg2c} that solved a problem with using the
-@code{OPEN} statement as the first Fortran I/O activity in a program
-without a Fortran main program unit.
-
-However, if you don't intend to use @command{g77} (or @command{f2c}) to compile
-your main program unit---that is, if you intend to compile a @code{main()}
-procedure using some other language---you should carefully
-examine the code for @code{main()} in @code{libg2c}, found in the source
-file @file{@value{path-libf2c}/libF77/main.c}, to see what kinds of things
-might need to be done by your @code{main()} in order to provide the
-Fortran environment your Fortran code is expecting.
-
-@cindex @code{IArgC} intrinsic
-@cindex intrinsics, @code{IArgC}
-@cindex @code{GetArg} intrinsic
-@cindex intrinsics, @code{GetArg}
-For example, @code{libg2c}'s @code{main()} sets up the information used by
-the @code{IARGC} and @code{GETARG} intrinsics.
-Bypassing @code{libg2c}'s @code{main()}
-without providing a substitute for this activity would mean
-that invoking @code{IARGC} and @code{GETARG} would produce undefined
-results.
-
-@cindex debugging
-@cindex main program unit, debugging
-@cindex main()
-@cindex MAIN__()
-@cindex .gdbinit
-When debugging, one implication of the fact that @code{main()}, which
-is the place where the debugged program ``starts'' from the
-debugger's point of view, is in @code{libg2c} is that you won't be
-starting your Fortran program at a point you recognize as your
-Fortran code.
-
-The standard way to get around this problem is to set a break
-point (a one-time, or temporary, break point will do) at
-the entrance to @code{MAIN__}, and then run the program.
-A convenient way to do so is to add the @command{gdb} command
-
-@example
-tbreak MAIN__
-@end example
-
-@noindent
-to the file @file{.gdbinit} in the directory in which you're debugging
-(using @command{gdb}).
-
-After doing this, the debugger will see the current execution
-point of the program as at the beginning of the main program
-unit of your program.
-
-Of course, if you really want to set a break point at some
-other place in your program and just start the program
-running, without first breaking at @code{MAIN__},
-that should work fine.
-
-@node Procedures
-@section Procedures (SUBROUTINE and FUNCTION)
-@cindex procedures
-@cindex SUBROUTINE statement
-@cindex statements, SUBROUTINE
-@cindex FUNCTION statement
-@cindex statements, FUNCTION
-@cindex signature of procedures
-
-Currently, @command{g77} passes arguments via reference---specifically,
-by passing a pointer to the location in memory of a variable, array,
-array element, a temporary location that holds the result of evaluating an
-expression, or a temporary or permanent location that holds the value
-of a constant.
-
-Procedures that accept @code{CHARACTER} arguments are implemented by
-@command{g77} so that each @code{CHARACTER} argument has two actual arguments.
-
-The first argument occupies the expected position in the
-argument list and has the user-specified name.
-This argument
-is a pointer to an array of characters, passed by the caller.
-
-The second argument is appended to the end of the user-specified
-calling sequence and is named @samp{__g77_length_@var{x}}, where @var{x}
-is the user-specified name.
-This argument is of the C type @code{ftnlen}
-(see @file{@value{path-libf2c}/g2c.h.in} for information on that type) and
-is the number of characters the caller has allocated in the
-array pointed to by the first argument.
-
-A procedure will ignore the length argument if @samp{X} is not declared
-@code{CHARACTER*(*)}, because for other declarations, it knows the
-length.
-Not all callers necessarily ``know'' this, however, which
-is why they all pass the extra argument.
-
-The contents of the @code{CHARACTER} argument are specified by the
-address passed in the first argument (named after it).
-The procedure can read or write these contents as appropriate.
-
-When more than one @code{CHARACTER} argument is present in the argument
-list, the length arguments are appended in the order
-the original arguments appear.
-So @samp{CALL FOO('HI','THERE')} is implemented in
-C as @samp{foo("hi","there",2,5);}, ignoring the fact that @command{g77}
-does not provide the trailing null bytes on the constant
-strings (@command{f2c} does provide them, but they are unnecessary in
-a Fortran environment, and you should not expect them to be
-there).
-
-Note that the above information applies to @code{CHARACTER} variables and
-arrays @strong{only}.
-It does @strong{not} apply to external @code{CHARACTER}
-functions or to intrinsic @code{CHARACTER} functions.
-That is, no second length argument is passed to @samp{FOO} in this case:
-
-@example
-CHARACTER X
-EXTERNAL X
-CALL FOO(X)
-@end example
-
-@noindent
-Nor does @samp{FOO} expect such an argument in this case:
-
-@example
-SUBROUTINE FOO(X)
-CHARACTER X
-EXTERNAL X
-@end example
-
-Because of this implementation detail, if a program has a bug
-such that there is disagreement as to whether an argument is
-a procedure, and the type of the argument is @code{CHARACTER}, subtle
-symptoms might appear.
-
-@node Functions
-@section Functions (FUNCTION and RETURN)
-@cindex functions
-@cindex FUNCTION statement
-@cindex statements, FUNCTION
-@cindex RETURN statement
-@cindex statements, RETURN
-@cindex return type of functions
-
-@command{g77} handles in a special way functions that return the following
-types:
-
-@itemize @bullet
-@item
-@code{CHARACTER}
-@item
-@code{COMPLEX}
-@item
-@code{REAL(KIND=1)}
-@end itemize
-
-For @code{CHARACTER}, @command{g77} implements a subroutine (a C function
-returning @code{void})
-with two arguments prepended: @samp{__g77_result}, which the caller passes
-as a pointer to a @code{char} array expected to hold the return value,
-and @samp{__g77_length}, which the caller passes as an @code{ftnlen} value
-specifying the length of the return value as declared in the calling
-program.
-For @code{CHARACTER*(*)}, the called function uses @samp{__g77_length}
-to determine the size of the array that @samp{__g77_result} points to;
-otherwise, it ignores that argument.
-
-For @code{COMPLEX}, when @option{-ff2c} is in
-force, @command{g77} implements
-a subroutine with one argument prepended: @samp{__g77_result}, which the
-caller passes as a pointer to a variable of the type of the function.
-The called function writes the return value into this variable instead
-of returning it as a function value.
-When @option{-fno-f2c} is in force,
-@command{g77} implements a @code{COMPLEX} function as @command{gcc}'s
-@samp{__complex__ float} or @samp{__complex__ double} function
-(or an emulation thereof, when @option{-femulate-complex} is in effect),
-returning the result of the function in the same way as @command{gcc} would.
-
-For @code{REAL(KIND=1)}, when @option{-ff2c} is in force, @command{g77} implements
-a function that actually returns @code{REAL(KIND=2)} (typically
-C's @code{double} type).
-When @option{-fno-f2c} is in force, @code{REAL(KIND=1)}
-functions return @code{float}.
-
-@node Names
-@section Names
-@cindex symbol names
-@cindex transforming symbol names
-
-Fortran permits each implementation to decide how to represent
-names as far as how they're seen in other contexts, such as debuggers
-and when interfacing to other languages, and especially as far
-as how casing is handled.
-
-External names---names of entities that are public, or ``accessible'',
-to all modules in a program---normally have an underscore (@samp{_})
-appended by @command{g77},
-to generate code that is compatible with @command{f2c}.
-External names include names of Fortran things like common blocks,
-external procedures (subroutines and functions, but not including
-statement functions, which are internal procedures), and entry point
-names.
-
-However, use of the @option{-fno-underscoring} option
-disables this kind of transformation of external names (though inhibiting
-the transformation certainly improves the chances of colliding with
-incompatible externals written in other languages---but that
-might be intentional.
-
-@cindex -fno-underscoring option
-@cindex options, -fno-underscoring
-@cindex -fno-second-underscore option
-@cindex options, -fno-underscoring
-When @option{-funderscoring} is in force, any name (external or local)
-that already has at least one underscore in it is
-implemented by @command{g77} by appending two underscores.
-(This second underscore can be disabled via the
-@option{-fno-second-underscore} option.)
-External names are changed this way for @command{f2c} compatibility.
-Local names are changed this way to avoid collisions with external names
-that are different in the source code---@command{f2c} does the same thing, but
-there's no compatibility issue there except for user expectations while
-debugging.
-
-For example:
-
-@example
-Max_Cost = 0
-@end example
-
-@cindex debugging
-@noindent
-Here, a user would, in the debugger, refer to this variable using the
-name @samp{max_cost__} (or @samp{MAX_COST__} or @samp{Max_Cost__},
-as described below).
-(We hope to improve @command{g77} in this regard in the future---don't
-write scripts depending on this behavior!
-Also, consider experimenting with the @option{-fno-underscoring}
-option to try out debugging without having to massage names by
-hand like this.)
-
-@command{g77} provides a number of command-line options that allow the user
-to control how case mapping is handled for source files.
-The default is the traditional UNIX model for Fortran compilers---names
-are mapped to lower case.
-Other command-line options can be specified to map names to upper
-case, or to leave them exactly as written in the source file.
-
-For example:
-
-@example
-Foo = 9.436
-@end example
-
-@noindent
-Here, it is normally the case that the variable assigned will be named
-@samp{foo}.
-This would be the name to enter when using a debugger to
-access the variable.
-
-However, depending on the command-line options specified, the
-name implemented by @command{g77} might instead be @samp{FOO} or even
-@samp{Foo}, thus affecting how debugging is done.
-
-Also:
-
-@example
-Call Foo
-@end example
-
-@noindent
-This would normally call a procedure that, if it were in a separate C program,
-be defined starting with the line:
-
-@example
-void foo_()
-@end example
-
-@noindent
-However, @command{g77} command-line options could be used to change the casing
-of names, resulting in the name @samp{FOO_} or @samp{Foo_} being given to the
-procedure instead of @samp{foo_}, and the @option{-fno-underscoring} option
-could be used to inhibit the appending of the underscore to the name.
-
-@node Common Blocks
-@section Common Blocks (COMMON)
-@cindex common blocks
-@cindex @code{COMMON} statement
-@cindex statements, @code{COMMON}
-
-@command{g77} names and lays out @code{COMMON} areas
-the same way @command{f2c} does,
-for compatibility with @command{f2c}.
-
-@node Local Equivalence Areas
-@section Local Equivalence Areas (EQUIVALENCE)
-@cindex equivalence areas
-@cindex local equivalence areas
-@cindex EQUIVALENCE statement
-@cindex statements, EQUIVALENCE
-
-@command{g77} treats storage-associated areas involving a @code{COMMON}
-block as explained in the section on common blocks.
-
-A local @code{EQUIVALENCE} area is a collection of variables and arrays
-connected to each other in any way via @code{EQUIVALENCE}, none of which are
-listed in a @code{COMMON} statement.
-
-(@emph{Note:} @command{g77} version 0.5.18 and earlier chose the name
-for @var{x} using a different method when more than one name was
-in the list of names of entities placed at the beginning of the
-array.
-Though the documentation specified that the first name listed in
-the @code{EQUIVALENCE} statements was chosen for @var{x}, @command{g77}
-in fact chose the name using a method that was so complicated,
-it seemed easier to change it to an alphabetical sort than to describe the
-previous method in the documentation.)
-
-@node Complex Variables
-@section Complex Variables (COMPLEX)
-@cindex complex variables
-@cindex imaginary part
-@cindex COMPLEX statement
-@cindex statements, COMPLEX
-
-As of 0.5.20, @command{g77} defaults to handling @code{COMPLEX} types
-(and related intrinsics, constants, functions, and so on)
-in a manner that
-makes direct debugging involving these types in Fortran
-language mode difficult.
-
-Essentially, @command{g77} implements these types using an
-internal construct similar to C's @code{struct}, at least
-as seen by the @command{gcc} back end.
-
-Currently, the back end, when outputting debugging info with
-the compiled code for the assembler to digest, does not detect
-these @code{struct} types as being substitutes for Fortran
-complex.
-As a result, the Fortran language modes of debuggers such as
-@command{gdb} see these types as C @code{struct} types, which
-they might or might not support.
-
-Until this is fixed, switch to C language mode to work with
-entities of @code{COMPLEX} type and then switch back to Fortran language
-mode afterward.
-(In @command{gdb}, this is accomplished via @samp{set lang c} and
-either @samp{set lang fortran} or @samp{set lang auto}.)
-
-@node Arrays
-@section Arrays (DIMENSION)
-@cindex DIMENSION statement
-@cindex statements, DIMENSION
-@cindex array ordering
-@cindex ordering, array
-@cindex column-major ordering
-@cindex row-major ordering
-@cindex arrays
-
-Fortran uses ``column-major ordering'' in its arrays.
-This differs from other languages, such as C, which use ``row-major ordering''.
-The difference is that, with Fortran, array elements adjacent to
-each other in memory differ in the @emph{first} subscript instead of
-the last; @samp{A(5,10,20)} immediately follows @samp{A(4,10,20)},
-whereas with row-major ordering it would follow @samp{A(5,10,19)}.
-
-This consideration
-affects not only interfacing with and debugging Fortran code,
-it can greatly affect how code is designed and written, especially
-when code speed and size is a concern.
-
-Fortran also differs from C, a popular language for interfacing and
-to support directly in debuggers, in the way arrays are treated.
-In C, arrays are single-dimensional and have interesting relationships
-to pointers, neither of which is true for Fortran.
-As a result, dealing with Fortran arrays from within
-an environment limited to C concepts can be challenging.
-
-For example, accessing the array element @samp{A(5,10,20)} is easy enough
-in Fortran (use @samp{A(5,10,20)}), but in C some difficult machinations
-are needed.
-First, C would treat the A array as a single-dimension array.
-Second, C does not understand low bounds for arrays as does Fortran.
-Third, C assumes a low bound of zero (0), while Fortran defaults to a
-low bound of one (1) and can supports an arbitrary low bound.
-Therefore, calculations must be done
-to determine what the C equivalent of @samp{A(5,10,20)} would be, and these
-calculations require knowing the dimensions of @samp{A}.
-
-For @samp{DIMENSION A(2:11,21,0:29)}, the calculation of the offset of
-@samp{A(5,10,20)} would be:
-
-@example
- (5-2)
-+ (10-1)*(11-2+1)
-+ (20-0)*(11-2+1)*(21-1+1)
-= 4293
-@end example
-
-@noindent
-So the C equivalent in this case would be @samp{a[4293]}.
-
-When using a debugger directly on Fortran code, the C equivalent
-might not work, because some debuggers cannot understand the notion
-of low bounds other than zero. However, unlike @command{f2c}, @command{g77}
-does inform the GBE that a multi-dimensional array (like @samp{A}
-in the above example) is really multi-dimensional, rather than a
-single-dimensional array, so at least the dimensionality of the array
-is preserved.
-
-Debuggers that understand Fortran should have no trouble with
-nonzero low bounds, but for non-Fortran debuggers, especially
-C debuggers, the above example might have a C equivalent of
-@samp{a[4305]}.
-This calculation is arrived at by eliminating the subtraction
-of the lower bound in the first parenthesized expression on each
-line---that is, for @samp{(5-2)} substitute @samp{(5)}, for @samp{(10-1)}
-substitute @samp{(10)}, and for @samp{(20-0)} substitute @samp{(20)}.
-Actually, the implication of
-this can be that the expression @samp{*(&a[2][1][0] + 4293)} works fine,
-but that @samp{a[20][10][5]} produces the equivalent of
-@samp{*(&a[0][0][0] + 4305)} because of the missing lower bounds.
-
-Come to think of it, perhaps
-the behavior is due to the debugger internally compensating for
-the lower bounds by offsetting the base address of @samp{a}, leaving
-@samp{&a} set lower, in this case, than @samp{&a[2][1][0]} (the address of
-its first element as identified by subscripts equal to the
-corresponding lower bounds).
-
-You know, maybe nobody really needs to use arrays.
-
-@node Adjustable Arrays
-@section Adjustable Arrays (DIMENSION)
-@cindex arrays, adjustable
-@cindex adjustable arrays
-@cindex arrays, automatic
-@cindex automatic arrays
-@cindex DIMENSION statement
-@cindex statements, DIMENSION
-@cindex dimensioning arrays
-@cindex arrays, dimensioning
-
-Adjustable and automatic arrays in Fortran require the implementation
-(in this
-case, the @command{g77} compiler) to ``memorize'' the expressions that
-dimension the arrays each time the procedure is invoked.
-This is so that subsequent changes to variables used in those
-expressions, made during execution of the procedure, do not
-have any effect on the dimensions of those arrays.
-
-For example:
-
-@example
-REAL ARRAY(5)
-DATA ARRAY/5*2/
-CALL X(ARRAY, 5)
-END
-SUBROUTINE X(A, N)
-DIMENSION A(N)
-N = 20
-PRINT *, N, A
-END
-@end example
-
-@noindent
-Here, the implementation should, when running the program, print something
-like:
-
-@example
-20 2. 2. 2. 2. 2.
-@end example
-
-@noindent
-Note that this shows that while the value of @samp{N} was successfully
-changed, the size of the @samp{A} array remained at 5 elements.
-
-To support this, @command{g77} generates code that executes before any user
-code (and before the internally generated computed @code{GOTO} to handle
-alternate entry points, as described below) that evaluates each
-(nonconstant) expression in the list of subscripts for an
-array, and saves the result of each such evaluation to be used when
-determining the size of the array (instead of re-evaluating the
-expressions).
-
-So, in the above example, when @samp{X} is first invoked, code is
-executed that copies the value of @samp{N} to a temporary.
-And that same temporary serves as the actual high bound for the single
-dimension of the @samp{A} array (the low bound being the constant 1).
-Since the user program cannot (legitimately) change the value
-of the temporary during execution of the procedure, the size
-of the array remains constant during each invocation.
-
-For alternate entry points, the code @command{g77} generates takes into
-account the possibility that a dummy adjustable array is not actually
-passed to the actual entry point being invoked at that time.
-In that case, the public procedure implementing the entry point
-passes to the master private procedure implementing all the
-code for the entry points a @code{NULL} pointer where a pointer to that
-adjustable array would be expected.
-The @command{g77}-generated code
-doesn't attempt to evaluate any of the expressions in the subscripts
-for an array if the pointer to that array is @code{NULL} at run time in
-such cases.
-(Don't depend on this particular implementation
-by writing code that purposely passes @code{NULL} pointers where the
-callee expects adjustable arrays, even if you know the callee
-won't reference the arrays---nor should you pass @code{NULL} pointers
-for any dummy arguments used in calculating the bounds of such
-arrays or leave undefined any values used for that purpose in
-COMMON---because the way @command{g77} implements these things might
-change in the future!)
-
-@node Alternate Entry Points
-@section Alternate Entry Points (ENTRY)
-@cindex alternate entry points
-@cindex entry points
-@cindex ENTRY statement
-@cindex statements, ENTRY
-
-The GBE does not understand the general concept of
-alternate entry points as Fortran provides via the ENTRY statement.
-@command{g77} gets around this by using an approach to compiling procedures
-having at least one @code{ENTRY} statement that is almost identical to the
-approach used by @command{f2c}.
-(An alternate approach could be used that
-would probably generate faster, but larger, code that would also
-be a bit easier to debug.)
-
-Information on how @command{g77} implements @code{ENTRY} is provided for those
-trying to debug such code.
-The choice of implementation seems
-unlikely to affect code (compiled in other languages) that interfaces
-to such code.
-
-@command{g77} compiles exactly one public procedure for the primary entry
-point of a procedure plus each @code{ENTRY} point it specifies, as usual.
-That is, in terms of the public interface, there is no difference
-between
-
-@example
-SUBROUTINE X
-END
-SUBROUTINE Y
-END
-@end example
-
-@noindent
-and:
-
-@example
-SUBROUTINE X
-ENTRY Y
-END
-@end example
-
-The difference between the above two cases lies in the code compiled
-for the @samp{X} and @samp{Y} procedures themselves, plus the fact that,
-for the second case, an extra internal procedure is compiled.
-
-For every Fortran procedure with at least one @code{ENTRY}
-statement, @command{g77} compiles an extra procedure
-named @samp{__g77_masterfun_@var{x}}, where @var{x} is
-the name of the primary entry point (which, in the above case,
-using the standard compiler options, would be @samp{x_} in C).
-
-This extra procedure is compiled as a private procedure---that is,
-a procedure not accessible by name to separately compiled modules.
-It contains all the code in the program unit, including the code
-for the primary entry point plus for every entry point.
-(The code for each public procedure is quite short, and explained later.)
-
-The extra procedure has some other interesting characteristics.
-
-The argument list for this procedure is invented by @command{g77}.
-It contains
-a single integer argument named @samp{__g77_which_entrypoint},
-passed by value (as in Fortran's @samp{%VAL()} intrinsic), specifying the
-entry point index---0 for the primary entry point, 1 for the
-first entry point (the first @code{ENTRY} statement encountered), 2 for
-the second entry point, and so on.
-
-It also contains, for functions returning @code{CHARACTER} and
-(when @option{-ff2c} is in effect) @code{COMPLEX} functions,
-and for functions returning different types among the
-@code{ENTRY} statements (e.g. @samp{REAL FUNCTION R()}
-containing @samp{ENTRY I()}), an argument named @samp{__g77_result} that
-is expected at run time to contain a pointer to where to store
-the result of the entry point.
-For @code{CHARACTER} functions, this
-storage area is an array of the appropriate number of characters;
-for @code{COMPLEX} functions, it is the appropriate area for the return
-type; for multiple-return-type functions, it is a union of all the supported return
-types (which cannot include @code{CHARACTER}, since combining @code{CHARACTER}
-and non-@code{CHARACTER} return types via @code{ENTRY} in a single function
-is not supported by @command{g77}).
-
-For @code{CHARACTER} functions, the @samp{__g77_result} argument is followed
-by yet another argument named @samp{__g77_length} that, at run time,
-specifies the caller's expected length of the returned value.
-Note that only @code{CHARACTER*(*)} functions and entry points actually
-make use of this argument, even though it is always passed by
-all callers of public @code{CHARACTER} functions (since the caller does not
-generally know whether such a function is @code{CHARACTER*(*)} or whether
-there are any other callers that don't have that information).
-
-The rest of the argument list is the union of all the arguments
-specified for all the entry points (in their usual forms, e.g.
-@code{CHARACTER} arguments have extra length arguments, all appended at
-the end of this list).
-This is considered the ``master list'' of
-arguments.
-
-The code for this procedure has, before the code for the first
-executable statement, code much like that for the following Fortran
-statement:
-
-@smallexample
- GOTO (100000,100001,100002), __g77_which_entrypoint
-100000 @dots{}code for primary entry point@dots{}
-100001 @dots{}code immediately following first ENTRY statement@dots{}
-100002 @dots{}code immediately following second ENTRY statement@dots{}
-@end smallexample
-
-@noindent
-(Note that invalid Fortran statement labels and variable names
-are used in the above example to highlight the fact that it
-represents code generated by the @command{g77} internals, not code to be
-written by the user.)
-
-It is this code that, when the procedure is called, picks which
-entry point to start executing.
-
-Getting back to the public procedures (@samp{x} and @samp{Y} in the original
-example), those procedures are fairly simple.
-Their interfaces
-are just like they would be if they were self-contained procedures
-(without @code{ENTRY}), of course, since that is what the callers
-expect.
-Their code consists of simply calling the private
-procedure, described above, with the appropriate extra arguments
-(the entry point index, and perhaps a pointer to a multiple-type-
-return variable, local to the public procedure, that contains
-all the supported returnable non-character types).
-For arguments
-that are not listed for a given entry point that are listed for
-other entry points, and therefore that are in the ``master list''
-for the private procedure, null pointers (in C, the @code{NULL} macro)
-are passed.
-Also, for entry points that are part of a multiple-type-
-returning function, code is compiled after the call of the private
-procedure to extract from the multi-type union the appropriate result,
-depending on the type of the entry point in question, returning
-that result to the original caller.
-
-When debugging a procedure containing alternate entry points, you
-can either set a break point on the public procedure itself (e.g.
-a break point on @samp{X} or @samp{Y}) or on the private procedure that
-contains most of the pertinent code (e.g. @samp{__g77_masterfun_@var{x}}).
-If you do the former, you should use the debugger's command to
-``step into'' the called procedure to get to the actual code; with
-the latter approach, the break point leaves you right at the
-actual code, skipping over the public entry point and its call
-to the private procedure (unless you have set a break point there
-as well, of course).
-
-Further, the list of dummy arguments that is visible when the
-private procedure is active is going to be the expanded version
-of the list for whichever particular entry point is active,
-as explained above, and the way in which return values are
-handled might well be different from how they would be handled
-for an equivalent single-entry function.
-
-@node Alternate Returns
-@section Alternate Returns (SUBROUTINE and RETURN)
-@cindex subroutines
-@cindex alternate returns
-@cindex SUBROUTINE statement
-@cindex statements, SUBROUTINE
-@cindex RETURN statement
-@cindex statements, RETURN
-
-Subroutines with alternate returns (e.g. @samp{SUBROUTINE X(*)} and
-@samp{CALL X(*50)}) are implemented by @command{g77} as functions returning
-the C @code{int} type.
-The actual alternate-return arguments are omitted from the calling sequence.
-Instead, the caller uses
-the return value to do a rough equivalent of the Fortran
-computed-@code{GOTO} statement, as in @samp{GOTO (50), X()} in the
-example above (where @samp{X} is quietly declared as an @code{INTEGER(KIND=1)}
-function), and the callee just returns whatever integer
-is specified in the @code{RETURN} statement for the subroutine
-For example, @samp{RETURN 1} is implemented as @samp{X = 1} followed
-by @samp{RETURN}
-in C, and @samp{RETURN} by itself is @samp{X = 0} and @samp{RETURN}).
-
-@node Assigned Statement Labels
-@section Assigned Statement Labels (ASSIGN and GOTO)
-@cindex assigned statement labels
-@cindex statement labels, assigned
-@cindex ASSIGN statement
-@cindex statements, ASSIGN
-@cindex GOTO statement
-@cindex statements, GOTO
-
-For portability to machines where a pointer (such as to a label,
-which is how @command{g77} implements @code{ASSIGN} and its relatives,
-the assigned-@code{GOTO} and assigned-@code{FORMAT}-I/O statements)
-is wider (bitwise) than an @code{INTEGER(KIND=1)}, @command{g77}
-uses a different memory location to hold the @code{ASSIGN}ed value of a variable
-than it does the numerical value in that variable, unless the
-variable is wide enough (can hold enough bits).
-
-In particular, while @command{g77} implements
-
-@example
-I = 10
-@end example
-
-@noindent
-as, in C notation, @samp{i = 10;}, it implements
-
-@example
-ASSIGN 10 TO I
-@end example
-
-@noindent
-as, in GNU's extended C notation (for the label syntax),
-@samp{__g77_ASSIGN_I = &&L10;} (where @samp{L10} is just a massaging
-of the Fortran label @samp{10} to make the syntax C-like; @command{g77} doesn't
-actually generate the name @samp{L10} or any other name like that,
-since debuggers cannot access labels anyway).
-
-While this currently means that an @code{ASSIGN} statement does not
-overwrite the numeric contents of its target variable, @emph{do not}
-write any code depending on this feature.
-@command{g77} has already changed this implementation across
-versions and might do so in the future.
-This information is provided only to make debugging Fortran programs
-compiled with the current version of @command{g77} somewhat easier.
-If there's no debugger-visible variable named @samp{__g77_ASSIGN_I}
-in a program unit that does @samp{ASSIGN 10 TO I}, that probably
-means @command{g77} has decided it can store the pointer to the label directly
-into @samp{I} itself.
-
-@xref{Ugly Assigned Labels}, for information on a command-line option
-to force @command{g77} to use the same storage for both normal and
-assigned-label uses of a variable.
-
-@node Run-time Library Errors
-@section Run-time Library Errors
-@cindex IOSTAT=
-@cindex error values
-@cindex error messages
-@cindex messages, run-time
-@cindex I/O, errors
-
-The @code{libg2c} library currently has the following table to relate
-error code numbers, returned in @code{IOSTAT=} variables, to messages.
-This information should, in future versions of this document, be
-expanded upon to include detailed descriptions of each message.
-
-In line with good coding practices, any of the numbers in the
-list below should @emph{not} be directly written into Fortran
-code you write.
-Instead, make a separate @code{INCLUDE} file that defines
-@code{PARAMETER} names for them, and use those in your code,
-so you can more easily change the actual numbers in the future.
-
-The information below is culled from the definition
-of @code{F_err} in @file{f/runtime/libI77/err.c} in the
-@command{g77} source tree.
-
-@smallexample
-100: "error in format"
-101: "illegal unit number"
-102: "formatted io not allowed"
-103: "unformatted io not allowed"
-104: "direct io not allowed"
-105: "sequential io not allowed"
-106: "can't backspace file"
-107: "null file name"
-108: "can't stat file"
-109: "unit not connected"
-110: "off end of record"
-111: "truncation failed in endfile"
-112: "incomprehensible list input"
-113: "out of free space"
-114: "unit not connected"
-115: "read unexpected character"
-116: "bad logical input field"
-117: "bad variable type"
-118: "bad namelist name"
-119: "variable not in namelist"
-120: "no end record"
-121: "variable count incorrect"
-122: "subscript for scalar variable"
-123: "invalid array section"
-124: "substring out of bounds"
-125: "subscript out of bounds"
-126: "can't read file"
-127: "can't write file"
-128: "'new' file exists"
-129: "can't append to file"
-130: "non-positive record number"
-131: "I/O started while already doing I/O"
-@end smallexample
-
-@node Collected Fortran Wisdom
-@chapter Collected Fortran Wisdom
-@cindex wisdom
-@cindex legacy code
-@cindex code, legacy
-@cindex writing code
-@cindex code, writing
-
-Most users of @command{g77} can be divided into two camps:
-
-@itemize @bullet
-@item
-Those writing new Fortran code to be compiled by @command{g77}.
-
-@item
-Those using @command{g77} to compile existing, ``legacy'' code.
-@end itemize
-
-Users writing new code generally understand most of the necessary
-aspects of Fortran to write ``mainstream'' code, but often need
-help deciding how to handle problems, such as the construction
-of libraries containing @code{BLOCK DATA}.
-
-Users dealing with ``legacy'' code sometimes don't have much
-experience with Fortran, but believe that the code they're compiling
-already works when compiled by other compilers (and might
-not understand why, as is sometimes the case, it doesn't work
-when compiled by @command{g77}).
-
-The following information is designed to help users do a better job
-coping with existing, ``legacy'' Fortran code, and with writing
-new code as well.
-
-@menu
-* Advantages Over f2c:: If @command{f2c} is so great, why @command{g77}?
-* Block Data and Libraries:: How @command{g77} solves a common problem.
-* Loops:: Fortran @code{DO} loops surprise many people.
-* Working Programs:: Getting programs to work should be done first.
-* Overly Convenient Options:: Temptations to avoid, habits to not form.
-* Faster Programs:: Everybody wants these, but at what cost?
-@end menu
-
-@node Advantages Over f2c
-@section Advantages Over f2c
-
-Without @command{f2c}, @command{g77} would have taken much longer to
-do and probably not been as good for quite a while.
-Sometimes people who notice how much @command{g77} depends on, and
-documents encouragement to use, @command{f2c} ask why @command{g77}
-was created if @command{f2c} already existed.
-
-This section gives some basic answers to these questions, though it
-is not intended to be comprehensive.
-
-@menu
-* Language Extensions:: Features used by Fortran code.
-* Diagnostic Abilities:: Abilities to spot problems early.
-* Compiler Options:: Features helpful to accommodate legacy code, etc.
-* Compiler Speed:: Speed of the compilation process.
-* Program Speed:: Speed of the generated, optimized code.
-* Ease of Debugging:: Debugging ease-of-use at the source level.
-* Character and Hollerith Constants:: A byte saved is a byte earned.
-@end menu
-
-@node Language Extensions
-@subsection Language Extensions
-
-@command{g77} offers several extensions to FORTRAN 77 language that @command{f2c}
-doesn't:
-
-@itemize @bullet
-@item
-Automatic arrays
-
-@item
-@code{CYCLE} and @code{EXIT}
-
-@item
-Construct names
-
-@item
-@code{SELECT CASE}
-
-@item
-@code{KIND=} and @code{LEN=} notation
-
-@item
-Semicolon as statement separator
-
-@item
-Constant expressions in @code{FORMAT} statements
-(such as @samp{FORMAT(I<J>)},
-where @samp{J} is a @code{PARAMETER} named constant)
-
-@item
-@code{MvBits} intrinsic
-
-@item
-@code{libU77} (Unix-compatibility) library,
-with routines known to compiler as intrinsics
-(so they work even when compiler options are used
-to change the interfaces used by Fortran routines)
-@end itemize
-
-@command{g77} also implements iterative @code{DO} loops
-so that they work even in the presence of certain ``extreme'' inputs,
-unlike @command{f2c}.
-@xref{Loops}.
-
-However, @command{f2c} offers a few that @command{g77} doesn't, such as:
-
-@itemize @bullet
-@item
-Intrinsics in @code{PARAMETER} statements
-
-@item
-Array bounds expressions (such as @samp{REAL M(N(2))})
-
-@item
-@code{AUTOMATIC} statement
-@end itemize
-
-It is expected that @command{g77} will offer some or all of these missing
-features at some time in the future.
-
-@node Diagnostic Abilities
-@subsection Diagnostic Abilities
-
-@command{g77} offers better diagnosis of problems in @code{FORMAT} statements.
-@command{f2c} doesn't, for example, emit any diagnostic for
-@samp{FORMAT(XZFAJG10324)},
-leaving that to be diagnosed, at run time, by
-the @code{libf2c} run-time library.
-
-@node Compiler Options
-@subsection Compiler Options
-
-@command{g77} offers compiler options that @command{f2c} doesn't,
-most of which are designed to more easily accommodate
-legacy code:
-
-@itemize @bullet
-@item
-Two that control the automatic appending of extra
-underscores to external names
-
-@item
-One that allows dollar signs (@samp{$}) in symbol names
-
-@item
-A variety that control acceptance of various
-``ugly'' constructs
-
-@item
-Several that specify acceptable use of upper and lower case
-in the source code
-
-@item
-Many that enable, disable, delete, or hide
-groups of intrinsics
-
-@item
-One to specify the length of fixed-form source lines
-(normally 72)
-
-@item
-One to specify the the source code is written in
-Fortran-90-style free-form
-@end itemize
-
-However, @command{f2c} offers a few that @command{g77} doesn't,
-like an option to have @code{REAL} default to @code{REAL*8}.
-It is expected that @command{g77} will offer all of the
-missing options pertinent to being a Fortran compiler
-at some time in the future.
-
-@node Compiler Speed
-@subsection Compiler Speed
-
-Saving the steps of writing and then rereading C code is a big reason
-why @command{g77} should be able to compile code much faster than using
-@command{f2c} in conjunction with the equivalent invocation of @command{gcc}.
-
-However, due to @command{g77}'s youth, lots of self-checking is still being
-performed.
-As a result, this improvement is as yet unrealized
-(though the potential seems to be there for quite a big speedup
-in the future).
-It is possible that, as of version 0.5.18, @command{g77}
-is noticeably faster compiling many Fortran source files than using
-@command{f2c} in conjunction with @command{gcc}.
-
-@node Program Speed
-@subsection Program Speed
-
-@command{g77} has the potential to better optimize code than @command{f2c},
-even when @command{gcc} is used to compile the output of @command{f2c},
-because @command{f2c} must necessarily
-translate Fortran into a somewhat lower-level language (C) that cannot
-preserve all the information that is potentially useful for optimization,
-while @command{g77} can gather, preserve, and transmit that information directly
-to the GBE.
-
-For example, @command{g77} implements @code{ASSIGN} and assigned
-@code{GOTO} using direct assignment of pointers to labels and direct
-jumps to labels, whereas @command{f2c} maps the assigned labels to
-integer values and then uses a C @code{switch} statement to encode
-the assigned @code{GOTO} statements.
-
-However, as is typical, theory and reality don't quite match, at least
-not in all cases, so it is still the case that @command{f2c} plus @command{gcc}
-can generate code that is faster than @command{g77}.
-
-Version 0.5.18 of @command{g77} offered default
-settings and options, via patches to the @command{gcc}
-back end, that allow for better program speed, though
-some of these improvements also affected the performance
-of programs translated by @command{f2c} and then compiled
-by @command{g77}'s version of @command{gcc}.
-
-Version 0.5.20 of @command{g77} offers further performance
-improvements, at least one of which (alias analysis) is
-not generally applicable to @command{f2c} (though @command{f2c}
-could presumably be changed to also take advantage of
-this new capability of the @command{gcc} back end, assuming
-this is made available in an upcoming release of @command{gcc}).
-
-@node Ease of Debugging
-@subsection Ease of Debugging
-
-Because @command{g77} compiles directly to assembler code like @command{gcc},
-instead of translating to an intermediate language (C) as does @command{f2c},
-support for debugging can be better for @command{g77} than @command{f2c}.
-
-However, although @command{g77} might be somewhat more ``native'' in terms of
-debugging support than @command{f2c} plus @command{gcc}, there still are a lot
-of things ``not quite right''.
-Many of the important ones should be resolved in the near future.
-
-For example, @command{g77} doesn't have to worry about reserved names
-like @command{f2c} does.
-Given @samp{FOR = WHILE}, @command{f2c} must necessarily
-translate this to something @emph{other} than
-@samp{for = while;}, because C reserves those words.
-
-However, @command{g77} does still uses things like an extra level of indirection
-for @code{ENTRY}-laden procedures---in this case, because the back end doesn't
-yet support multiple entry points.
-
-Another example is that, given
-
-@smallexample
-COMMON A, B
-EQUIVALENCE (B, C)
-@end smallexample
-
-@noindent
-the @command{g77} user should be able to access the variables directly, by name,
-without having to traverse C-like structures and unions, while @command{f2c}
-is unlikely to ever offer this ability (due to limitations in the
-C language).
-
-Yet another example is arrays.
-@command{g77} represents them to the debugger
-using the same ``dimensionality'' as in the source code, while @command{f2c}
-must necessarily convert them all to one-dimensional arrays to fit
-into the confines of the C language.
-However, the level of support
-offered by debuggers for interactive Fortran-style access to arrays
-as compiled by @command{g77} can vary widely.
-In some cases, it can actually
-be an advantage that @command{f2c} converts everything to widely supported
-C semantics.
-
-In fairness, @command{g77} could do many of the things @command{f2c} does
-to get things working at least as well as @command{f2c}---for now,
-the developers prefer making @command{g77} work the
-way they think it is supposed to, and finding help improving the
-other products (the back end of @command{gcc}; @command{gdb}; and so on)
-to get things working properly.
-
-@node Character and Hollerith Constants
-@subsection Character and Hollerith Constants
-@cindex character constants
-@cindex constants, character
-@cindex Hollerith constants
-@cindex constants, Hollerith
-@cindex trailing null byte
-@cindex null byte, trailing
-@cindex zero byte, trailing
-
-To avoid the extensive hassle that would be needed to avoid this,
-@command{f2c} uses C character constants to encode character and Hollerith
-constants.
-That means a constant like @samp{'HELLO'} is translated to
-@samp{"hello"} in C, which further means that an extra null byte is
-present at the end of the constant.
-This null byte is superfluous.
-
-@command{g77} does not generate such null bytes.
-This represents significant
-savings of resources, such as on systems where @file{/dev/null} or
-@file{/dev/zero} represent bottlenecks in the systems' performance,
-because @command{g77} simply asks for fewer zeros from the operating
-system than @command{f2c}.
-(Avoiding spurious use of zero bytes, each byte typically have
-eight zero bits, also reduces the liabilities in case
-Microsoft's rumored patent on the digits 0 and 1 is upheld.)
-
-@node Block Data and Libraries
-@section Block Data and Libraries
-@cindex block data and libraries
-@cindex BLOCK DATA statement
-@cindex statements, BLOCK DATA
-@cindex libraries, containing BLOCK DATA
-@cindex f2c compatibility
-@cindex compatibility, f2c
-
-To ensure that block data program units are linked, especially a concern
-when they are put into libraries, give each one a name (as in
-@samp{BLOCK DATA FOO}) and make sure there is an @samp{EXTERNAL FOO}
-statement in every program unit that uses any common block
-initialized by the corresponding @code{BLOCK DATA}.
-@command{g77} currently compiles a @code{BLOCK DATA} as if it were a
-@code{SUBROUTINE},
-that is, it generates an actual procedure having the appropriate name.
-The procedure does nothing but return immediately if it happens to be
-called.
-For @samp{EXTERNAL FOO}, where @samp{FOO} is not otherwise referenced in the
-same program unit, @command{g77} assumes there exists a @samp{BLOCK DATA FOO}
-in the program and ensures that by generating a
-reference to it so the linker will make sure it is present.
-(Specifically, @command{g77} outputs in the data section a static pointer to the
-external name @samp{FOO}.)
-
-The implementation @command{g77} currently uses to make this work is
-one of the few things not compatible with @command{f2c} as currently
-shipped.
-@command{f2c} currently does nothing with @samp{EXTERNAL FOO} except
-issue a warning that @samp{FOO} is not otherwise referenced,
-and, for @samp{BLOCK DATA FOO},
-@command{f2c} doesn't generate a dummy procedure with the name @samp{FOO}.
-The upshot is that you shouldn't mix @command{f2c} and @command{g77} in
-this particular case.
-If you use @command{f2c} to compile @samp{BLOCK DATA FOO},
-then any @command{g77}-compiled program unit that says @samp{EXTERNAL FOO}
-will result in an unresolved reference when linked.
-If you do the
-opposite, then @samp{FOO} might not be linked in under various
-circumstances (such as when @samp{FOO} is in a library, or you're
-using a ``clever'' linker---so clever, it produces a broken program
-with little or no warning by omitting initializations of global data
-because they are contained in unreferenced procedures).
-
-The changes you make to your code to make @command{g77} handle this situation,
-however, appear to be a widely portable way to handle it.
-That is, many systems permit it (as they should, since the
-FORTRAN 77 standard permits @samp{EXTERNAL FOO} when @samp{FOO}
-is a block data program unit), and of the ones
-that might not link @samp{BLOCK DATA FOO} under some circumstances, most of
-them appear to do so once @samp{EXTERNAL FOO} is present in the appropriate
-program units.
-
-Here is the recommended approach to modifying a program containing
-a program unit such as the following:
-
-@smallexample
-BLOCK DATA FOO
-COMMON /VARS/ X, Y, Z
-DATA X, Y, Z / 3., 4., 5. /
-END
-@end smallexample
-
-@noindent
-If the above program unit might be placed in a library module, then
-ensure that every program unit in every program that references that
-particular @code{COMMON} area uses the @code{EXTERNAL} statement
-to force the area to be initialized.
-
-For example, change a program unit that starts with
-
-@smallexample
-INTEGER FUNCTION CURX()
-COMMON /VARS/ X, Y, Z
-CURX = X
-END
-@end smallexample
-
-@noindent
-so that it uses the @code{EXTERNAL} statement, as in:
-
-@smallexample
-INTEGER FUNCTION CURX()
-COMMON /VARS/ X, Y, Z
-EXTERNAL FOO
-CURX = X
-END
-@end smallexample
-
-@noindent
-That way, @samp{CURX} is compiled by @command{g77} (and many other
-compilers) so that the linker knows it must include @samp{FOO},
-the @code{BLOCK DATA} program unit that sets the initial values
-for the variables in @samp{VAR}, in the executable program.
-
-@node Loops
-@section Loops
-@cindex DO statement
-@cindex statements, DO
-@cindex trips, number of
-@cindex number of trips
-
-The meaning of a @code{DO} loop in Fortran is precisely specified
-in the Fortran standard@dots{}and is quite different from what
-many programmers might expect.
-
-In particular, Fortran iterative @code{DO} loops are implemented as if
-the number of trips through the loop is calculated @emph{before}
-the loop is entered.
-
-The number of trips for a loop is calculated from the @var{start},
-@var{end}, and @var{increment} values specified in a statement such as:
-
-@smallexample
-DO @var{iter} = @var{start}, @var{end}, @var{increment}
-@end smallexample
-
-@noindent
-The trip count is evaluated using a fairly simple formula
-based on the three values following the @samp{=} in the
-statement, and it is that trip count that is effectively
-decremented during each iteration of the loop.
-If, at the beginning of an iteration of the loop, the
-trip count is zero or negative, the loop terminates.
-The per-loop-iteration modifications to @var{iter} are not
-related to determining whether to terminate the loop.
-
-There are two important things to remember about the trip
-count:
-
-@itemize @bullet
-@item
-It can be @emph{negative}, in which case it is
-treated as if it was zero---meaning the loop is
-not executed at all.
-
-@item
-The type used to @emph{calculate} the trip count
-is the same type as @var{iter}, but the final
-calculation, and thus the type of the trip
-count itself, always is @code{INTEGER(KIND=1)}.
-@end itemize
-
-These two items mean that there are loops that cannot
-be written in straightforward fashion using the Fortran @code{DO}.
-
-For example, on a system with the canonical 32-bit two's-complement
-implementation of @code{INTEGER(KIND=1)}, the following loop will not work:
-
-@smallexample
-DO I = -2000000000, 2000000000
-@end smallexample
-
-@noindent
-Although the @var{start} and @var{end} values are well within
-the range of @code{INTEGER(KIND=1)}, the @emph{trip count} is not.
-The expected trip count is 40000000001, which is outside
-the range of @code{INTEGER(KIND=1)} on many systems.
-
-Instead, the above loop should be constructed this way:
-
-@smallexample
-I = -2000000000
-DO
- IF (I .GT. 2000000000) EXIT
- @dots{}
- I = I + 1
-END DO
-@end smallexample
-
-@noindent
-The simple @code{DO} construct and the @code{EXIT} statement
-(used to leave the innermost loop)
-are F90 features that @command{g77} supports.
-
-Some Fortran compilers have buggy implementations of @code{DO},
-in that they don't follow the standard.
-They implement @code{DO} as a straightforward translation
-to what, in C, would be a @code{for} statement.
-Instead of creating a temporary variable to hold the trip count
-as calculated at run time, these compilers
-use the iteration variable @var{iter} to control
-whether the loop continues at each iteration.
-
-The bug in such an implementation shows up when the
-trip count is within the range of the type of @var{iter},
-but the magnitude of @samp{ABS(@var{end}) + ABS(@var{incr})}
-exceeds that range. For example:
-
-@smallexample
-DO I = 2147483600, 2147483647
-@end smallexample
-
-@noindent
-A loop started by the above statement will work as implemented
-by @command{g77}, but the use, by some compilers, of a
-more C-like implementation akin to
-
-@smallexample
-for (i = 2147483600; i <= 2147483647; ++i)
-@end smallexample
-
-@noindent
-produces a loop that does not terminate, because @samp{i}
-can never be greater than 2147483647, since incrementing it
-beyond that value overflows @samp{i}, setting it to -2147483648.
-This is a large, negative number that still is less than 2147483647.
-
-Another example of unexpected behavior of @code{DO} involves
-using a nonintegral iteration variable @var{iter}, that is,
-a @code{REAL} variable.
-Consider the following program:
-
-@smallexample
- DATA BEGIN, END, STEP /.1, .31, .007/
- DO 10 R = BEGIN, END, STEP
- IF (R .GT. END) PRINT *, R, ' .GT. ', END, '!!'
- PRINT *,R
-10 CONTINUE
- PRINT *,'LAST = ',R
- IF (R .LE. END) PRINT *, R, ' .LE. ', END, '!!'
- END
-@end smallexample
-
-@noindent
-A C-like view of @code{DO} would hold that the two ``exclamatory''
-@code{PRINT} statements are never executed.
-However, this is the output of running the above program
-as compiled by @command{g77} on a GNU/Linux ix86 system:
-
-@smallexample
- .100000001
- .107000001
- .114
- .120999999
- @dots{}
- .289000005
- .296000004
- .303000003
-LAST = .310000002
- .310000002 .LE. .310000002!!
-@end smallexample
-
-Note that one of the two checks in the program turned up
-an apparent violation of the programmer's expectation---yet,
-the loop is correctly implemented by @command{g77}, in that
-it has 30 iterations.
-This trip count of 30 is correct when evaluated using
-the floating-point representations for the @var{begin},
-@var{end}, and @var{incr} values (.1, .31, .007) on GNU/Linux
-ix86 are used.
-On other systems, an apparently more accurate trip count
-of 31 might result, but, nevertheless, @command{g77} is
-faithfully following the Fortran standard, and the result
-is not what the author of the sample program above
-apparently expected.
-(Such other systems might, for different values in the @code{DATA}
-statement, violate the other programmer's expectation,
-for example.)
-
-Due to this combination of imprecise representation
-of floating-point values and the often-misunderstood
-interpretation of @code{DO} by standard-conforming
-compilers such as @command{g77}, use of @code{DO} loops
-with @code{REAL} iteration
-variables is not recommended.
-Such use can be caught by specifying @option{-Wsurprising}.
-@xref{Warning Options}, for more information on this
-option.
-
-@node Working Programs
-@section Working Programs
-
-Getting Fortran programs to work in the first place can be
-quite a challenge---even when the programs already work on
-other systems, or when using other compilers.
-
-@command{g77} offers some facilities that might be useful for
-tracking down bugs in such programs.
-
-@menu
-* Not My Type::
-* Variables Assumed To Be Zero::
-* Variables Assumed To Be Saved::
-* Unwanted Variables::
-* Unused Arguments::
-* Surprising Interpretations of Code::
-* Aliasing Assumed To Work::
-* Output Assumed To Flush::
-* Large File Unit Numbers::
-* Floating-point precision::
-* Inconsistent Calling Sequences::
-@end menu
-
-@node Not My Type
-@subsection Not My Type
-@cindex mistyped variables
-@cindex variables, mistyped
-@cindex mistyped functions
-@cindex functions, mistyped
-@cindex implicit typing
-
-A fruitful source of bugs in Fortran source code is use, or
-mis-use, of Fortran's implicit-typing feature, whereby the
-type of a variable, array, or function is determined by the
-first character of its name.
-
-Simple cases of this include statements like @samp{LOGX=9.227},
-without a statement such as @samp{REAL LOGX}.
-In this case, @samp{LOGX} is implicitly given @code{INTEGER(KIND=1)}
-type, with the result of the assignment being that it is given
-the value @samp{9}.
-
-More involved cases include a function that is defined starting
-with a statement like @samp{DOUBLE PRECISION FUNCTION IPS(@dots{})}.
-Any caller of this function that does not also declare @samp{IPS}
-as type @code{DOUBLE PRECISION} (or, in GNU Fortran, @code{REAL(KIND=2)})
-is likely to assume it returns
-@code{INTEGER}, or some other type, leading to invalid results
-or even program crashes.
-
-The @option{-Wimplicit} option might catch failures to
-properly specify the types of
-variables, arrays, and functions in the code.
-
-However, in code that makes heavy use of Fortran's
-implicit-typing facility, this option might produce so
-many warnings about cases that are working, it would be
-hard to find the one or two that represent bugs.
-This is why so many experienced Fortran programmers strongly
-recommend widespread use of the @code{IMPLICIT NONE} statement,
-despite it not being standard FORTRAN 77, to completely turn
-off implicit typing.
-(@command{g77} supports @code{IMPLICIT NONE}, as do almost all
-FORTRAN 77 compilers.)
-
-Note that @option{-Wimplicit} catches only implicit typing of
-@emph{names}.
-It does not catch implicit typing of expressions such
-as @samp{X**(2/3)}.
-Such expressions can be buggy as well---in fact, @samp{X**(2/3)}
-is equivalent to @samp{X**0}, due to the way Fortran expressions
-are given types and then evaluated.
-(In this particular case, the programmer probably wanted
-@samp{X**(2./3.)}.)
-
-@node Variables Assumed To Be Zero
-@subsection Variables Assumed To Be Zero
-@cindex zero-initialized variables
-@cindex variables, assumed to be zero
-@cindex uninitialized variables
-
-Many Fortran programs were developed on systems that provided
-automatic initialization of all, or some, variables and arrays
-to zero.
-As a result, many of these programs depend, sometimes
-inadvertently, on this behavior, though to do so violates
-the Fortran standards.
-
-You can ask @command{g77} for this behavior by specifying the
-@option{-finit-local-zero} option when compiling Fortran code.
-(You might want to specify @option{-fno-automatic} as well,
-to avoid code-size inflation for non-optimized compilations.)
-
-Note that a program that works better when compiled with the
-@option{-finit-local-zero} option
-is almost certainly depending on a particular system's,
-or compiler's, tendency to initialize some variables to zero.
-It might be worthwhile finding such cases and fixing them,
-using techniques such as compiling with the @option{-O -Wuninitialized}
-options using @command{g77}.
-
-@node Variables Assumed To Be Saved
-@subsection Variables Assumed To Be Saved
-@cindex variables, retaining values across calls
-@cindex saved variables
-@cindex static variables
-
-Many Fortran programs were developed on systems that
-saved the values of all, or some, variables and arrays
-across procedure calls.
-As a result, many of these programs depend, sometimes
-inadvertently, on being able to assign a value to a
-variable, perform a @code{RETURN} to a calling procedure,
-and, upon subsequent invocation, reference the previously
-assigned variable to obtain the value.
-
-They expect this despite not using the @code{SAVE} statement
-to specify that the value in a variable is expected to survive
-procedure returns and calls.
-Depending on variables and arrays to retain values across
-procedure calls without using @code{SAVE} to require it violates
-the Fortran standards.
-
-You can ask @command{g77} to assume @code{SAVE} is specified for all
-relevant (local) variables and arrays by using the
-@option{-fno-automatic} option.
-
-Note that a program that works better when compiled with the
-@option{-fno-automatic} option
-is almost certainly depending on not having to use
-the @code{SAVE} statement as required by the Fortran standard.
-It might be worthwhile finding such cases and fixing them,
-using techniques such as compiling with the @samp{-O -Wuninitialized}
-options using @command{g77}.
-
-@node Unwanted Variables
-@subsection Unwanted Variables
-
-The @option{-Wunused} option can find bugs involving
-implicit typing, sometimes
-more easily than using @option{-Wimplicit} in code that makes
-heavy use of implicit typing.
-An unused variable or array might indicate that the
-spelling for its declaration is different from that of
-its intended uses.
-
-Other than cases involving typos, unused variables rarely
-indicate actual bugs in a program.
-However, investigating such cases thoroughly has, on occasion,
-led to the discovery of code that had not been completely
-written---where the programmer wrote declarations as needed
-for the whole algorithm, wrote some or even most of the code
-for that algorithm, then got distracted and forgot that the
-job was not complete.
-
-@node Unused Arguments
-@subsection Unused Arguments
-@cindex unused arguments
-@cindex arguments, unused
-
-As with unused variables, It is possible that unused arguments
-to a procedure might indicate a bug.
-Compile with @samp{-W -Wunused} option to catch cases of
-unused arguments.
-
-Note that @option{-W} also enables warnings regarding overflow
-of floating-point constants under certain circumstances.
-
-@node Surprising Interpretations of Code
-@subsection Surprising Interpretations of Code
-
-The @option{-Wsurprising} option can help find bugs involving
-expression evaluation or in
-the way @code{DO} loops with non-integral iteration variables
-are handled.
-Cases found by this option might indicate a difference of
-interpretation between the author of the code involved, and
-a standard-conforming compiler such as @command{g77}.
-Such a difference might produce actual bugs.
-
-In any case, changing the code to explicitly do what the
-programmer might have expected it to do, so @command{g77} and
-other compilers are more likely to follow the programmer's
-expectations, might be worthwhile, especially if such changes
-make the program work better.
-
-@node Aliasing Assumed To Work
-@subsection Aliasing Assumed To Work
-@cindex -falias-check option
-@cindex options, -falias-check
-@cindex -fargument-alias option
-@cindex options, -fargument-alias
-@cindex -fargument-noalias option
-@cindex options, -fargument-noalias
-@cindex -fno-argument-noalias-global option
-@cindex options, -fno-argument-noalias-global
-@cindex aliasing
-@cindex anti-aliasing
-@cindex overlapping arguments
-@cindex overlays
-@cindex association, storage
-@cindex storage association
-@cindex scheduling of reads and writes
-@cindex reads and writes, scheduling
-
-The @option{-falias-check}, @option{-fargument-alias},
-@option{-fargument-noalias},
-and @option{-fno-argument-noalias-global} options,
-introduced in version 0.5.20 and
-@command{g77}'s version 2.7.2.2.f.2 of @command{gcc},
-were withdrawn as of @command{g77} version 0.5.23
-due to their not being supported by @command{gcc} version 2.8.
-
-These options control the assumptions regarding aliasing
-(overlapping) of writes and reads to main memory (core) made
-by the @command{gcc} back end.
-
-The information below still is useful, but applies to
-only those versions of @command{g77} that support the
-alias analysis implied by support for these options.
-
-These options are effective only when compiling with @option{-O}
-(specifying any level other than @option{-O0})
-or with @option{-falias-check}.
-
-The default for Fortran code is @option{-fargument-noalias-global}.
-(The default for C code and code written in other C-based languages
-is @option{-fargument-alias}.
-These defaults apply regardless of whether you use @command{g77} or
-@command{gcc} to compile your code.)
-
-Note that, on some systems, compiling with @option{-fforce-addr} in
-effect can produce more optimal code when the default aliasing
-options are in effect (and when optimization is enabled).
-
-If your program is not working when compiled with optimization,
-it is possible it is violating the Fortran standards (77 and 90)
-by relying on the ability to ``safely'' modify variables and
-arrays that are aliased, via procedure calls, to other variables
-and arrays, without using @code{EQUIVALENCE} to explicitly
-set up this kind of aliasing.
-
-(The FORTRAN 77 standard's prohibition of this sort of
-overlap, generally referred to therein as ``storage
-association'', appears in Sections 15.9.3.6.
-This prohibition allows implementations, such as @command{g77},
-to, for example, implement the passing of procedures and
-even values in @code{COMMON} via copy operations into local,
-perhaps more efficiently accessed temporaries at entry to a
-procedure, and, where appropriate, via copy operations back
-out to their original locations in memory at exit from that
-procedure, without having to take into consideration the
-order in which the local copies are updated by the code,
-among other things.)
-
-To test this hypothesis, try compiling your program with
-the @option{-fargument-alias} option, which causes the
-compiler to revert to assumptions essentially the same as
-made by versions of @command{g77} prior to 0.5.20.
-
-If the program works using this option, that strongly suggests
-that the bug is in your program.
-Finding and fixing the bug(s) should result in a program that
-is more standard-conforming and that can be compiled by @command{g77}
-in a way that results in a faster executable.
-
-(You might want to try compiling with @option{-fargument-noalias},
-a kind of half-way point, to see if the problem is limited to
-aliasing between dummy arguments and @code{COMMON} variables---this
-option assumes that such aliasing is not done, while still allowing
-aliasing among dummy arguments.)
-
-An example of aliasing that is invalid according to the standards
-is shown in the following program, which might @emph{not} produce
-the expected results when executed:
-
-@smallexample
-I = 1
-CALL FOO(I, I)
-PRINT *, I
-END
-
-SUBROUTINE FOO(J, K)
-J = J + K
-K = J * K
-PRINT *, J, K
-END
-@end smallexample
-
-The above program attempts to use the temporary aliasing of the
-@samp{J} and @samp{K} arguments in @samp{FOO} to effect a
-pathological behavior---the simultaneous changing of the values
-of @emph{both} @samp{J} and @samp{K} when either one of them
-is written.
-
-The programmer likely expects the program to print these values:
-
-@example
-2 4
-4
-@end example
-
-However, since the program is not standard-conforming, an
-implementation's behavior when running it is undefined, because
-subroutine @samp{FOO} modifies at least one of the arguments,
-and they are aliased with each other.
-(Even if one of the assignment statements was deleted, the
-program would still violate these rules.
-This kind of on-the-fly aliasing is permitted by the standard
-only when none of the aliased items are defined, or written,
-while the aliasing is in effect.)
-
-As a practical example, an optimizing compiler might schedule
-the @samp{J =} part of the second line of @samp{FOO} @emph{after}
-the reading of @samp{J} and @samp{K} for the @samp{J * K} expression,
-resulting in the following output:
-
-@example
-2 2
-2
-@end example
-
-Essentially, compilers are promised (by the standard and, therefore,
-by programmers who write code they claim to be standard-conforming)
-that if they cannot detect aliasing via static analysis of a single
-program unit's @code{EQUIVALENCE} and @code{COMMON} statements, no
-such aliasing exists.
-In such cases, compilers are free to assume that an assignment to
-one variable will not change the value of another variable, allowing
-it to avoid generating code to re-read the value of the other
-variable, to re-schedule reads and writes, and so on, to produce
-a faster executable.
-
-The same promise holds true for arrays (as seen by the called
-procedure)---an element of one dummy array cannot be aliased
-with, or overlap, any element of another dummy array or be
-in a @code{COMMON} area known to the procedure.
-
-(These restrictions apply only when the procedure defines, or
-writes to, one of the aliased variables or arrays.)
-
-Unfortunately, there is no way to find @emph{all} possible cases of
-violations of the prohibitions against aliasing in Fortran code.
-Static analysis is certainly imperfect, as is run-time analysis,
-since neither can catch all violations.
-(Static analysis can catch all likely violations, and some that
-might never actually happen, while run-time analysis can catch
-only those violations that actually happen during a particular run.
-Neither approach can cope with programs mixing Fortran code with
-routines written in other languages, however.)
-
-Currently, @command{g77} provides neither static nor run-time facilities
-to detect any cases of this problem, although other products might.
-Run-time facilities are more likely to be offered by future
-versions of @command{g77}, though patches improving @command{g77} so that
-it provides either form of detection are welcome.
-
-@node Output Assumed To Flush
-@subsection Output Assumed To Flush
-@cindex ALWAYS_FLUSH
-@cindex synchronous write errors
-@cindex disk full
-@cindex flushing output
-@cindex fflush()
-@cindex I/O, flushing
-@cindex output, flushing
-@cindex writes, flushing
-@cindex NFS
-@cindex network file system
-
-For several versions prior to 0.5.20, @command{g77} configured its
-version of the @code{libf2c} run-time library so that one of
-its configuration macros, @code{ALWAYS_FLUSH}, was defined.
-
-This was done as a result of a belief that many programs expected
-output to be flushed to the operating system (under UNIX, via
-the @code{fflush()} library call) with the result that errors,
-such as disk full, would be immediately flagged via the
-relevant @code{ERR=} and @code{IOSTAT=} mechanism.
-
-Because of the adverse effects this approach had on the performance
-of many programs, @command{g77} no longer configures @code{libf2c}
-(now named @code{libg2c} in its @command{g77} incarnation)
-to always flush output.
-
-If your program depends on this behavior, either insert the
-appropriate @samp{CALL FLUSH} statements, or modify the sources
-to the @code{libg2c}, rebuild and reinstall @command{g77}, and
-relink your programs with the modified library.
-
-(Ideally, @code{libg2c} would offer the choice at run-time, so
-that a compile-time option to @command{g77} or @command{f2c} could
-result in generating the appropriate calls to flushing or
-non-flushing library routines.)
-
-Some Fortran programs require output
-(writes) to be flushed to the operating system (under UNIX,
-via the @code{fflush()} library call) so that errors,
-such as disk full, are immediately flagged via the relevant
-@code{ERR=} and @code{IOSTAT=} mechanism, instead of such
-errors being flagged later as subsequent writes occur, forcing
-the previously written data to disk, or when the file is
-closed.
-
-Essentially, the difference can be viewed as synchronous error
-reporting (immediate flagging of errors during writes) versus
-asynchronous, or, more precisely, buffered error reporting
-(detection of errors might be delayed).
-
-@code{libg2c} supports flagging write errors immediately when
-it is built with the @code{ALWAYS_FLUSH} macro defined.
-This results in a @code{libg2c} that runs slower, sometimes
-quite a bit slower, under certain circumstances---for example,
-accessing files via the networked file system NFS---but the
-effect can be more reliable, robust file I/O.
-
-If you know that Fortran programs requiring this level of precision
-of error reporting are to be compiled using the
-version of @command{g77} you are building, you might wish to
-modify the @command{g77} source tree so that the version of
-@code{libg2c} is built with the @code{ALWAYS_FLUSH} macro
-defined, enabling this behavior.
-
-To do this, find this line in @file{@value{path-libf2c}/f2c.h} in
-your @command{g77} source tree:
-
-@example
-/* #define ALWAYS_FLUSH */
-@end example
-
-Remove the leading @samp{/*@w{ }},
-so the line begins with @samp{#define},
-and the trailing @samp{@w{ }*/}.
-
-Then build or rebuild @command{g77} as appropriate.
-
-@node Large File Unit Numbers
-@subsection Large File Unit Numbers
-@cindex MXUNIT
-@cindex unit numbers
-@cindex maximum unit number
-@cindex illegal unit number
-@cindex increasing maximum unit number
-
-If your program crashes at run time with a message including
-the text @samp{illegal unit number}, that probably is
-a message from the run-time library, @code{libg2c}.
-
-The message means that your program has attempted to use a
-file unit number that is out of the range accepted by
-@code{libg2c}.
-Normally, this range is 0 through 99, and the high end
-of the range is controlled by a @code{libg2c} source-file
-macro named @code{MXUNIT}.
-
-If you can easily change your program to use unit numbers
-in the range 0 through 99, you should do so.
-
-As distributed, whether as part of @command{f2c} or @command{g77},
-@code{libf2c} accepts file unit numbers only in the range
-0 through 99.
-For example, a statement such as @samp{WRITE (UNIT=100)} causes
-a run-time crash in @code{libf2c}, because the unit number,
-100, is out of range.
-
-If you know that Fortran programs at your installation require
-the use of unit numbers higher than 99, you can change the
-value of the @code{MXUNIT} macro, which represents the maximum unit
-number, to an appropriately higher value.
-
-To do this, edit the file @file{@value{path-libf2c}/libI77/fio.h} in your
-@command{g77} source tree, changing the following line:
-
-@example
-#define MXUNIT 100
-@end example
-
-Change the line so that the value of @code{MXUNIT} is defined to be
-at least one @emph{greater} than the maximum unit number used by
-the Fortran programs on your system.
-
-(For example, a program that does @samp{WRITE (UNIT=255)} would require
-@code{MXUNIT} set to at least 256 to avoid crashing.)
-
-Then build or rebuild @command{g77} as appropriate.
-
-@emph{Note:} Changing this macro has @emph{no} effect on other limits
-your system might place on the number of files open at the same time.
-That is, the macro might allow a program to do @samp{WRITE (UNIT=100)},
-but the library and operating system underlying @code{libf2c} might
-disallow it if many other files have already been opened (via @code{OPEN} or
-implicitly via @code{READ}, @code{WRITE}, and so on).
-Information on how to increase these other limits should be found
-in your system's documentation.
-
-@node Floating-point precision
-@subsection Floating-point precision
-
-@cindex IEEE 754 conformance
-@cindex conformance, IEEE 754
-@cindex floating-point, precision
-@cindex ix86 floating-point
-@cindex x86 floating-point
-If your program depends on exact IEEE 754 floating-point handling it may
-help on some systems---specifically x86 or m68k hardware---to use
-the @option{-ffloat-store} option or to reset the precision flag on the
-floating-point unit.
-@xref{Optimize Options}.
-
-However, it might be better simply to put the FPU into double precision
-mode and not take the performance hit of @option{-ffloat-store}. On x86
-and m68k GNU systems you can do this with a technique similar to that
-for turning on floating-point exceptions
-(@pxref{Floating-point Exception Handling}).
-The control word could be set to double precision by some code like this
-one:
-@smallexample
-#include <fpu_control.h>
-@{
- fpu_control_t cw = (_FPU_DEFAULT & ~_FPU_EXTENDED) | _FPU_DOUBLE;
- _FPU_SETCW(cw);
-@}
-@end smallexample
-(It is not clear whether this has any effect on the operation of the GNU
-maths library, but we have no evidence of it causing trouble.)
-
-Some targets (such as the Alpha) may need special options for full IEEE
-conformance.
-@xref{Submodel Options,,Hardware Models and Configurations,gcc,Using
-the GNU Compiler Collection (GCC)}.
-
-@node Inconsistent Calling Sequences
-@subsection Inconsistent Calling Sequences
-
-@pindex ftnchek
-@cindex floating-point, errors
-@cindex ix86 FPU stack
-@cindex x86 FPU stack
-Code containing inconsistent calling sequences in the same file is
-normally rejected---see @ref{GLOBALS}.
-(Use, say, @command{ftnchek} to ensure
-consistency across source files.
-@xref{f2c Skeletons and Prototypes,,
-Generating Skeletons and Prototypes with @command{f2c}}.)
-
-Mysterious errors, which may appear to be code generation problems, can
-appear specifically on the x86 architecture with some such
-inconsistencies. On x86 hardware, floating-point return values of
-functions are placed on the floating-point unit's register stack, not
-the normal stack. Thus calling a @code{REAL} or @code{DOUBLE PRECISION}
-@code{FUNCTION} as some other sort of procedure, or vice versa,
-scrambles the floating-point stack. This may break unrelated code
-executed later. Similarly if, say, external C routines are written
-incorrectly.
-
-@node Overly Convenient Options
-@section Overly Convenient Command-line Options
-@cindex overly convenient options
-@cindex options, overly convenient
-
-These options should be used only as a quick-and-dirty way to determine
-how well your program will run under different compilation models
-without having to change the source.
-Some are more problematic
-than others, depending on how portable and maintainable you want the
-program to be (and, of course, whether you are allowed to change it
-at all is crucial).
-
-You should not continue to use these command-line options to compile
-a given program, but rather should make changes to the source code:
-
-@table @code
-@cindex -finit-local-zero option
-@cindex options, -finit-local-zero
-@item -finit-local-zero
-(This option specifies that any uninitialized local variables
-and arrays have default initialization to binary zeros.)
-
-Many other compilers do this automatically, which means lots of
-Fortran code developed with those compilers depends on it.
-
-It is safer (and probably
-would produce a faster program) to find the variables and arrays that
-need such initialization and provide it explicitly via @code{DATA}, so that
-@option{-finit-local-zero} is not needed.
-
-Consider using @option{-Wuninitialized} (which requires @option{-O}) to
-find likely candidates, but
-do not specify @option{-finit-local-zero} or @option{-fno-automatic},
-or this technique won't work.
-
-@cindex -fno-automatic option
-@cindex options, -fno-automatic
-@item -fno-automatic
-(This option specifies that all local variables and arrays
-are to be treated as if they were named in @code{SAVE} statements.)
-
-Many other compilers do this automatically, which means lots of
-Fortran code developed with those compilers depends on it.
-
-The effect of this is that all non-automatic variables and arrays
-are made static, that is, not placed on the stack or in heap storage.
-This might cause a buggy program to appear to work better.
-If so, rather than relying on this command-line option (and hoping all
-compilers provide the equivalent one), add @code{SAVE}
-statements to some or all program unit sources, as appropriate.
-Consider using @option{-Wuninitialized} (which requires @option{-O})
-to find likely candidates, but
-do not specify @option{-finit-local-zero} or @option{-fno-automatic},
-or this technique won't work.
-
-The default is @option{-fautomatic}, which tells @command{g77} to try
-and put variables and arrays on the stack (or in fast registers)
-where possible and reasonable.
-This tends to make programs faster.
-
-@cindex automatic arrays
-@cindex arrays, automatic
-@emph{Note:} Automatic variables and arrays are not affected
-by this option.
-These are variables and arrays that are @emph{necessarily} automatic,
-either due to explicit statements, or due to the way they are
-declared.
-Examples include local variables and arrays not given the
-@code{SAVE} attribute in procedures declared @code{RECURSIVE},
-and local arrays declared with non-constant bounds (automatic
-arrays).
-Currently, @command{g77} supports only automatic arrays, not
-@code{RECURSIVE} procedures or other means of explicitly
-specifying that variables or arrays are automatic.
-
-@cindex -f@var{group}-intrinsics-hide option
-@cindex options, -f@var{group}-intrinsics-hide
-@item -f@var{group}-intrinsics-hide
-Change the source code to use @code{EXTERNAL} for any external procedure
-that might be the name of an intrinsic.
-It is easy to find these using @option{-f@var{group}-intrinsics-disable}.
-@end table
-
-@node Faster Programs
-@section Faster Programs
-@cindex speed, of programs
-@cindex programs, speeding up
-
-Aside from the usual @command{gcc} options, such as @option{-O},
-@option{-ffast-math}, and so on, consider trying some of the
-following approaches to speed up your program (once you get
-it working).
-
-@menu
-* Aligned Data::
-* Prefer Automatic Uninitialized Variables::
-* Avoid f2c Compatibility::
-* Use Submodel Options::
-@end menu
-
-@node Aligned Data
-@subsection Aligned Data
-@cindex alignment
-@cindex data, aligned
-@cindex stack, aligned
-@cindex aligned data
-@cindex aligned stack
-@cindex Pentium optimizations
-@cindex optimization, for Pentium
-
-On some systems, such as those with Pentium Pro CPUs, programs
-that make heavy use of @code{REAL(KIND=2)} (@code{DOUBLE PRECISION})
-might run much slower
-than possible due to the compiler not aligning these 64-bit
-values to 64-bit boundaries in memory.
-(The effect also is present, though
-to a lesser extent, on the 586 (Pentium) architecture.)
-
-The Intel x86 architecture generally ensures that these programs will
-work on all its implementations,
-but particular implementations (such as Pentium Pro)
-perform better with more strict alignment.
-(Such behavior isn't unique to the Intel x86 architecture.)
-Other architectures might @emph{demand} 64-bit alignment
-of 64-bit data.
-
-There are a variety of approaches to use to address this problem:
-
-@itemize @bullet
-@item
-@cindex @code{COMMON} layout
-@cindex layout of @code{COMMON} blocks
-Order your @code{COMMON} and @code{EQUIVALENCE} areas such
-that the variables and arrays with the widest alignment
-guidelines come first.
-
-For example, on most systems, this would mean placing
-@code{COMPLEX(KIND=2)}, @code{REAL(KIND=2)}, and
-@code{INTEGER(KIND=2)} entities first, followed by @code{REAL(KIND=1)},
-@code{INTEGER(KIND=1)}, and @code{LOGICAL(KIND=1)} entities, then
-@code{INTEGER(KIND=6)} entities, and finally @code{CHARACTER}
-and @code{INTEGER(KIND=3)} entities.
-
-The reason to use such placement is it makes it more likely
-that your data will be aligned properly, without requiring
-you to do detailed analysis of each aggregate (@code{COMMON}
-and @code{EQUIVALENCE}) area.
-
-Specifically, on systems where the above guidelines are
-appropriate, placing @code{CHARACTER} entities before
-@code{REAL(KIND=2)} entities can work just as well,
-but only if the number of bytes occupied by the @code{CHARACTER}
-entities is divisible by the recommended alignment for
-@code{REAL(KIND=2)}.
-
-By ordering the placement of entities in aggregate
-areas according to the simple guidelines above, you
-avoid having to carefully count the number of bytes
-occupied by each entity to determine whether the
-actual alignment of each subsequent entity meets the
-alignment guidelines for the type of that entity.
-
-If you don't ensure correct alignment of @code{COMMON} elements, the
-compiler may be forced by some systems to violate the Fortran semantics by
-adding padding to get @code{DOUBLE PRECISION} data properly aligned.
-If the unfortunate practice is employed of overlaying different types of
-data in the @code{COMMON} block, the different variants
-of this block may become misaligned with respect to each other.
-Even if your platform doesn't require strict alignment,
-@code{COMMON} should be laid out as above for portability.
-(Unfortunately the FORTRAN 77 standard didn't anticipate this
-possible requirement, which is compiler-independent on a given platform.)
-
-@item
-@cindex -malign-double option
-@cindex options, -malign-double
-Use the (x86-specific) @option{-malign-double} option when compiling
-programs for the Pentium and Pentium Pro architectures (called 586
-and 686 in the @command{gcc} configuration subsystem).
-The warning about this in the @command{gcc} manual isn't
-generally relevant to Fortran,
-but using it will force @code{COMMON} to be padded if necessary to align
-@code{DOUBLE PRECISION} data.
-
-When @code{DOUBLE PRECISION} data is forcibly aligned
-in @code{COMMON} by @command{g77} due to specifying @option{-malign-double},
-@command{g77} issues a warning about the need to
-insert padding.
-
-In this case, each and every program unit that uses
-the same @code{COMMON} area
-must specify the same layout of variables and their types
-for that area
-and be compiled with @option{-malign-double} as well.
-@command{g77} will issue warnings in each case,
-but as long as every program unit using that area
-is compiled with the same warnings,
-the resulting object files should work when linked together
-unless the program makes additional assumptions about
-@code{COMMON} area layouts that are outside the scope
-of the FORTRAN 77 standard,
-or uses @code{EQUIVALENCE} or different layouts
-in ways that assume no padding is ever inserted by the compiler.
-
-@item
-Ensure that @file{crt0.o} or @file{crt1.o}
-on your system guarantees a 64-bit
-aligned stack for @code{main()}.
-The recent one from GNU (@code{glibc2}) will do this on x86 systems,
-but we don't know of any other x86 setups where it will be right.
-Read your system's documentation to determine if
-it is appropriate to upgrade to a more recent version
-to obtain the optimal alignment.
-@end itemize
-
-Progress is being made on making this work
-``out of the box'' on future versions of @command{g77},
-@command{gcc}, and some of the relevant operating systems
-(such as GNU/Linux).
-
-@node Prefer Automatic Uninitialized Variables
-@subsection Prefer Automatic Uninitialized Variables
-
-If you're using @option{-fno-automatic} already, you probably
-should change your code to allow compilation with @option{-fautomatic}
-(the default), to allow the program to run faster.
-
-Similarly, you should be able to use @option{-fno-init-local-zero}
-(the default) instead of @option{-finit-local-zero}.
-This is because it is rare that every variable affected by these
-options in a given program actually needs to
-be so affected.
-
-For example, @option{-fno-automatic}, which effectively @code{SAVE}s
-every local non-automatic variable and array, affects even things like
-@code{DO} iteration
-variables, which rarely need to be @code{SAVE}d, and this often reduces
-run-time performances.
-Similarly, @option{-fno-init-local-zero} forces such
-variables to be initialized to zero---when @code{SAVE}d (such as when
-@option{-fno-automatic}), this by itself generally affects only
-startup time for a program, but when not @code{SAVE}d,
-it can slow down the procedure every time it is called.
-
-@xref{Overly Convenient Options,,Overly Convenient Command-Line Options},
-for information on the @option{-fno-automatic} and
-@option{-finit-local-zero} options and how to convert
-their use into selective changes in your own code.
-
-@node Avoid f2c Compatibility
-@subsection Avoid f2c Compatibility
-@cindex -fno-f2c option
-@cindex options, -fno-f2c
-@cindex @command{f2c} compatibility
-@cindex compatibility, @command{f2c}
-
-If you aren't linking with any code compiled using
-@command{f2c}, try using the @option{-fno-f2c} option when
-compiling @emph{all} the code in your program.
-(Note that @code{libf2c} is @emph{not} an example of code
-that is compiled using @command{f2c}---it is compiled by a C
-compiler, typically @command{gcc}.)
-
-@node Use Submodel Options
-@subsection Use Submodel Options
-@cindex submodels
-
-Using an appropriate @option{-m} option to generate specific code for your
-CPU may be worthwhile, though it may mean the executable won't run on
-other versions of the CPU that don't support the same instruction set.
-@xref{Submodel Options,,Hardware Models and Configurations,gcc,Using the
-GNU Compiler Collection (GCC)}. For instance on an x86 system the
-compiler might have
-been built---as shown by @samp{g77 -v}---for the target
-@samp{i386-pc-linux-gnu}, i.e.@: an @samp{i386} CPU@. In that case to
-generate code best optimized for a Pentium you could use the option
-@option{-march=pentium}.
-
-For recent CPUs that don't have explicit support in the released version
-of @command{gcc}, it @emph{might} still be possible to get improvements
-with certain @option{-m} options.
-
-@option{-fomit-frame-pointer} can help performance on x86 systems and
-others. It will, however, inhibit debugging on the systems on which it
-is not turned on anyway by @option{-O}.
-
-@node Trouble
-@chapter Known Causes of Trouble with GNU Fortran
-@cindex bugs, known
-@cindex installation trouble
-@cindex known causes of trouble
-
-This section describes known problems that affect users of GNU Fortran.
-Most of these are not GNU Fortran bugs per se---if they were, we would
-fix them.
-But the result for a user might be like the result of a bug.
-
-Some of these problems are due to bugs in other software, some are
-missing features that are too much work to add, and some are places
-where people's opinions differ as to what is best.
-
-(Note that some of this portion of the manual is lifted
-directly from the @command{gcc} manual, with minor modifications
-to tailor it to users of @command{g77}.
-Anytime a bug seems to have more to do with the @command{gcc}
-portion of @command{g77}, see
-@ref{Trouble,,Known Causes of Trouble with GCC,
-gcc,Using the GNU Compiler Collection (GCC)}.)
-
-@menu
-* But-bugs:: Bugs really in other programs or elsewhere.
-* Known Bugs:: Bugs known to be in this version of @command{g77}.
-* Missing Features:: Features we already know we want to add later.
-* Disappointments:: Regrettable things we can't change.
-* Non-bugs:: Things we think are right, but some others disagree.
-* Warnings and Errors:: Which problems in your code get warnings,
- and which get errors.
-@end menu
-
-@node But-bugs
-@section Bugs Not In GNU Fortran
-@cindex but-bugs
-
-These are bugs to which the maintainers often have to reply,
-``but that isn't a bug in @command{g77}@dots{}''.
-Some of these already are fixed in new versions of other
-software; some still need to be fixed; some are problems
-with how @command{g77} is installed or is being used;
-some are the result of bad hardware that causes software
-to misbehave in sometimes bizarre ways;
-some just cannot be addressed at this time until more
-is known about the problem.
-
-Please don't re-report these bugs to the @command{g77} maintainers---if
-you must remind someone how important it is to you that the problem
-be fixed, talk to the people responsible for the other products
-identified below, but preferably only after you've tried the
-latest versions of those products.
-The @command{g77} maintainers have their hands full working on
-just fixing and improving @command{g77}, without serving as a
-clearinghouse for all bugs that happen to affect @command{g77}
-users.
-
-@xref{Collected Fortran Wisdom}, for information on behavior
-of Fortran programs, and the programs that compile them, that
-might be @emph{thought} to indicate bugs.
-
-@menu
-* Signal 11 and Friends:: Strange behavior by any software.
-* Cannot Link Fortran Programs:: Unresolved references.
-* Large Common Blocks:: Problems on older GNU/Linux systems.
-* Debugger Problems:: When the debugger crashes.
-* NeXTStep Problems:: Misbehaving executables.
-* Stack Overflow:: More misbehaving executables.
-* Nothing Happens:: Less behaving executables.
-* Strange Behavior at Run Time:: Executables misbehaving due to
- bugs in your program.
-* Floating-point Errors:: The results look wrong, but@dots{}.
-@end menu
-
-@node Signal 11 and Friends
-@subsection Signal 11 and Friends
-@cindex signal 11
-@cindex hardware errors
-
-A whole variety of strange behaviors can occur when the
-software, or the way you are using the software,
-stresses the hardware in a way that triggers hardware bugs.
-This might seem hard to believe, but it happens frequently
-enough that there exist documents explaining in detail
-what the various causes of the problems are, what
-typical symptoms look like, and so on.
-
-Generally these problems are referred to in this document
-as ``signal 11'' crashes, because the Linux kernel, running
-on the most popular hardware (the Intel x86 line), often
-stresses the hardware more than other popular operating
-systems.
-When hardware problems do occur under GNU/Linux on x86
-systems, these often manifest themselves as ``signal 11''
-problems, as illustrated by the following diagnostic:
-
-@smallexample
-sh# @kbd{g77 myprog.f}
-gcc: Internal compiler error: program f771 got fatal signal 11
-sh#
-@end smallexample
-
-It is @emph{very} important to remember that the above
-message is @emph{not} the only one that indicates a
-hardware problem, nor does it always indicate a hardware
-problem.
-
-In particular, on systems other than those running the Linux
-kernel, the message might appear somewhat or very different,
-as it will if the error manifests itself while running a
-program other than the @command{g77} compiler.
-For example,
-it will appear somewhat different when running your program,
-when running Emacs, and so on.
-
-How to cope with such problems is well beyond the scope
-of this manual.
-
-However, users of Linux-based systems (such as GNU/Linux)
-should review @uref{http://www.bitwizard.nl/sig11/}, a source
-of detailed information on diagnosing hardware problems,
-by recognizing their common symptoms.
-
-Users of other operating systems and hardware might
-find this reference useful as well.
-If you know of similar material for another hardware/software
-combination, please let us know so we can consider including
-a reference to it in future versions of this manual.
-
-@node Cannot Link Fortran Programs
-@subsection Cannot Link Fortran Programs
-@cindex unresolved reference (various)
-@cindex linking error for user code
-@cindex code, user
-@cindex @command{ld}, error linking user code
-@cindex @command{ld}, can't find strange names
-On some systems, perhaps just those with out-of-date (shared?)
-libraries, unresolved-reference errors happen when linking @command{g77}-compiled
-programs (which should be done using @command{g77}).
-
-If this happens to you, try appending @option{-lc} to the command you
-use to link the program, e.g. @samp{g77 foo.f -lc}.
-@command{g77} already specifies @samp{-lg2c -lm} when it calls the linker,
-but it cannot also specify @option{-lc} because not all systems have a
-file named @file{libc.a}.
-
-It is unclear at this point whether there are legitimately installed
-systems where @samp{-lg2c -lm} is insufficient to resolve code produced
-by @command{g77}.
-
-@cindex undefined reference (_main)
-@cindex linking error, user code
-@cindex @command{ld}, error linking user code
-@cindex code, user
-@cindex @command{ld}, can't find @samp{_main}
-If your program doesn't link due to unresolved references to names
-like @samp{_main}, make sure you're using the @command{g77} command to do the
-link, since this command ensures that the necessary libraries are
-loaded by specifying @samp{-lg2c -lm} when it invokes the @command{gcc}
-command to do the actual link.
-(Use the @option{-v} option to discover
-more about what actually happens when you use the @command{g77} and @command{gcc}
-commands.)
-
-Also, try specifying @option{-lc} as the last item on the @command{g77}
-command line, in case that helps.
-
-@node Large Common Blocks
-@subsection Large Common Blocks
-@cindex common blocks, large
-@cindex large common blocks
-@cindex linking, errors
-@cindex @command{ld}, errors
-@cindex errors, linker
-On some older GNU/Linux systems, programs with common blocks larger
-than 16MB cannot be linked without some kind of error
-message being produced.
-
-This is a bug in older versions of @command{ld}, fixed in
-more recent versions of @code{binutils}, such as version 2.6.
-
-@node Debugger Problems
-@subsection Debugger Problems
-@cindex @command{gdb}, support
-@cindex support, @command{gdb}
-There are some known problems when using @command{gdb} on code
-compiled by @command{g77}.
-Inadequate investigation as of the release of 0.5.16 results in not
-knowing which products are the culprit, but @file{gdb-4.14} definitely
-crashes when, for example, an attempt is made to print the contents
-of a @code{COMPLEX(KIND=2)} dummy array, on at least some GNU/Linux
-machines, plus some others.
-Attempts to access assumed-size arrays are
-also known to crash recent versions of @command{gdb}.
-(@command{gdb}'s Fortran support was done for a different compiler
-and isn't properly compatible with @command{g77}.)
-
-@node NeXTStep Problems
-@subsection NeXTStep Problems
-@cindex NeXTStep problems
-@cindex bus error
-@cindex segmentation violation
-Developers of Fortran code on NeXTStep (all architectures) have to
-watch out for the following problem when writing programs with
-large, statically allocated (i.e. non-stack based) data structures
-(common blocks, saved arrays).
-
-Due to the way the native loader (@file{/bin/ld}) lays out
-data structures in virtual memory, it is very easy to create an
-executable wherein the @samp{__DATA} segment overlaps (has addresses in
-common) with the @samp{UNIX STACK} segment.
-
-This leads to all sorts of trouble, from the executable simply not
-executing, to bus errors.
-The NeXTStep command line tool @command{ebadexec} points to
-the problem as follows:
-
-@smallexample
-% @kbd{/bin/ebadexec a.out}
-/bin/ebadexec: __LINKEDIT segment (truncated address = 0x3de000
-rounded size = 0x2a000) of executable file: a.out overlaps with UNIX
-STACK segment (truncated address = 0x400000 rounded size =
-0x3c00000) of executable file: a.out
-@end smallexample
-
-(In the above case, it is the @samp{__LINKEDIT} segment that overlaps the
-stack segment.)
-
-This can be cured by assigning the @samp{__DATA} segment
-(virtual) addresses beyond the stack segment.
-A conservative
-estimate for this is from address 6000000 (hexadecimal) onwards---this
-has always worked for me [Toon Moene]:
-
-@smallexample
-% @kbd{g77 -segaddr __DATA 6000000 test.f}
-% @kbd{ebadexec a.out}
-ebadexec: file: a.out appears to be executable
-%
-@end smallexample
-
-Browsing through @file{@value{path-g77}/Makefile.in},
-you will find that the @code{f771} program itself also has to be
-linked with these flags---it has large statically allocated
-data structures.
-(Version 0.5.18 reduces this somewhat, but probably
-not enough.)
-
-(The above item was contributed by Toon Moene
-(@email{toon@@moene.indiv.nluug.nl}).)
-
-@node Stack Overflow
-@subsection Stack Overflow
-@cindex stack, overflow
-@cindex segmentation violation
-@command{g77} code might fail at runtime (probably with a ``segmentation
-violation'') due to overflowing the stack.
-This happens most often on systems with an environment
-that provides substantially more heap space (for use
-when arbitrarily allocating and freeing memory) than stack
-space.
-
-Often this can be cured by
-increasing or removing your shell's limit on stack usage, typically
-using @kbd{limit stacksize} (in @command{csh} and derivatives) or
-@kbd{ulimit -s} (in @command{sh} and derivatives).
-
-Increasing the allowed stack size might, however, require
-changing some operating system or system configuration parameters.
-
-You might be able to work around the problem by compiling with the
-@option{-fno-automatic} option to reduce stack usage, probably at the
-expense of speed.
-
-@command{g77}, on most machines, puts many variables and arrays on the stack
-where possible, and can be configured (by changing
-@code{FFECOM_sizeMAXSTACKITEM} in @file{@value{path-g77}/com.c}) to force
-smaller-sized entities into static storage (saving
-on stack space) or permit larger-sized entities to be put on the
-stack (which can improve run-time performance, as it presents
-more opportunities for the GBE to optimize the generated code).
-
-@emph{Note:} Putting more variables and arrays on the stack
-might cause problems due to system-dependent limits on stack size.
-Also, the value of @code{FFECOM_sizeMAXSTACKITEM} has no
-effect on automatic variables and arrays.
-@xref{But-bugs}, for more information.
-@emph{Note:} While @code{libg2c} places a limit on the range
-of Fortran file-unit numbers, the underlying library and operating
-system might impose different kinds of limits.
-For example, some systems limit the number of files simultaneously
-open by a running program.
-Information on how to increase these limits should be found
-in your system's documentation.
-
-@cindex automatic arrays
-@cindex arrays, automatic
-However, if your program uses large automatic arrays
-(for example, has declarations like @samp{REAL A(N)} where
-@samp{A} is a local array and @samp{N} is a dummy or
-@code{COMMON} variable that can have a large value),
-neither use of @option{-fno-automatic},
-nor changing the cut-off point for @command{g77} for using the stack,
-will solve the problem by changing the placement of these
-large arrays, as they are @emph{necessarily} automatic.
-
-@command{g77} currently provides no means to specify that
-automatic arrays are to be allocated on the heap instead
-of the stack.
-So, other than increasing the stack size, your best bet is to
-change your source code to avoid large automatic arrays.
-Methods for doing this currently are outside the scope of
-this document.
-
-(@emph{Note:} If your system puts stack and heap space in the
-same memory area, such that they are effectively combined, then
-a stack overflow probably indicates a program that is either
-simply too large for the system, or buggy.)
-
-@node Nothing Happens
-@subsection Nothing Happens
-@cindex nothing happens
-@cindex naming programs
-@cindex @command{test} programs
-@cindex programs, @command{test}
-It is occasionally reported that a ``simple'' program,
-such as a ``Hello, World!'' program, does nothing when
-it is run, even though the compiler reported no errors,
-despite the program containing nothing other than a
-simple @code{PRINT} statement.
-
-This most often happens because the program has been
-compiled and linked on a UNIX system and named @command{test},
-though other names can lead to similarly unexpected
-run-time behavior on various systems.
-
-Essentially this problem boils down to giving
-your program a name that is already known to
-the shell you are using to identify some other program,
-which the shell continues to execute instead of your
-program when you invoke it via, for example:
-
-@smallexample
-sh# @kbd{test}
-sh#
-@end smallexample
-
-Under UNIX and many other system, a simple command name
-invokes a searching mechanism that might well not choose
-the program located in the current working directory if
-there is another alternative (such as the @command{test}
-command commonly installed on UNIX systems).
-
-The reliable way to invoke a program you just linked in
-the current directory under UNIX is to specify it using
-an explicit pathname, as in:
-
-@smallexample
-sh# @kbd{./test}
- Hello, World!
-sh#
-@end smallexample
-
-Users who encounter this problem should take the time to
-read up on how their shell searches for commands, how to
-set their search path, and so on.
-The relevant UNIX commands to learn about include
-@command{man}, @command{info} (on GNU systems), @command{setenv} (or
-@command{set} and @command{env}), @command{which}, and @command{find}.
-
-@node Strange Behavior at Run Time
-@subsection Strange Behavior at Run Time
-@cindex segmentation violation
-@cindex bus error
-@cindex overwritten data
-@cindex data, overwritten
-@command{g77} code might fail at runtime with ``segmentation violation'',
-``bus error'', or even something as subtle as a procedure call
-overwriting a variable or array element that it is not supposed
-to touch.
-
-These can be symptoms of a wide variety of actual bugs that
-occurred earlier during the program's run, but manifested
-themselves as @emph{visible} problems some time later.
-
-Overflowing the bounds of an array---usually by writing beyond
-the end of it---is one of two kinds of bug that often occurs
-in Fortran code.
-(Compile your code with the @option{-fbounds-check} option
-to catch many of these kinds of errors at program run time.)
-
-The other kind of bug is a mismatch between the actual arguments
-passed to a procedure and the dummy arguments as declared by that
-procedure.
-
-Both of these kinds of bugs, and some others as well, can be
-difficult to track down, because the bug can change its behavior,
-or even appear to not occur, when using a debugger.
-
-That is, these bugs can be quite sensitive to data, including
-data representing the placement of other data in memory (that is,
-pointers, such as the placement of stack frames in memory).
-
-@command{g77} now offers the
-ability to catch and report some of these problems at compile, link, or
-run time, such as by generating code to detect references to
-beyond the bounds of most arrays (except assumed-size arrays),
-and checking for agreement between calling and called procedures.
-Future improvements are likely to be made in the procedure-mismatch area,
-at least.
-
-In the meantime, finding and fixing the programming
-bugs that lead to these behaviors is, ultimately, the user's
-responsibility, as difficult as that task can sometimes be.
-
-@cindex infinite spaces printed
-@cindex space, endless printing of
-@cindex libc, non-ANSI or non-default
-@cindex C library
-@cindex linking against non-standard library
-@cindex Solaris
-One runtime problem that has been observed might have a simple solution.
-If a formatted @code{WRITE} produces an endless stream of spaces, check
-that your program is linked against the correct version of the C library.
-The configuration process takes care to account for your
-system's normal @file{libc} not being ANSI-standard, which will
-otherwise cause this behavior.
-If your system's default library is
-ANSI-standard and you subsequently link against a non-ANSI one, there
-might be problems such as this one.
-
-Specifically, on Solaris2 systems,
-avoid picking up the @code{BSD} library from @file{/usr/ucblib}.
-
-@node Floating-point Errors
-@subsection Floating-point Errors
-@cindex floating-point errors
-@cindex rounding errors
-@cindex inconsistent floating-point results
-@cindex results, inconsistent
-Some programs appear to produce inconsistent floating-point
-results compiled by @command{g77} versus by other compilers.
-
-Often the reason for this behavior is the fact that floating-point
-values are represented on almost all Fortran systems by
-@emph{approximations}, and these approximations are inexact
-even for apparently simple values like 0.1, 0.2, 0.3, 0.4, 0.6,
-0.7, 0.8, 0.9, 1.1, and so on.
-Most Fortran systems, including all current ports of @command{g77},
-use binary arithmetic to represent these approximations.
-
-Therefore, the exact value of any floating-point approximation
-as manipulated by @command{g77}-compiled code is representable by
-adding some combination of the values 1.0, 0.5, 0.25, 0.125, and
-so on (just keep dividing by two) through the precision of the
-fraction (typically around 23 bits for @code{REAL(KIND=1)}, 52 for
-@code{REAL(KIND=2)}), then multiplying the sum by a integral
-power of two (in Fortran, by @samp{2**N}) that typically is between
--127 and +128 for @code{REAL(KIND=1)} and -1023 and +1024 for
-@code{REAL(KIND=2)}, then multiplying by -1 if the number
-is negative.
-
-So, a value like 0.2 is exactly represented in decimal---since
-it is a fraction, @samp{2/10}, with a denominator that is compatible
-with the base of the number system (base 10).
-However, @samp{2/10} cannot be represented by any finite number
-of sums of any of 1.0, 0.5, 0.25, and so on, so 0.2 cannot
-be exactly represented in binary notation.
-
-(On the other hand, decimal notation can represent any binary
-number in a finite number of digits.
-Decimal notation cannot do so with ternary, or base-3,
-notation, which would represent floating-point numbers as
-sums of any of @samp{1/1}, @samp{1/3}, @samp{1/9}, and so on.
-After all, no finite number of decimal digits can exactly
-represent @samp{1/3}.
-Fortunately, few systems use ternary notation.)
-
-Moreover, differences in the way run-time I/O libraries convert
-between these approximations and the decimal representation often
-used by programmers and the programs they write can result in
-apparent differences between results that do not actually exist,
-or exist to such a small degree that they usually are not worth
-worrying about.
-
-For example, consider the following program:
-
-@smallexample
-PRINT *, 0.2
-END
-@end smallexample
-
-When compiled by @command{g77}, the above program might output
-@samp{0.20000003}, while another compiler might produce a
-executable that outputs @samp{0.2}.
-
-This particular difference is due to the fact that, currently,
-conversion of floating-point values by the @code{libg2c} library,
-used by @command{g77}, handles only double-precision values.
-
-Since @samp{0.2} in the program is a single-precision value, it
-is converted to double precision (still in binary notation)
-before being converted back to decimal.
-The conversion to binary appends @emph{binary} zero digits to the
-original value---which, again, is an inexact approximation of
-0.2---resulting in an approximation that is much less exact
-than is connoted by the use of double precision.
-
-(The appending of binary zero digits has essentially the same
-effect as taking a particular decimal approximation of
-@samp{1/3}, such as @samp{0.3333333}, and appending decimal
-zeros to it, producing @samp{0.33333330000000000}.
-Treating the resulting decimal approximation as if it really
-had 18 or so digits of valid precision would make it seem
-a very poor approximation of @samp{1/3}.)
-
-As a result of converting the single-precision approximation
-to double precision by appending binary zeros, the conversion
-of the resulting double-precision
-value to decimal produces what looks like an incorrect
-result, when in fact the result is @emph{inexact}, and
-is probably no less inaccurate or imprecise an approximation
-of 0.2 than is produced by other compilers that happen to output
-the converted value as ``exactly'' @samp{0.2}.
-(Some compilers behave in a way that can make them appear
-to retain more accuracy across a conversion of a single-precision
-constant to double precision.
-@xref{Context-Sensitive Constants}, to see why
-this practice is illusory and even dangerous.)
-
-Note that a more exact approximation of the constant is
-computed when the program is changed to specify a
-double-precision constant:
-
-@smallexample
-PRINT *, 0.2D0
-END
-@end smallexample
-
-Future versions of @command{g77} and/or @code{libg2c} might convert
-single-precision values directly to decimal,
-instead of converting them to double precision first.
-This would tend to result in output that is more consistent
-with that produced by some other Fortran implementations.
-
-A useful source of information on floating-point computation is David
-Goldberg, `What Every Computer Scientist Should Know About
-Floating-Point Arithmetic', Computing Surveys, 23, March 1991, pp.@:
-5-48.
-An online version is available at
-@uref{http://docs.sun.com/}.
-
-Information related to the IEEE 754 floating-point standard can be found
-at @uref{http://grouper.ieee.org/groups/754/} and
-@uref{http://http.cs.berkeley.edu/%7Ewkahan/ieee754status/};
-see also slides from the short course referenced from
-@uref{http://http.cs.berkeley.edu/%7Efateman/}.
-
-The supplement to the PostScript-formatted Goldberg document,
-referenced above, is available in HTML format.
-See `Differences Among IEEE 754 Implementations' by Doug Priest.
-This document explores some of the issues surrounding computing
-of extended (80-bit) results on processors such as the x86,
-especially when those results are arbitrarily truncated
-to 32-bit or 64-bit values by the compiler
-as ``spills''.
-
-@cindex spills of floating-point results
-@cindex 80-bit spills
-@cindex truncation, of floating-point values
-(@emph{Note:} @command{g77} specifically, and @command{gcc} generally,
-does arbitrarily truncate 80-bit results during spills
-as of this writing.
-It is not yet clear whether a future version of
-the GNU compiler suite will offer 80-bit spills
-as an option, or perhaps even as the default behavior.)
-
-@c xref would be different between editions:
-The GNU C library provides routines for controlling the FPU, and other
-documentation about this.
-
-@xref{Floating-point precision}, regarding IEEE 754 conformance.
-
-@include bugs.texi
-
-@node Missing Features
-@section Missing Features
-
-This section lists features we know are missing from @command{g77},
-and which we want to add someday.
-(There is no priority implied in the ordering below.)
-
-@menu
-GNU Fortran language:
-* Better Source Model::
-* Fortran 90 Support::
-* Intrinsics in PARAMETER Statements::
-* Arbitrary Concatenation::
-* SELECT CASE on CHARACTER Type::
-* RECURSIVE Keyword::
-* Popular Non-standard Types::
-* Full Support for Compiler Types::
-* Array Bounds Expressions::
-* POINTER Statements::
-* Sensible Non-standard Constructs::
-* READONLY Keyword::
-* FLUSH Statement::
-* Expressions in FORMAT Statements::
-* Explicit Assembler Code::
-* Q Edit Descriptor::
-
-GNU Fortran dialects:
-* Old-style PARAMETER Statements::
-* TYPE and ACCEPT I/O Statements::
-* STRUCTURE UNION RECORD MAP::
-* OPEN CLOSE and INQUIRE Keywords::
-* ENCODE and DECODE::
-* AUTOMATIC Statement::
-* Suppressing Space Padding::
-* Fortran Preprocessor::
-* Bit Operations on Floating-point Data::
-* Really Ugly Character Assignments::
-
-New facilities:
-* POSIX Standard::
-* Floating-point Exception Handling::
-* Nonportable Conversions::
-* Large Automatic Arrays::
-* Support for Threads::
-* Increasing Precision/Range::
-* Enabling Debug Lines::
-
-Better diagnostics:
-* Better Warnings::
-* Gracefully Handle Sensible Bad Code::
-* Non-standard Conversions::
-* Non-standard Intrinsics::
-* Modifying DO Variable::
-* Better Pedantic Compilation::
-* Warn About Implicit Conversions::
-* Invalid Use of Hollerith Constant::
-* Dummy Array Without Dimensioning Dummy::
-* Invalid FORMAT Specifiers::
-* Ambiguous Dialects::
-* Unused Labels::
-* Informational Messages::
-
-Run-time facilities:
-* Uninitialized Variables at Run Time::
-* Portable Unformatted Files::
-* Better List-directed I/O::
-* Default to Console I/O::
-
-Debugging:
-* Labels Visible to Debugger::
-@end menu
-
-@node Better Source Model
-@subsection Better Source Model
-
-@command{g77} needs to provide, as the default source-line model,
-a ``pure visual'' mode, where
-the interpretation of a source program in this mode can be accurately
-determined by a user looking at a traditionally displayed rendition
-of the program (assuming the user knows whether the program is fixed
-or free form).
-
-The design should assume the user cannot tell tabs from spaces
-and cannot see trailing spaces on lines, but has canonical tab stops
-and, for fixed-form source, has the ability to always know exactly
-where column 72 is (since the Fortran standard itself requires
-this for fixed-form source).
-
-This would change the default treatment of fixed-form source
-to not treat lines with tabs as if they were infinitely long---instead,
-they would end at column 72 just as if the tabs were replaced
-by spaces in the canonical way.
-
-As part of this, provide common alternate models (Digital, @command{f2c},
-and so on) via command-line options.
-This includes allowing arbitrarily long
-lines for free-form source as well as fixed-form source and providing
-various limits and diagnostics as appropriate.
-
-@cindex sequence numbers
-@cindex columns 73 through 80
-Also, @command{g77} should offer, perhaps even default to, warnings
-when characters beyond the last valid column are anything other
-than spaces.
-This would mean code with ``sequence numbers'' in columns 73 through 80
-would be rejected, and there's a lot of that kind of code around,
-but one of the most frequent bugs encountered by new users is
-accidentally writing fixed-form source code into and beyond
-column 73.
-So, maybe the users of old code would be able to more easily handle
-having to specify, say, a @option{-Wno-col73to80} option.
-
-@node Fortran 90 Support
-@subsection Fortran 90 Support
-@cindex Fortran 90, support
-@cindex support, Fortran 90
-
-@command{g77} does not support many of the features that
-distinguish Fortran 90 (and, now, Fortran 95) from
-ANSI FORTRAN 77.
-
-Some Fortran 90 features are supported, because they
-make sense to offer even to die-hard users of F77.
-For example, many of them codify various ways F77 has
-been extended to meet users' needs during its tenure,
-so @command{g77} might as well offer them as the primary
-way to meet those same needs, even if it offers compatibility
-with one or more of the ways those needs were met
-by other F77 compilers in the industry.
-
-Still, many important F90 features are not supported,
-because no attempt has been made to research each and
-every feature and assess its viability in @command{g77}.
-In the meantime, users who need those features must
-use Fortran 90 compilers anyway, and the best approach
-to adding some F90 features to GNU Fortran might well be
-to fund a comprehensive project to create GNU Fortran 95.
-
-@node Intrinsics in PARAMETER Statements
-@subsection Intrinsics in @code{PARAMETER} Statements
-@cindex PARAMETER statement
-@cindex statements, PARAMETER
-
-@command{g77} doesn't allow intrinsics in @code{PARAMETER} statements.
-
-Related to this, @command{g77} doesn't allow non-integral
-exponentiation in @code{PARAMETER} statements, such as
-@samp{PARAMETER (R=2**.25)}.
-It is unlikely @command{g77} will ever support this feature,
-as doing it properly requires complete emulation of
-a target computer's floating-point facilities when
-building @command{g77} as a cross-compiler.
-But, if the @command{gcc} back end is enhanced to provide
-such a facility, @command{g77} will likely use that facility
-in implementing this feature soon afterwards.
-
-@node Arbitrary Concatenation
-@subsection Arbitrary Concatenation
-@cindex concatenation
-@cindex CHARACTER*(*)
-@cindex run-time, dynamic allocation
-
-@command{g77} doesn't support arbitrary operands for concatenation
-in contexts where run-time allocation is required.
-For example:
-
-@smallexample
-SUBROUTINE X(A)
-CHARACTER*(*) A
-CALL FOO(A // 'suffix')
-@end smallexample
-
-@node SELECT CASE on CHARACTER Type
-@subsection @code{SELECT CASE} on @code{CHARACTER} Type
-
-Character-type selector/cases for @code{SELECT CASE} currently
-are not supported.
-
-@node RECURSIVE Keyword
-@subsection @code{RECURSIVE} Keyword
-@cindex RECURSIVE keyword
-@cindex keywords, RECURSIVE
-@cindex recursion, lack of
-@cindex lack of recursion
-
-@command{g77} doesn't support the @code{RECURSIVE} keyword that
-F90 compilers do.
-Nor does it provide any means for compiling procedures
-designed to do recursion.
-
-All recursive code can be rewritten to not use recursion,
-but the result is not pretty.
-
-@node Increasing Precision/Range
-@subsection Increasing Precision/Range
-@cindex -r8
-@cindex -qrealsize=8
-@cindex -i8
-@cindex f2c
-@cindex increasing precision
-@cindex precision, increasing
-@cindex increasing range
-@cindex range, increasing
-@cindex Toolpack
-@cindex Netlib
-
-Some compilers, such as @command{f2c}, have an option (@option{-r8},
-@option{-qrealsize=8} or
-similar) that provides automatic treatment of @code{REAL}
-entities such that they have twice the storage size, and
-a corresponding increase in the range and precision, of what
-would normally be the @code{REAL(KIND=1)} (default @code{REAL}) type.
-(This affects @code{COMPLEX} the same way.)
-
-They also typically offer another option (@option{-i8}) to increase
-@code{INTEGER} entities so they are twice as large
-(with roughly twice as much range).
-
-(There are potential pitfalls in using these options.)
-
-@command{g77} does not yet offer any option that performs these
-kinds of transformations.
-Part of the problem is the lack of detailed specifications regarding
-exactly how these options affect the interpretation of constants,
-intrinsics, and so on.
-
-Until @command{g77} addresses this need, programmers could improve
-the portability of their code by modifying it to not require
-compile-time options to produce correct results.
-Some free tools are available which may help, specifically
-in Toolpack (which one would expect to be sound) and the @file{fortran}
-section of the Netlib repository.
-
-Use of preprocessors can provide a fairly portable means
-to work around the lack of widely portable methods in the Fortran
-language itself (though increasing acceptance of Fortran 90 would
-alleviate this problem).
-
-@node Popular Non-standard Types
-@subsection Popular Non-standard Types
-@cindex @code{INTEGER*2} support
-@cindex types, @code{INTEGER*2}
-@cindex @code{LOGICAL*1} support
-@cindex types, @code{LOGICAL*1}
-
-@command{g77} doesn't fully support @code{INTEGER*2}, @code{LOGICAL*1},
-and similar.
-In the meantime, version 0.5.18 provides rudimentary support
-for them.
-
-@node Full Support for Compiler Types
-@subsection Full Support for Compiler Types
-
-@cindex @code{REAL*16} support
-@cindex types, @code{REAL*16}
-@cindex @code{INTEGER*8} support
-@cindex types, @code{INTEGER*8}
-@command{g77} doesn't support @code{INTEGER}, @code{REAL}, and @code{COMPLEX} equivalents
-for @emph{all} applicable back-end-supported types (@code{char}, @code{short int},
-@code{int}, @code{long int}, @code{long long int}, and @code{long double}).
-This means providing intrinsic support, and maybe constant
-support (using F90 syntax) as well, and, for most
-machines will result in automatic support of @code{INTEGER*1},
-@code{INTEGER*2}, @code{INTEGER*8}, maybe even @code{REAL*16},
-and so on.
-
-@node Array Bounds Expressions
-@subsection Array Bounds Expressions
-@cindex array elements, in adjustable array bounds
-@cindex function references, in adjustable array bounds
-@cindex array bounds, adjustable
-@cindex @code{DIMENSION} statement
-@cindex statements, @code{DIMENSION}
-
-@command{g77} doesn't support more general expressions to dimension
-arrays, such as array element references, function
-references, etc.
-
-For example, @command{g77} currently does not accept the following:
-
-@smallexample
-SUBROUTINE X(M, N)
-INTEGER N(10), M(N(2), N(1))
-@end smallexample
-
-@node POINTER Statements
-@subsection POINTER Statements
-@cindex POINTER statement
-@cindex statements, POINTER
-@cindex Cray pointers
-
-@command{g77} doesn't support pointers or allocatable objects
-(other than automatic arrays).
-This set of features is
-probably considered just behind intrinsics
-in @code{PARAMETER} statements on the list of large,
-important things to add to @command{g77}.
-
-In the meantime, consider using the @code{INTEGER(KIND=7)}
-declaration to specify that a variable must be
-able to hold a pointer.
-This construct is not portable to other non-GNU compilers,
-but it is portable to all machines GNU Fortran supports
-when @command{g77} is used.
-
-@xref{Functions and Subroutines}, for information on
-@code{%VAL()}, @code{%REF()}, and @code{%DESCR()}
-constructs, which are useful for passing pointers to
-procedures written in languages other than Fortran.
-
-@node Sensible Non-standard Constructs
-@subsection Sensible Non-standard Constructs
-
-@command{g77} rejects things other compilers accept,
-like @samp{INTRINSIC SQRT,SQRT}.
-As time permits in the future, some of these things that are easy for
-humans to read and write and unlikely to be intended to mean something
-else will be accepted by @command{g77} (though @option{-fpedantic} should
-trigger warnings about such non-standard constructs).
-
-Until @command{g77} no longer gratuitously rejects sensible code,
-you might as well fix your code
-to be more standard-conforming and portable.
-
-The kind of case that is important to except from the
-recommendation to change your code is one where following
-good coding rules would force you to write non-standard
-code that nevertheless has a clear meaning.
-
-For example, when writing an @code{INCLUDE} file that
-defines a common block, it might be appropriate to
-include a @code{SAVE} statement for the common block
-(such as @samp{SAVE /CBLOCK/}), so that variables
-defined in the common block retain their values even
-when all procedures declaring the common block become
-inactive (return to their callers).
-
-However, putting @code{SAVE} statements in an @code{INCLUDE}
-file would prevent otherwise standard-conforming code
-from also specifying the @code{SAVE} statement, by itself,
-to indicate that all local variables and arrays are to
-have the @code{SAVE} attribute.
-
-For this reason, @command{g77} already has been changed to
-allow this combination, because although the general
-problem of gratuitously rejecting unambiguous and
-``safe'' constructs still exists in @command{g77}, this
-particular construct was deemed useful enough that
-it was worth fixing @command{g77} for just this case.
-
-So, while there is no need to change your code
-to avoid using this particular construct, there
-might be other, equally appropriate but non-standard
-constructs, that you shouldn't have to stop using
-just because @command{g77} (or any other compiler)
-gratuitously rejects it.
-
-Until the general problem is solved, if you have
-any such construct you believe is worthwhile
-using (e.g. not just an arbitrary, redundant
-specification of an attribute), please submit a
-bug report with an explanation, so we can consider
-fixing @command{g77} just for cases like yours.
-
-@node READONLY Keyword
-@subsection @code{READONLY} Keyword
-@cindex READONLY
-
-Support for @code{READONLY}, in @code{OPEN} statements,
-requires @code{libg2c} support,
-to make sure that @samp{CLOSE(@dots{},STATUS='DELETE')}
-does not delete a file opened on a unit
-with the @code{READONLY} keyword,
-and perhaps to trigger a fatal diagnostic
-if a @code{WRITE} or @code{PRINT}
-to such a unit is attempted.
-
-@emph{Note:} It is not sufficient for @command{g77} and @code{libg2c}
-(its version of @code{libf2c})
-to assume that @code{READONLY} does not need some kind of explicit support
-at run time,
-due to UNIX systems not (generally) needing it.
-@command{g77} is not just a UNIX-based compiler!
-
-Further, mounting of non-UNIX filesystems on UNIX systems
-(such as via NFS)
-might require proper @code{READONLY} support.
-
-@cindex SHARED
-(Similar issues might be involved with supporting the @code{SHARED}
-keyword.)
-
-@node FLUSH Statement
-@subsection @code{FLUSH} Statement
-
-@command{g77} could perhaps use a @code{FLUSH} statement that
-does what @samp{CALL FLUSH} does,
-but that supports @samp{*} as the unit designator (same unit as for
-@code{PRINT}) and accepts @code{ERR=} and/or @code{IOSTAT=}
-specifiers.
-
-@node Expressions in FORMAT Statements
-@subsection Expressions in @code{FORMAT} Statements
-@cindex FORMAT statement
-@cindex statements, FORMAT
-
-@command{g77} doesn't support @samp{FORMAT(I<J>)} and the like.
-Supporting this requires a significant redesign or replacement
-of @code{libg2c}.
-
-However, @command{g77} does support
-this construct when the expression is constant
-(as of version 0.5.22).
-For example:
-
-@smallexample
- PARAMETER (IWIDTH = 12)
-10 FORMAT (I<IWIDTH>)
-@end smallexample
-
-Otherwise, at least for output (@code{PRINT} and
-@code{WRITE}), Fortran code making use of this feature can
-be rewritten to avoid it by constructing the @code{FORMAT}
-string in a @code{CHARACTER} variable or array, then
-using that variable or array in place of the @code{FORMAT}
-statement label to do the original @code{PRINT} or @code{WRITE}.
-
-Many uses of this feature on input can be rewritten this way
-as well, but not all can.
-For example, this can be rewritten:
-
-@smallexample
- READ 20, I
-20 FORMAT (I<J>)
-@end smallexample
-
-However, this cannot, in general, be rewritten, especially
-when @code{ERR=} and @code{END=} constructs are employed:
-
-@smallexample
- READ 30, J, I
-30 FORMAT (I<J>)
-@end smallexample
-
-@node Explicit Assembler Code
-@subsection Explicit Assembler Code
-
-@command{g77} needs to provide some way, a la @command{gcc}, for @command{g77}
-code to specify explicit assembler code.
-
-@node Q Edit Descriptor
-@subsection Q Edit Descriptor
-@cindex FORMAT statement
-@cindex Q edit descriptor
-@cindex edit descriptor, Q
-
-The @code{Q} edit descriptor in @code{FORMAT}s isn't supported.
-(This is meant to get the number of characters remaining in an input record.)
-Supporting this requires a significant redesign or replacement
-of @code{libg2c}.
-
-A workaround might be using internal I/O or the stream-based intrinsics.
-@xref{FGetC Intrinsic (subroutine)}.
-
-@node Old-style PARAMETER Statements
-@subsection Old-style PARAMETER Statements
-@cindex PARAMETER statement
-@cindex statements, PARAMETER
-
-@command{g77} doesn't accept @samp{PARAMETER I=1}.
-Supporting this obsolete form of
-the @code{PARAMETER} statement would not be particularly hard, as most of the
-parsing code is already in place and working.
-
-Until time/money is
-spent implementing it, you might as well fix your code to use the
-standard form, @samp{PARAMETER (I=1)} (possibly needing
-@samp{INTEGER I} preceding the @code{PARAMETER} statement as well,
-otherwise, in the obsolete form of @code{PARAMETER}, the
-type of the variable is set from the type of the constant being
-assigned to it).
-
-@node TYPE and ACCEPT I/O Statements
-@subsection @code{TYPE} and @code{ACCEPT} I/O Statements
-@cindex TYPE statement
-@cindex statements, TYPE
-@cindex ACCEPT statement
-@cindex statements, ACCEPT
-
-@command{g77} doesn't support the I/O statements @code{TYPE} and
-@code{ACCEPT}.
-These are common extensions that should be easy to support,
-but also are fairly easy to work around in user code.
-
-Generally, any @samp{TYPE fmt,list} I/O statement can be replaced
-by @samp{PRINT fmt,list}.
-And, any @samp{ACCEPT fmt,list} statement can be
-replaced by @samp{READ fmt,list}.
-
-@node STRUCTURE UNION RECORD MAP
-@subsection @code{STRUCTURE}, @code{UNION}, @code{RECORD}, @code{MAP}
-@cindex STRUCTURE statement
-@cindex statements, STRUCTURE
-@cindex UNION statement
-@cindex statements, UNION
-@cindex RECORD statement
-@cindex statements, RECORD
-@cindex MAP statement
-@cindex statements, MAP
-
-@command{g77} doesn't support @code{STRUCTURE}, @code{UNION}, @code{RECORD},
-@code{MAP}.
-This set of extensions is quite a bit
-lower on the list of large, important things to add to @command{g77}, partly
-because it requires a great deal of work either upgrading or
-replacing @code{libg2c}.
-
-@node OPEN CLOSE and INQUIRE Keywords
-@subsection @code{OPEN}, @code{CLOSE}, and @code{INQUIRE} Keywords
-@cindex disposition of files
-@cindex OPEN statement
-@cindex statements, OPEN
-@cindex CLOSE statement
-@cindex statements, CLOSE
-@cindex INQUIRE statement
-@cindex statements, INQUIRE
-
-@command{g77} doesn't have support for keywords such as @code{DISP='DELETE'} in
-the @code{OPEN}, @code{CLOSE}, and @code{INQUIRE} statements.
-These extensions are easy to add to @command{g77} itself, but
-require much more work on @code{libg2c}.
-
-@cindex FORM='PRINT'
-@cindex ANS carriage control
-@cindex carriage control
-@pindex asa
-@pindex fpr
-@command{g77} doesn't support @code{FORM='PRINT'} or an equivalent to
-translate the traditional `carriage control' characters in column 1 of
-output to use backspaces, carriage returns and the like. However
-programs exist to translate them in output files (or standard output).
-These are typically called either @command{fpr} or @command{asa}. You can get
-a version of @command{asa} from
-@uref{ftp://sunsite.unc.edu/pub/Linux/devel/lang/fortran} for GNU
-systems which will probably build easily on other systems.
-Alternatively, @command{fpr} is in BSD distributions in various archive
-sites.
-
-@c (Can both programs can be used in a pipeline,
-@c with a named input file,
-@c and/or with a named output file???)
-
-@node ENCODE and DECODE
-@subsection @code{ENCODE} and @code{DECODE}
-@cindex ENCODE statement
-@cindex statements, ENCODE
-@cindex DECODE statement
-@cindex statements, DECODE
-
-@command{g77} doesn't support @code{ENCODE} or @code{DECODE}.
-
-These statements are best replaced by READ and WRITE statements
-involving internal files (CHARACTER variables and arrays).
-
-For example, replace a code fragment like
-
-@smallexample
- INTEGER*1 LINE(80)
-@dots{}
- DECODE (80, 9000, LINE) A, B, C
-@dots{}
-9000 FORMAT (1X, 3(F10.5))
-@end smallexample
-
-@noindent
-with:
-
-@smallexample
- CHARACTER*80 LINE
-@dots{}
- READ (UNIT=LINE, FMT=9000) A, B, C
-@dots{}
-9000 FORMAT (1X, 3(F10.5))
-@end smallexample
-
-Similarly, replace a code fragment like
-
-@smallexample
- INTEGER*1 LINE(80)
-@dots{}
- ENCODE (80, 9000, LINE) A, B, C
-@dots{}
-9000 FORMAT (1X, 'OUTPUT IS ', 3(F10.5))
-@end smallexample
-
-@noindent
-with:
-
-@smallexample
- CHARACTER*80 LINE
-@dots{}
- WRITE (UNIT=LINE, FMT=9000) A, B, C
-@dots{}
-9000 FORMAT (1X, 'OUTPUT IS ', 3(F10.5))
-@end smallexample
-
-It is entirely possible that @code{ENCODE} and @code{DECODE} will
-be supported by a future version of @command{g77}.
-
-@node AUTOMATIC Statement
-@subsection @code{AUTOMATIC} Statement
-@cindex @code{AUTOMATIC} statement
-@cindex statements, @code{AUTOMATIC}
-@cindex automatic variables
-@cindex variables, automatic
-
-@command{g77} doesn't support the @code{AUTOMATIC} statement that
-@command{f2c} does.
-
-@code{AUTOMATIC} would identify a variable or array
-as not being @code{SAVE}'d, which is normally the default,
-but which would be especially useful for code that, @emph{generally},
-needed to be compiled with the @option{-fno-automatic} option.
-
-@code{AUTOMATIC} also would serve as a hint to the compiler that placing
-the variable or array---even a very large array--on the stack is acceptable.
-
-@code{AUTOMATIC} would not, by itself, designate the containing procedure
-as recursive.
-
-@code{AUTOMATIC} should work syntactically like @code{SAVE},
-in that @code{AUTOMATIC} with no variables listed should apply to
-all pertinent variables and arrays
-(which would not include common blocks or their members).
-
-Variables and arrays denoted as @code{AUTOMATIC}
-would not be permitted to be initialized via @code{DATA}
-or other specification of any initial values,
-requiring explicit initialization,
-such as via assignment statements.
-
-@cindex UNSAVE
-@cindex STATIC
-Perhaps @code{UNSAVE} and @code{STATIC},
-as strict semantic opposites to @code{SAVE} and @code{AUTOMATIC},
-should be provided as well.
-
-@node Suppressing Space Padding
-@subsection Suppressing Space Padding of Source Lines
-
-@command{g77} should offer VXT-Fortran-style suppression of virtual
-spaces at the end of a source line
-if an appropriate command-line option is specified.
-
-This affects cases where
-a character constant is continued onto the next line in a fixed-form
-source file, as in the following example:
-
-@smallexample
-10 PRINT *,'HOW MANY
- 1 SPACES?'
-@end smallexample
-
-@noindent
-@command{g77}, and many other compilers, virtually extend
-the continued line through column 72 with spaces that become part
-of the character constant, but Digital Fortran normally didn't,
-leaving only one space between @samp{MANY} and @samp{SPACES?}
-in the output of the above statement.
-
-Fairly recently, at least one version of Digital Fortran
-was enhanced to provide the other behavior when a
-command-line option is specified, apparently due to demand
-from readers of the USENET group @file{comp.lang.fortran}
-to offer conformance to this widespread practice in the
-industry.
-@command{g77} should return the favor by offering conformance
-to Digital's approach to handling the above example.
-
-@node Fortran Preprocessor
-@subsection Fortran Preprocessor
-
-@command{g77} should offer a preprocessor designed specifically
-for Fortran to replace @samp{cpp -traditional}.
-There are several out there worth evaluating, at least.
-
-Such a preprocessor would recognize Hollerith constants,
-properly parse comments and character constants, and so on.
-It might also recognize, process, and thus preprocess
-files included via the @code{INCLUDE} directive.
-
-@node Bit Operations on Floating-point Data
-@subsection Bit Operations on Floating-point Data
-@cindex @code{And} intrinsic
-@cindex intrinsics, @code{And}
-@cindex @code{Or} intrinsic
-@cindex intrinsics, @code{Or}
-@cindex @code{Shift} intrinsic
-@cindex intrinsics, @code{Shift}
-
-@command{g77} does not allow @code{REAL} and other non-integral types for
-arguments to intrinsics like @code{And}, @code{Or}, and @code{Shift}.
-
-For example, this program is rejected by @command{g77}, because
-the intrinsic @code{Iand} does not accept @code{REAL} arguments:
-
-@smallexample
-DATA A/7.54/, B/9.112/
-PRINT *, IAND(A, B)
-END
-@end smallexample
-
-@node Really Ugly Character Assignments
-@subsection Really Ugly Character Assignments
-
-An option such as @option{-fugly-char} should be provided
-to allow
-
-@smallexample
-REAL*8 A1
-DATA A1 / '12345678' /
-@end smallexample
-
-and:
-
-@smallexample
-REAL*8 A1
-A1 = 'ABCDEFGH'
-@end smallexample
-
-@node POSIX Standard
-@subsection @code{POSIX} Standard
-
-@command{g77} should support the POSIX standard for Fortran.
-
-@node Floating-point Exception Handling
-@subsection Floating-point Exception Handling
-@cindex floating-point, exceptions
-@cindex exceptions, floating-point
-@cindex FPE handling
-@cindex NaN values
-
-The @command{gcc} backend and, consequently, @command{g77}, currently provides no
-general control over whether or not floating-point exceptions are trapped or
-ignored.
-(Ignoring them typically results in NaN values being
-propagated in systems that conform to IEEE 754.)
-The behavior is normally inherited from the system-dependent startup
-code, though some targets, such as the Alpha, have code generation
-options which change the behavior.
-
-Most systems provide some C-callable mechanism to change this; this can
-be invoked at startup using @command{gcc}'s @code{constructor} attribute.
-For example, just compiling and linking the following C code with your
-program will turn on exception trapping for the ``common'' exceptions
-on a GNU system using glibc 2.2 or newer:
-
-@smallexample
-#define _GNU_SOURCE 1
-#include <fenv.h>
-static void __attribute__ ((constructor))
-trapfpe ()
-@{
- /* Enable some exceptions. At startup all exceptions are masked. */
-
- feenableexcept (FE_INVALID|FE_DIVBYZERO|FE_OVERFLOW);
-@}
-@end smallexample
-
-A convenient trick is to compile this something like:
-@smallexample
-gcc -o libtrapfpe.a trapfpe.c
-@end smallexample
-and then use it by adding @option{-trapfpe} to the @command{g77} command line
-when linking.
-
-@node Nonportable Conversions
-@subsection Nonportable Conversions
-@cindex nonportable conversions
-@cindex conversions, nonportable
-
-@command{g77} doesn't accept some particularly nonportable,
-silent data-type conversions such as @code{LOGICAL}
-to @code{REAL} (as in @samp{A=.FALSE.}, where @samp{A}
-is type @code{REAL}), that other compilers might
-quietly accept.
-
-Some of these conversions are accepted by @command{g77}
-when the @option{-fugly-logint} option is specified.
-Perhaps it should accept more or all of them.
-
-@node Large Automatic Arrays
-@subsection Large Automatic Arrays
-@cindex automatic arrays
-@cindex arrays, automatic
-
-Currently, automatic arrays always are allocated on the stack.
-For situations where the stack cannot be made large enough,
-@command{g77} should offer a compiler option that specifies
-allocation of automatic arrays in heap storage.
-
-@node Support for Threads
-@subsection Support for Threads
-@cindex threads
-@cindex parallel processing
-
-Neither the code produced by @command{g77} nor the @code{libg2c} library
-are thread-safe, nor does @command{g77} have support for parallel processing
-(other than the instruction-level parallelism available on some
-processors).
-A package such as PVM might help here.
-
-@node Enabling Debug Lines
-@subsection Enabling Debug Lines
-@cindex debug line
-@cindex comment line, debug
-
-An option such as @option{-fdebug-lines} should be provided
-to turn fixed-form lines beginning with @samp{D}
-to be treated as if they began with a space,
-instead of as if they began with a @samp{C}
-(as comment lines).
-
-@node Better Warnings
-@subsection Better Warnings
-
-Because of how @command{g77} generates code via the back end,
-it doesn't always provide warnings the user wants.
-Consider:
-
-@smallexample
-PROGRAM X
-PRINT *, A
-END
-@end smallexample
-
-Currently, the above is not flagged as a case of
-using an uninitialized variable,
-because @command{g77} generates a run-time library call that looks,
-to the GBE, like it might actually @emph{modify} @samp{A} at run time.
-(And, in fact, depending on the previous run-time library call,
-it would!)
-
-Fixing this requires one of the following:
-
-@itemize @bullet
-@item
-Switch to new library, @code{libg77}, that provides
-a more ``clean'' interface,
-vis-a-vis input, output, and modified arguments,
-so the GBE can tell what's going on.
-
-This would provide a pretty big performance improvement,
-at least theoretically, and, ultimately, in practice,
-for some types of code.
-
-@item
-Have @command{g77} pass a pointer to a temporary
-containing a copy of @samp{A},
-instead of to @samp{A} itself.
-The GBE would then complain about the copy operation
-involving a potentially uninitialized variable.
-
-This might also provide a performance boost for some code,
-because @samp{A} might then end up living in a register,
-which could help with inner loops.
-
-@item
-Have @command{g77} use a GBE construct similar to @code{ADDR_EXPR}
-but with extra information on the fact that the
-item pointed to won't be modified
-(a la @code{const} in C).
-
-Probably the best solution for now, but not quite trivial
-to implement in the general case.
-@end itemize
-
-@node Gracefully Handle Sensible Bad Code
-@subsection Gracefully Handle Sensible Bad Code
-
-@command{g77} generally should continue processing for
-warnings and recoverable (user) errors whenever possible---that
-is, it shouldn't gratuitously make bad or useless code.
-
-For example:
-
-@smallexample
-INTRINSIC ZABS
-CALL FOO(ZABS)
-END
-@end smallexample
-
-@noindent
-When compiling the above with @option{-ff2c-intrinsics-disable},
-@command{g77} should indeed complain about passing @code{ZABS},
-but it still should compile, instead of rejecting
-the entire @code{CALL} statement.
-(Some of this is related to improving
-the compiler internals to improve how statements are analyzed.)
-
-@node Non-standard Conversions
-@subsection Non-standard Conversions
-
-@option{-Wconversion} and related should flag places where non-standard
-conversions are found.
-Perhaps much of this would be part of @option{-Wugly*}.
-
-@node Non-standard Intrinsics
-@subsection Non-standard Intrinsics
-
-@command{g77} needs a new option, like @option{-Wintrinsics}, to warn about use of
-non-standard intrinsics without explicit @code{INTRINSIC} statements for them.
-This would help find code that might fail silently when ported to another
-compiler.
-
-@node Modifying DO Variable
-@subsection Modifying @code{DO} Variable
-
-@command{g77} should warn about modifying @code{DO} variables
-via @code{EQUIVALENCE}.
-(The internal information gathered to produce this warning
-might also be useful in setting the
-internal ``doiter'' flag for a variable or even array
-reference within a loop, since that might produce faster code someday.)
-
-For example, this code is invalid, so @command{g77} should warn about
-the invalid assignment to @samp{NOTHER}:
-
-@smallexample
-EQUIVALENCE (I, NOTHER)
-DO I = 1, 100
- IF (I.EQ. 10) NOTHER = 20
-END DO
-@end smallexample
-
-@node Better Pedantic Compilation
-@subsection Better Pedantic Compilation
-
-@command{g77} needs to support @option{-fpedantic} more thoroughly,
-and use it only to generate
-warnings instead of rejecting constructs outright.
-Have it warn:
-if a variable that dimensions an array is not a dummy or placed
-explicitly in @code{COMMON} (F77 does not allow it to be
-placed in @code{COMMON} via @code{EQUIVALENCE}); if specification statements
-follow statement-function-definition statements; about all sorts of
-syntactic extensions.
-
-@node Warn About Implicit Conversions
-@subsection Warn About Implicit Conversions
-
-@command{g77} needs a @option{-Wpromotions} option to warn if source code appears
-to expect automatic, silent, and
-somewhat dangerous compiler-assisted conversion of @code{REAL(KIND=1)}
-constants to @code{REAL(KIND=2)} based on context.
-
-For example, it would warn about cases like this:
-
-@smallexample
-DOUBLE PRECISION FOO
-PARAMETER (TZPHI = 9.435784839284958)
-FOO = TZPHI * 3D0
-@end smallexample
-
-@node Invalid Use of Hollerith Constant
-@subsection Invalid Use of Hollerith Constant
-
-@command{g77} should disallow statements like @samp{RETURN 2HAB},
-which are invalid in both source forms
-(unlike @samp{RETURN (2HAB)},
-which probably still makes no sense but at least can
-be reliably parsed).
-Fixed-form processing rejects it, but not free-form, except
-in a way that is a bit difficult to understand.
-
-@node Dummy Array Without Dimensioning Dummy
-@subsection Dummy Array Without Dimensioning Dummy
-
-@command{g77} should complain when a list of dummy arguments containing an
-adjustable dummy array does
-not also contain every variable listed in the dimension list of the
-adjustable array.
-
-Currently, @command{g77} does complain about a variable that
-dimensions an array but doesn't appear in any dummy list or @code{COMMON}
-area, but this needs to be extended to catch cases where it doesn't appear in
-every dummy list that also lists any arrays it dimensions.
-
-For example, @command{g77} should warn about the entry point @samp{ALT}
-below, since it includes @samp{ARRAY} but not @samp{ISIZE} in its
-list of arguments:
-
-@smallexample
-SUBROUTINE PRIMARY(ARRAY, ISIZE)
-REAL ARRAY(ISIZE)
-ENTRY ALT(ARRAY)
-@end smallexample
-
-@node Invalid FORMAT Specifiers
-@subsection Invalid FORMAT Specifiers
-
-@command{g77} should check @code{FORMAT} specifiers for validity
-as it does @code{FORMAT} statements.
-
-For example, a diagnostic would be produced for:
-
-@smallexample
-PRINT 'HI THERE!' !User meant PRINT *, 'HI THERE!'
-@end smallexample
-
-@node Ambiguous Dialects
-@subsection Ambiguous Dialects
-
-@command{g77} needs a set of options such as @option{-Wugly*}, @option{-Wautomatic},
-@option{-Wvxt}, @option{-Wf90}, and so on.
-These would warn about places in the user's source where ambiguities
-are found, helpful in resolving ambiguities in the program's
-dialect or dialects.
-
-@node Unused Labels
-@subsection Unused Labels
-
-@command{g77} should warn about unused labels when @option{-Wunused} is in effect.
-
-@node Informational Messages
-@subsection Informational Messages
-
-@command{g77} needs an option to suppress information messages (notes).
-@option{-w} does this but also suppresses warnings.
-The default should be to suppress info messages.
-
-Perhaps info messages should simply be eliminated.
-
-@node Uninitialized Variables at Run Time
-@subsection Uninitialized Variables at Run Time
-
-@command{g77} needs an option to initialize everything (not otherwise
-explicitly initialized) to ``weird''
-(machine-dependent) values, e.g. NaNs, bad (non-@code{NULL}) pointers, and
-largest-magnitude integers, would help track down references to
-some kinds of uninitialized variables at run time.
-
-Note that use of the options @samp{-O -Wuninitialized} can catch
-many such bugs at compile time.
-
-@node Portable Unformatted Files
-@subsection Portable Unformatted Files
-
-@cindex unformatted files
-@cindex file formats
-@cindex binary data
-@cindex byte ordering
-@command{g77} has no facility for exchanging unformatted files with systems
-using different number formats---even differing only in endianness (byte
-order)---or written by other compilers. Some compilers provide
-facilities at least for doing byte-swapping during unformatted I/O.
-
-It is unrealistic to expect to cope with exchanging unformatted files
-with arbitrary other compiler runtimes, but the @command{g77} runtime
-should at least be able to read files written by @command{g77} on systems
-with different number formats, particularly if they differ only in byte
-order.
-
-In case you do need to write a program to translate to or from
-@command{g77} (@code{libf2c}) unformatted files, they are written as
-follows:
-@table @asis
-@item Sequential
-Unformatted sequential records consist of
-@enumerate
-@item
-A number giving the length of the record contents;
-@item
-the length of record contents again (for backspace).
-@end enumerate
-
-The record length is of C type
-@code{long}; this means that it is 8 bytes on 64-bit systems such as
-Alpha GNU/Linux and 4 bytes on other systems, such as x86 GNU/Linux.
-Consequently such files cannot be exchanged between 64-bit and 32-bit
-systems, even with the same basic number format.
-@item Direct access
-Unformatted direct access files form a byte stream of length
-@var{records}*@var{recl} bytes, where @var{records} is the maximum
-record number (@code{REC=@var{records}}) written and @var{recl} is the
-record length in bytes specified in the @code{OPEN} statement
-(@code{RECL=@var{recl}}). Data appear in the records as determined by
-the relevant @code{WRITE} statement. Dummy records with arbitrary
-contents appear in the file in place of records which haven't been
-written.
-@end table
-
-Thus for exchanging a sequential or direct access unformatted file
-between big- and little-endian 32-bit systems using IEEE 754 floating
-point it would be sufficient to reverse the bytes in consecutive words
-in the file if, and @emph{only} if, only @code{REAL*4}, @code{COMPLEX},
-@code{INTEGER*4} and/or @code{LOGICAL*4} data have been written to it by
-@command{g77}.
-
-If necessary, it is possible to do byte-oriented i/o with @command{g77}'s
-@code{FGETC} and @code{FPUTC} intrinsics. Byte-swapping can be done in
-Fortran by equivalencing larger sized variables to an @code{INTEGER*1}
-array or a set of scalars.
-
-@cindex HDF
-@cindex PDB
-If you need to exchange binary data between arbitrary system and
-compiler variations, we recommend using a portable binary format with
-Fortran bindings, such as NCSA's HDF (@uref{http://hdf.ncsa.uiuc.edu/})
-or PACT's PDB@footnote{No, not @emph{that} one.}
-(@uref{http://www.llnl.gov/def_sci/pact/pact_homepage.html}). (Unlike,
-say, CDF or XDR, HDF-like systems write in the native number formats and
-only incur overhead when they are read on a system with a different
-format.) A future @command{g77} runtime library should use such
-techniques.
-
-@node Better List-directed I/O
-@subsection Better List-directed I/O
-
-Values output using list-directed I/O
-(@samp{PRINT *, R, D})
-should be written with a field width, precision, and so on
-appropriate for the type (precision) of each value.
-
-(Currently, no distinction is made between single-precision
-and double-precision values
-by @code{libf2c}.)
-
-It is likely this item will require the @code{libg77} project
-to be undertaken.
-
-In the meantime, use of formatted I/O is recommended.
-While it might be of little consolation,
-@command{g77} does support @samp{FORMAT(F<WIDTH>.4)}, for example,
-as long as @samp{WIDTH} is defined as a named constant
-(via @code{PARAMETER}).
-That at least allows some compile-time specification
-of the precision of a data type,
-perhaps controlled by preprocessing directives.
-
-@node Default to Console I/O
-@subsection Default to Console I/O
-
-The default I/O units,
-specified by @samp{READ @var{fmt}},
-@samp{READ (UNIT=*)},
-@samp{WRITE (UNIT=*)}, and
-@samp{PRINT @var{fmt}},
-should not be units 5 (input) and 6 (output),
-but, rather, unit numbers not normally available
-for use in statements such as @code{OPEN} and @code{CLOSE}.
-
-Changing this would allow a program to connect units 5 and 6
-to files via @code{OPEN},
-but still use @samp{READ (UNIT=*)} and @samp{PRINT}
-to do I/O to the ``console''.
-
-This change probably requires the @code{libg77} project.
-
-@node Labels Visible to Debugger
-@subsection Labels Visible to Debugger
-
-@command{g77} should output debugging information for statements labels,
-for use by debuggers that know how to support them.
-Same with weirder things like construct names.
-It is not yet known if any debug formats or debuggers support these.
-
-@node Disappointments
-@section Disappointments and Misunderstandings
-
-These problems are perhaps regrettable, but we don't know any practical
-way around them for now.
-
-@menu
-* Mangling of Names:: @samp{SUBROUTINE FOO} is given
- external name @samp{foo_}.
-* Multiple Definitions of External Names:: No doing both @samp{COMMON /FOO/}
- and @samp{SUBROUTINE FOO}.
-* Limitation on Implicit Declarations:: No @samp{IMPLICIT CHARACTER*(*)}.
-@end menu
-
-@node Mangling of Names
-@subsection Mangling of Names in Source Code
-@cindex naming issues
-@cindex external names
-@cindex common blocks
-@cindex name space
-@cindex underscore
-
-The current external-interface design, which includes naming of
-external procedures, COMMON blocks, and the library interface,
-has various usability problems, including things like adding
-underscores where not really necessary (and preventing easier
-inter-language operability) and yet not providing complete
-namespace freedom for user C code linked with Fortran apps (due
-to the naming of functions in the library, among other things).
-
-Project GNU should at least get all this ``right'' for systems
-it fully controls, such as the Hurd, and provide defaults and
-options for compatibility with existing systems and interoperability
-with popular existing compilers.
-
-@node Multiple Definitions of External Names
-@subsection Multiple Definitions of External Names
-@cindex block data
-@cindex BLOCK DATA statement
-@cindex statements, BLOCK DATA
-@cindex @code{COMMON} statement
-@cindex statements, @code{COMMON}
-@cindex naming conflicts
-
-@command{g77} doesn't allow a common block and an external procedure or
-@code{BLOCK DATA} to have the same name.
-Some systems allow this, but @command{g77} does not,
-to be compatible with @command{f2c}.
-
-@command{g77} could special-case the way it handles
-@code{BLOCK DATA}, since it is not compatible with @command{f2c} in this
-particular area (necessarily, since @command{g77} offers an
-important feature here), but
-it is likely that such special-casing would be very annoying to people
-with programs that use @samp{EXTERNAL FOO}, with no other mention of
-@samp{FOO} in the same program unit, to refer to external procedures, since
-the result would be that @command{g77} would treat these references as requests to
-force-load BLOCK DATA program units.
-
-In that case, if @command{g77} modified
-names of @code{BLOCK DATA} so they could have the same names as
-@code{COMMON}, users
-would find that their programs wouldn't link because the @samp{FOO} procedure
-didn't have its name translated the same way.
-
-(Strictly speaking,
-@command{g77} could emit a null-but-externally-satisfying definition of
-@samp{FOO} with its name transformed as if it had been a
-@code{BLOCK DATA}, but that probably invites more trouble than it's
-worth.)
-
-@node Limitation on Implicit Declarations
-@subsection Limitation on Implicit Declarations
-@cindex IMPLICIT CHARACTER*(*) statement
-@cindex statements, IMPLICIT CHARACTER*(*)
-
-@command{g77} disallows @code{IMPLICIT CHARACTER*(*)}.
-This is not standard-conforming.
-
-@node Non-bugs
-@section Certain Changes We Don't Want to Make
-
-This section lists changes that people frequently request, but which
-we do not make because we think GNU Fortran is better without them.
-
-@menu
-* Backslash in Constants:: Why @samp{'\\'} is a constant that
- is one, not two, characters long.
-* Initializing Before Specifying:: Why @samp{DATA VAR/1/} can't precede
- @samp{COMMON VAR}.
-* Context-Sensitive Intrinsicness:: Why @samp{CALL SQRT} won't work.
-* Context-Sensitive Constants:: Why @samp{9.435784839284958} is a
- single-precision constant,
- and might be interpreted as
- @samp{9.435785} or similar.
-* Equivalence Versus Equality:: Why @samp{.TRUE. .EQ. .TRUE.} won't work.
-* Order of Side Effects:: Why @samp{J = IFUNC() - IFUNC()} might
- not behave as expected.
-@end menu
-
-@node Backslash in Constants
-@subsection Backslash in Constants
-@cindex backslash
-@cindex @command{f77} support
-@cindex support, @command{f77}
-
-In the opinion of many experienced Fortran users,
-@option{-fno-backslash} should be the default, not @option{-fbackslash},
-as currently set by @command{g77}.
-
-First of all, you can always specify
-@option{-fno-backslash} to turn off this processing.
-
-Despite not being within the spirit (though apparently within the
-letter) of the ANSI FORTRAN 77 standard, @command{g77} defaults to
-@option{-fbackslash} because that is what most UNIX @command{f77} commands
-default to, and apparently lots of code depends on this feature.
-
-This is a particularly troubling issue.
-The use of a C construct in the midst of Fortran code
-is bad enough, worse when it makes existing Fortran
-programs stop working (as happens when programs written
-for non-UNIX systems are ported to UNIX systems with
-compilers that provide the @option{-fbackslash} feature
-as the default---sometimes with no option to turn it off).
-
-The author of GNU Fortran wished, for reasons of linguistic
-purity, to make @option{-fno-backslash} the default for GNU
-Fortran and thus require users of UNIX @command{f77} and @command{f2c}
-to specify @option{-fbackslash} to get the UNIX behavior.
-
-However, the realization that @command{g77} is intended as
-a replacement for @emph{UNIX} @command{f77}, caused the author
-to choose to make @command{g77} as compatible with
-@command{f77} as feasible, which meant making @option{-fbackslash}
-the default.
-
-The primary focus on compatibility is at the source-code
-level, and the question became ``What will users expect
-a replacement for @command{f77} to do, by default?''
-Although at least one UNIX @command{f77} does not provide
-@option{-fbackslash} as a default, it appears that
-the majority of them do, which suggests that
-the majority of code that is compiled by UNIX @command{f77}
-compilers expects @option{-fbackslash} to be the default.
-
-It is probably the case that more code exists
-that would @emph{not} work with @option{-fbackslash}
-in force than code that requires it be in force.
-
-However, most of @emph{that} code is not being compiled
-with @command{f77},
-and when it is, new build procedures (shell scripts,
-makefiles, and so on) must be set up anyway so that
-they work under UNIX.
-That makes a much more natural and safe opportunity for
-non-UNIX users to adapt their build procedures for
-@command{g77}'s default of @option{-fbackslash} than would
-exist for the majority of UNIX @command{f77} users who
-would have to modify existing, working build procedures
-to explicitly specify @option{-fbackslash} if that was
-not the default.
-
-One suggestion has been to configure the default for
-@option{-fbackslash} (and perhaps other options as well)
-based on the configuration of @command{g77}.
-
-This is technically quite straightforward, but will be avoided
-even in cases where not configuring defaults to be
-dependent on a particular configuration greatly inconveniences
-some users of legacy code.
-
-Many users appreciate the GNU compilers because they provide an
-environment that is uniform across machines.
-These users would be
-inconvenienced if the compiler treated things like the
-format of the source code differently on certain machines.
-
-Occasionally users write programs intended only for a particular machine
-type.
-On these occasions, the users would benefit if the GNU Fortran compiler
-were to support by default the same dialect as the other compilers on
-that machine.
-But such applications are rare.
-And users writing a
-program to run on more than one type of machine cannot possibly benefit
-from this kind of compatibility.
-(This is consistent with the design goals for @command{gcc}.
-To change them for @command{g77}, you must first change them
-for @command{gcc}.
-Do not ask the maintainers of @command{g77} to do this for you,
-or to disassociate @command{g77} from the widely understood, if
-not widely agreed-upon, goals for GNU compilers in general.)
-
-This is why GNU Fortran does and will treat backslashes in the same
-fashion on all types of machines (by default).
-@xref{Direction of Language Development}, for more information on
-this overall philosophy guiding the development of the GNU Fortran
-language.
-
-Of course, users strongly concerned about portability should indicate
-explicitly in their build procedures which options are expected
-by their source code, or write source code that has as few such
-expectations as possible.
-
-For example, avoid writing code that depends on backslash (@samp{\})
-being interpreted either way in particular, such as by
-starting a program unit with:
-
-@smallexample
-CHARACTER BACKSL
-PARAMETER (BACKSL = '\\')
-@end smallexample
-
-@noindent
-Then, use concatenation of @samp{BACKSL} anyplace a backslash
-is desired.
-In this way, users can write programs which have the same meaning
-in many Fortran dialects.
-
-(However, this technique does not work for Hollerith constants---which
-is just as well, since the only generally portable uses for Hollerith
-constants are in places where character constants can and should
-be used instead, for readability.)
-
-@node Initializing Before Specifying
-@subsection Initializing Before Specifying
-@cindex initialization, statement placement
-@cindex placing initialization statements
-
-@command{g77} does not allow @samp{DATA VAR/1/} to appear in the
-source code before @samp{COMMON VAR},
-@samp{DIMENSION VAR(10)}, @samp{INTEGER VAR}, and so on.
-In general, @command{g77} requires initialization of a variable
-or array to be specified @emph{after} all other specifications
-of attributes (type, size, placement, and so on) of that variable
-or array are specified (though @emph{confirmation} of data type is
-permitted).
-
-It is @emph{possible} @command{g77} will someday allow all of this,
-even though it is not allowed by the FORTRAN 77 standard.
-
-Then again, maybe it is better to have
-@command{g77} always require placement of @code{DATA}
-so that it can possibly immediately write constants
-to the output file, thus saving time and space.
-
-That is, @samp{DATA A/1000000*1/} should perhaps always
-be immediately writable to canonical assembler, unless it's already known
-to be in a @code{COMMON} area following as-yet-uninitialized stuff,
-and to do this it cannot be followed by @samp{COMMON A}.
-
-@node Context-Sensitive Intrinsicness
-@subsection Context-Sensitive Intrinsicness
-@cindex intrinsics, context-sensitive
-@cindex context-sensitive intrinsics
-
-@command{g77} treats procedure references to @emph{possible} intrinsic
-names as always enabling their intrinsic nature, regardless of
-whether the @emph{form} of the reference is valid for that
-intrinsic.
-
-For example, @samp{CALL SQRT} is interpreted by @command{g77} as
-an invalid reference to the @code{SQRT} intrinsic function,
-because the reference is a subroutine invocation.
-
-First, @command{g77} recognizes the statement @samp{CALL SQRT}
-as a reference to a @emph{procedure} named @samp{SQRT}, not
-to a @emph{variable} with that name (as it would for a statement
-such as @samp{V = SQRT}).
-
-Next, @command{g77} establishes that, in the program unit being compiled,
-@code{SQRT} is an intrinsic---not a subroutine that
-happens to have the same name as an intrinsic (as would be
-the case if, for example, @samp{EXTERNAL SQRT} was present).
-
-Finally, @command{g77} recognizes that the @emph{form} of the
-reference is invalid for that particular intrinsic.
-That is, it recognizes that it is invalid for an intrinsic
-@emph{function}, such as @code{SQRT}, to be invoked as
-a @emph{subroutine}.
-
-At that point, @command{g77} issues a diagnostic.
-
-Some users claim that it is ``obvious'' that @samp{CALL SQRT}
-references an external subroutine of their own, not an
-intrinsic function.
-
-However, @command{g77} knows about intrinsic
-subroutines, not just functions, and is able to support both having
-the same names, for example.
-
-As a result of this, @command{g77} rejects calls
-to intrinsics that are not subroutines, and function invocations
-of intrinsics that are not functions, just as it (and most compilers)
-rejects invocations of intrinsics with the wrong number (or types)
-of arguments.
-
-So, use the @samp{EXTERNAL SQRT} statement in a program unit that calls
-a user-written subroutine named @samp{SQRT}.
-
-@node Context-Sensitive Constants
-@subsection Context-Sensitive Constants
-@cindex constants, context-sensitive
-@cindex context-sensitive constants
-
-@command{g77} does not use context to determine the types of
-constants or named constants (@code{PARAMETER}), except
-for (non-standard) typeless constants such as @samp{'123'O}.
-
-For example, consider the following statement:
-
-@smallexample
-PRINT *, 9.435784839284958 * 2D0
-@end smallexample
-
-@noindent
-@command{g77} will interpret the (truncated) constant
-@samp{9.435784839284958} as a @code{REAL(KIND=1)}, not @code{REAL(KIND=2)},
-constant, because the suffix @code{D0} is not specified.
-
-As a result, the output of the above statement when
-compiled by @command{g77} will appear to have ``less precision''
-than when compiled by other compilers.
-
-In these and other cases, some compilers detect the
-fact that a single-precision constant is used in
-a double-precision context and therefore interpret the
-single-precision constant as if it was @emph{explicitly}
-specified as a double-precision constant.
-(This has the effect of appending @emph{decimal}, not
-@emph{binary}, zeros to the fractional part of the
-number---producing different computational results.)
-
-The reason this misfeature is dangerous is that a slight,
-apparently innocuous change to the source code can change
-the computational results.
-Consider:
-
-@smallexample
-REAL ALMOST, CLOSE
-DOUBLE PRECISION FIVE
-PARAMETER (ALMOST = 5.000000000001)
-FIVE = 5
-CLOSE = 5.000000000001
-PRINT *, 5.000000000001 - FIVE
-PRINT *, ALMOST - FIVE
-PRINT *, CLOSE - FIVE
-END
-@end smallexample
-
-@noindent
-Running the above program should
-result in the same value being
-printed three times.
-With @command{g77} as the compiler,
-it does.
-
-However, compiled by many other compilers,
-running the above program would print
-two or three distinct values, because
-in two or three of the statements, the
-constant @samp{5.000000000001}, which
-on most systems is exactly equal to @samp{5.}
-when interpreted as a single-precision constant,
-is instead interpreted as a double-precision
-constant, preserving the represented
-precision.
-However, this ``clever'' promotion of
-type does not extend to variables or,
-in some compilers, to named constants.
-
-Since programmers often are encouraged to replace manifest
-constants or permanently-assigned variables with named
-constants (@code{PARAMETER} in Fortran), and might need
-to replace some constants with variables having the same
-values for pertinent portions of code,
-it is important that compilers treat code so modified in the
-same way so that the results of such programs are the same.
-@command{g77} helps in this regard by treating constants just
-the same as variables in terms of determining their types
-in a context-independent way.
-
-Still, there is a lot of existing Fortran code that has
-been written to depend on the way other compilers freely
-interpret constants' types based on context, so anything
-@command{g77} can do to help flag cases of this in such code
-could be very helpful.
-
-@node Equivalence Versus Equality
-@subsection Equivalence Versus Equality
-@cindex .EQV., with integer operands
-@cindex comparing logical expressions
-@cindex logical expressions, comparing
-
-Use of @code{.EQ.} and @code{.NE.} on @code{LOGICAL} operands
-is not supported, except via @option{-fugly-logint}, which is not
-recommended except for legacy code (where the behavior expected
-by the @emph{code} is assumed).
-
-Legacy code should be changed, as resources permit, to use @code{.EQV.}
-and @code{.NEQV.} instead, as these are permitted by the various
-Fortran standards.
-
-New code should never be written expecting @code{.EQ.} or @code{.NE.}
-to work if either of its operands is @code{LOGICAL}.
-
-The problem with supporting this ``feature'' is that there is
-unlikely to be consensus on how it works, as illustrated by the
-following sample program:
-
-@smallexample
-LOGICAL L,M,N
-DATA L,M,N /3*.FALSE./
-IF (L.AND.M.EQ.N) PRINT *,'L.AND.M.EQ.N'
-END
-@end smallexample
-
-The issue raised by the above sample program is: what is the
-precedence of @code{.EQ.} (and @code{.NE.}) when applied to
-@code{LOGICAL} operands?
-
-Some programmers will argue that it is the same as the precedence
-for @code{.EQ.} when applied to numeric (such as @code{INTEGER})
-operands.
-By this interpretation, the subexpression @samp{M.EQ.N} must be
-evaluated first in the above program, resulting in a program that,
-when run, does not execute the @code{PRINT} statement.
-
-Other programmers will argue that the precedence is the same as
-the precedence for @code{.EQV.}, which is restricted by the standards
-to @code{LOGICAL} operands.
-By this interpretation, the subexpression @samp{L.AND.M} must be
-evaluated first, resulting in a program that @emph{does} execute
-the @code{PRINT} statement.
-
-Assigning arbitrary semantic interpretations to syntactic expressions
-that might legitimately have more than one ``obvious'' interpretation
-is generally unwise.
-
-The creators of the various Fortran standards have done a good job
-in this case, requiring a distinct set of operators (which have their
-own distinct precedence) to compare @code{LOGICAL} operands.
-This requirement results in expression syntax with more certain
-precedence (without requiring substantial context), making it easier
-for programmers to read existing code.
-@command{g77} will avoid muddying up elements of the Fortran language
-that were well-designed in the first place.
-
-(Ask C programmers about the precedence of expressions such as
-@samp{(a) & (b)} and @samp{(a) - (b)}---they cannot even tell
-you, without knowing more context, whether the @samp{&} and @samp{-}
-operators are infix (binary) or unary!)
-
-Most dangerous of all is the fact that,
-even assuming consensus on its meaning,
-an expression like @samp{L.AND.M.EQ.N},
-if it is the result of a typographical error,
-doesn't @emph{look} like it has such a typo.
-Even experienced Fortran programmers would not likely notice that
-@samp{L.AND.M.EQV.N} was, in fact, intended.
-
-So, this is a prime example of a circumstance in which
-a quality compiler diagnoses the code,
-instead of leaving it up to someone debugging it
-to know to turn on special compiler options
-that might diagnose it.
-
-@node Order of Side Effects
-@subsection Order of Side Effects
-@cindex side effects, order of evaluation
-@cindex order of evaluation, side effects
-
-@command{g77} does not necessarily produce code that, when run, performs
-side effects (such as those performed by function invocations)
-in the same order as in some other compiler---or even in the same
-order as another version, port, or invocation (using different
-command-line options) of @command{g77}.
-
-It is never safe to depend on the order of evaluation of side effects.
-For example, an expression like this may very well behave differently
-from one compiler to another:
-
-@smallexample
-J = IFUNC() - IFUNC()
-@end smallexample
-
-@noindent
-There is no guarantee that @samp{IFUNC} will be evaluated in any particular
-order.
-Either invocation might happen first.
-If @samp{IFUNC} returns 5 the first time it is invoked, and
-returns 12 the second time, @samp{J} might end up with the
-value @samp{7}, or it might end up with @samp{-7}.
-
-Generally, in Fortran, procedures with side-effects intended to
-be visible to the caller are best designed as @emph{subroutines},
-not functions.
-Examples of such side-effects include:
-
-@itemize @bullet
-@item
-The generation of random numbers
-that are intended to influence return values.
-
-@item
-Performing I/O
-(other than internal I/O to local variables).
-
-@item
-Updating information in common blocks.
-@end itemize
-
-An example of a side-effect that is not intended to be visible
-to the caller is a function that maintains a cache of recently
-calculated results, intended solely to speed repeated invocations
-of the function with identical arguments.
-Such a function can be safely used in expressions, because
-if the compiler optimizes away one or more calls to the
-function, operation of the program is unaffected (aside
-from being speeded up).
-
-@node Warnings and Errors
-@section Warning Messages and Error Messages
-
-@cindex error messages
-@cindex warnings vs errors
-@cindex messages, warning and error
-The GNU compiler can produce two kinds of diagnostics: errors and
-warnings.
-Each kind has a different purpose:
-
-@itemize @w{}
-@item
-@emph{Errors} report problems that make it impossible to compile your
-program.
-GNU Fortran reports errors with the source file name, line
-number, and column within the line where the problem is apparent.
-
-@item
-@emph{Warnings} report other unusual conditions in your code that
-@emph{might} indicate a problem, although compilation can (and does)
-proceed.
-Warning messages also report the source file name, line number,
-and column information,
-but include the text @samp{warning:} to distinguish them
-from error messages.
-@end itemize
-
-Warnings might indicate danger points where you should check to make sure
-that your program really does what you intend; or the use of obsolete
-features; or the use of nonstandard features of GNU Fortran.
-Many warnings are issued only if you ask for them, with one of the
-@option{-W} options (for instance, @option{-Wall} requests a variety of
-useful warnings).
-
-@emph{Note:} Currently, the text of the line and a pointer to the column
-is printed in most @command{g77} diagnostics.
-
-@xref{Warning Options,,Options to Request or Suppress Warnings}, for
-more detail on these and related command-line options.
-
-@node Open Questions
-@chapter Open Questions
-
-Please consider offering useful answers to these questions!
-
-@itemize @bullet
-@item
-@code{LOC()} and other intrinsics are probably somewhat misclassified.
-Is the a need for more precise classification of intrinsics, and if so,
-what are the appropriate groupings?
-Is there a need to individually
-enable/disable/delete/hide intrinsics from the command line?
-@end itemize
-
-@node Bugs
-@chapter Reporting Bugs
-@cindex bugs
-@cindex reporting bugs
-
-Your bug reports play an essential role in making GNU Fortran reliable.
-
-When you encounter a problem, the first thing to do is to see if it is
-already known. @xref{Trouble}. If it isn't known, then you should
-report the problem.
-
-@menu
-* Criteria: Bug Criteria. Have you really found a bug?
-* Reporting: Bug Reporting. How to report a bug effectively.
-@end menu
-
-@xref{Trouble,,Known Causes of Trouble with GNU Fortran},
-for information on problems we already know about.
-
-@xref{Service,,How To Get Help with GNU Fortran},
-for information on where to ask for help.
-
-@node Bug Criteria
-@section Have You Found a Bug?
-@cindex bug criteria
-
-If you are not sure whether you have found a bug, here are some guidelines:
-
-@itemize @bullet
-@cindex fatal signal
-@cindex core dump
-@item
-If the compiler gets a fatal signal, for any input whatever, that is a
-compiler bug.
-Reliable compilers never crash---they just remain obsolete.
-
-@cindex invalid assembly code
-@cindex assembly code, invalid
-@item
-If the compiler produces invalid assembly code, for any input whatever,
-@c (except an @code{asm} statement),
-that is a compiler bug, unless the
-compiler reports errors (not just warnings) which would ordinarily
-prevent the assembler from being run.
-
-@cindex undefined behavior
-@cindex undefined function value
-@item
-If the compiler produces valid assembly code that does not correctly
-execute the input source code, that is a compiler bug.
-
-However, you must double-check to make sure, because you might have run
-into an incompatibility between GNU Fortran and traditional Fortran.
-@c (@pxref{Incompatibilities}).
-These incompatibilities might be considered
-bugs, but they are inescapable consequences of valuable features.
-
-Or you might have a program whose behavior is undefined, which happened
-by chance to give the desired results with another Fortran compiler.
-It is best to check the relevant Fortran standard thoroughly if
-it is possible that the program indeed does something undefined.
-
-After you have localized the error to a single source line, it should
-be easy to check for these things.
-If your program is correct and well defined, you have found
-a compiler bug.
-
-It might help if, in your submission, you identified the specific
-language in the relevant Fortran standard that specifies the
-desired behavior, if it isn't likely to be obvious and agreed-upon
-by all Fortran users.
-
-@item
-If the compiler produces an error message for valid input, that is a
-compiler bug.
-
-@cindex invalid input
-@item
-If the compiler does not produce an error message for invalid input,
-that is a compiler bug.
-However, you should note that your idea of
-``invalid input'' might be someone else's idea
-of ``an extension'' or ``support for traditional practice''.
-
-@item
-If you are an experienced user of Fortran compilers, your suggestions
-for improvement of GNU Fortran are welcome in any case.
-@end itemize
-
-Many, perhaps most, bug reports against @command{g77} turn out to
-be bugs in the user's code.
-While we find such bug reports educational, they sometimes take
-a considerable amount of time to track down or at least respond
-to---time we could be spending making @command{g77}, not some user's
-code, better.
-
-Some steps you can take to verify that the bug is not certainly
-in the code you're compiling with @command{g77}:
-
-@itemize @bullet
-@item
-Compile your code using the @command{g77} options @samp{-W -Wall -O}.
-These options enable many useful warning; the @option{-O} option
-enables flow analysis that enables the uninitialized-variable
-warning.
-
-If you investigate the warnings and find evidence of possible bugs
-in your code, fix them first and retry @command{g77}.
-
-@item
-Compile your code using the @command{g77} options @option{-finit-local-zero},
-@option{-fno-automatic}, @option{-ffloat-store}, and various
-combinations thereof.
-
-If your code works with any of these combinations, that is not
-proof that the bug isn't in @command{g77}---a @command{g77} bug exposed
-by your code might simply be avoided, or have a different, more subtle
-effect, when different options are used---but it can be a
-strong indicator that your code is making unwarranted assumptions
-about the Fortran dialect and/or underlying machine it is
-being compiled and run on.
-
-@xref{Overly Convenient Options,,Overly Convenient Command-Line Options},
-for information on the @option{-fno-automatic} and
-@option{-finit-local-zero} options and how to convert
-their use into selective changes in your own code.
-
-@item
-@pindex ftnchek
-Validate your code with @command{ftnchek} or a similar code-checking
-tool.
-@command{ftnchek} can be found at @uref{ftp://ftp.netlib.org/fortran}
-or @uref{ftp://ftp.dsm.fordham.edu}.
-
-@pindex make
-@cindex Makefile example
-Here are some sample @file{Makefile} rules using @command{ftnchek}
-``project'' files to do cross-file checking and @command{sfmakedepend}
-(from @uref{ftp://ahab.rutgers.edu/pub/perl/sfmakedepend})
-to maintain dependencies automatically.
-These assume the use of GNU @command{make}.
-
-@smallexample
-# Dummy suffix for ftnchek targets:
-.SUFFIXES: .chek
-.PHONY: chekall
-
-# How to compile .f files (for implicit rule):
-FC = g77
-# Assume `include' directory:
-FFLAGS = -Iinclude -g -O -Wall
-
-# Flags for ftnchek:
-CHEK1 = -array=0 -include=includes -noarray
-CHEK2 = -nonovice -usage=1 -notruncation
-CHEKFLAGS = $(CHEK1) $(CHEK2)
-
-# Run ftnchek with all the .prj files except the one corresponding
-# to the target's root:
-%.chek : %.f ; \
- ftnchek $(filter-out $*.prj,$(PRJS)) $(CHEKFLAGS) \
- -noextern -library $<
-
-# Derive a project file from a source file:
-%.prj : %.f ; \
- ftnchek $(CHEKFLAGS) -noextern -project -library $<
-
-# The list of objects is assumed to be in variable OBJS.
-# Sources corresponding to the objects:
-SRCS = $(OBJS:%.o=%.f)
-# ftnchek project files:
-PRJS = $(OBJS:%.o=%.prj)
-
-# Build the program
-prog: $(OBJS) ; \
- $(FC) -o $@ $(OBJS)
-
-chekall: $(PRJS) ; \
- ftnchek $(CHEKFLAGS) $(PRJS)
-
-prjs: $(PRJS)
-
-# For Emacs M-x find-tag:
-TAGS: $(SRCS) ; \
- etags $(SRCS)
-
-# Rebuild dependencies:
-depend: ; \
- sfmakedepend -I $(PLTLIBDIR) -I includes -a prj $(SRCS1)
-@end smallexample
-
-@item
-Try your code out using other Fortran compilers, such as @command{f2c}.
-If it does not work on at least one other compiler (assuming the
-compiler supports the features the code needs), that is a strong
-indicator of a bug in the code.
-
-However, even if your code works on many compilers @emph{except}
-@command{g77}, that does @emph{not} mean the bug is in @command{g77}.
-It might mean the bug is in your code, and that @command{g77} simply
-exposes it more readily than other compilers.
-@end itemize
-
-@node Bug Reporting
-@section How to Report Bugs
-@cindex compiler bugs, reporting
-
-Bugs should be reported to our bug database. Please refer to
-@uref{http://gcc.gnu.org/bugs.html} for up-to-date instructions how to
-submit bug reports. Copies of this file in HTML (@file{bugs.html}) and
-plain text (@file{BUGS}) are also part of GCC releases.
-
-
-@node Service
-@chapter How To Get Help with GNU Fortran
-
-If you need help installing, using or changing GNU Fortran, there are two
-ways to find it:
-
-@itemize @bullet
-@item
-Look in the service directory for someone who might help you for a fee.
-The service directory is found in the file named @file{SERVICE} in the
-GCC distribution.
-
-@item
-Send a message to @email{@value{email-help}}.
-@end itemize
-
-@end ifset
-@ifset INTERNALS
-@node Adding Options
-@chapter Adding Options
-@cindex options, adding
-@cindex adding options
-
-To add a new command-line option to @command{g77}, first decide
-what kind of option you wish to add.
-Search the @command{g77} and @command{gcc} documentation for one
-or more options that is most closely like the one you want to add
-(in terms of what kind of effect it has, and so on) to
-help clarify its nature.
-
-@itemize @bullet
-@item
-@emph{Fortran options} are options that apply only
-when compiling Fortran programs.
-They are accepted by @command{g77} and @command{gcc}, but
-they apply only when compiling Fortran programs.
-
-@item
-@emph{Compiler options} are options that apply
-when compiling most any kind of program.
-@end itemize
-
-@emph{Fortran options} are listed in the file
-@file{@value{path-g77}/lang-options.h},
-which is used during the build of @command{gcc} to
-build a list of all options that are accepted by
-at least one language's compiler.
-This list goes into the @code{documented_lang_options} array
-in @file{gcc/toplev.c}, which uses this array to
-determine whether a particular option should be
-offered to the linked-in front end for processing
-by calling @code{lang_option_decode}, which, for
-@command{g77}, is in @file{@value{path-g77}/com.c} and just
-calls @code{ffe_decode_option}.
-
-If the linked-in front end ``rejects'' a
-particular option passed to it, @file{toplev.c}
-just ignores the option, because @emph{some}
-language's compiler is willing to accept it.
-
-This allows commands like @samp{gcc -fno-asm foo.c bar.f}
-to work, even though Fortran compilation does
-not currently support the @option{-fno-asm} option;
-even though the @code{f771} version of @code{lang_decode_option}
-rejects @option{-fno-asm}, @file{toplev.c} doesn't
-produce a diagnostic because some other language (C)
-does accept it.
-
-This also means that commands like
-@samp{g77 -fno-asm foo.f} yield no diagnostics,
-despite the fact that no phase of the command was
-able to recognize and process @option{-fno-asm}---perhaps
-a warning about this would be helpful if it were
-possible.
-
-Code that processes Fortran options is found in
-@file{@value{path-g77}/top.c}, function @code{ffe_decode_option}.
-This code needs to check positive and negative forms
-of each option.
-
-The defaults for Fortran options are set in their
-global definitions, also found in @file{@value{path-g77}/top.c}.
-Many of these defaults are actually macros defined
-in @file{@value{path-g77}/target.h}, since they might be
-machine-specific.
-However, since, in practice, GNU compilers
-should behave the same way on all configurations
-(especially when it comes to language constructs),
-the practice of setting defaults in @file{target.h}
-is likely to be deprecated and, ultimately, stopped
-in future versions of @command{g77}.
-
-Accessor macros for Fortran options, used by code
-in the @command{g77} FFE, are defined in @file{@value{path-g77}/top.h}.
-
-@emph{Compiler options} are listed in @file{gcc/toplev.c}
-in the array @code{f_options}.
-An option not listed in @code{lang_options} is
-looked up in @code{f_options} and handled from there.
-
-The defaults for compiler options are set in the
-global definitions for the corresponding variables,
-some of which are in @file{gcc/toplev.c}.
-
-You can set different defaults for @emph{Fortran-oriented}
-or @emph{Fortran-reticent} compiler options by changing
-the source code of @command{g77} and rebuilding.
-How to do this depends on the version of @command{g77}:
-
-@table @code
-@item G77 0.5.24 (EGCS 1.1)
-@itemx G77 0.5.25 (EGCS 1.2 - which became GCC 2.95)
-Change the @code{lang_init_options} routine in @file{gcc/gcc/f/com.c}.
-
-(Note that these versions of @command{g77}
-perform internal consistency checking automatically
-when the @option{-fversion} option is specified.)
-
-@item G77 0.5.23
-@itemx G77 0.5.24 (EGCS 1.0)
-Change the way @code{f771} handles the @option{-fset-g77-defaults}
-option, which is always provided as the first option when
-called by @command{g77} or @command{gcc}.
-
-This code is in @code{ffe_decode_options} in @file{@value{path-g77}/top.c}.
-Have it change just the variables that you want to default
-to a different setting for Fortran compiles compared to
-compiles of other languages.
-
-The @option{-fset-g77-defaults} option is passed to @code{f771}
-automatically because of the specification information
-kept in @file{@value{path-g77}/lang-specs.h}.
-This file tells the @command{gcc} command how to recognize,
-in this case, Fortran source files (those to be preprocessed,
-and those that are not), and further, how to invoke the
-appropriate programs (including @code{f771}) to process
-those source files.
-
-It is in @file{@value{path-g77}/lang-specs.h} that @option{-fset-g77-defaults},
-@option{-fversion}, and other options are passed, as appropriate,
-even when the user has not explicitly specified them.
-Other ``internal'' options such as @option{-quiet} also
-are passed via this mechanism.
-@end table
-
-@node Projects
-@chapter Projects
-@cindex projects
-
-If you want to contribute to @command{g77} by doing research,
-design, specification, documentation, coding, or testing,
-the following information should give you some ideas.
-
-@menu
-* Efficiency:: Make @command{g77} itself compile code faster.
-* Better Optimization:: Teach @command{g77} to generate faster code.
-* Simplify Porting:: Make @command{g77} easier to configure, build,
- and install.
-* More Extensions:: Features many users won't know to ask for.
-* Machine Model:: @command{g77} should better leverage @command{gcc}.
-* Internals Documentation:: Make maintenance easier.
-* Internals Improvements:: Make internals more robust.
-* Better Diagnostics:: Make using @command{g77} on new code easier.
-@end menu
-
-@node Efficiency
-@section Improve Efficiency
-@cindex efficiency
-
-Don't bother doing any performance analysis until most of the
-following items are taken care of, because there's no question
-they represent serious space/time problems, although some of
-them show up only given certain kinds of (popular) input.
-
-@itemize @bullet
-@item
-Improve @code{malloc} package and its uses to specify more info about
-memory pools and, where feasible, use obstacks to implement them.
-
-@item
-Skip over uninitialized portions of aggregate areas (arrays,
-@code{COMMON} areas, @code{EQUIVALENCE} areas) so zeros need not be output.
-This would reduce memory usage for large initialized aggregate
-areas, even ones with only one initialized element.
-
-As of version 0.5.18, a portion of this item has already been
-accomplished.
-
-@item
-Prescan the statement (in @file{sta.c}) so that the nature of the statement
-is determined as much as possible by looking entirely at its form,
-and not looking at any context (previous statements, including types
-of symbols).
-This would allow ripping out of the statement-confirmation,
-symbol retraction/confirmation, and diagnostic inhibition
-mechanisms.
-Plus, it would result in much-improved diagnostics.
-For example, @samp{CALL some-intrinsic(@dots{})}, where the intrinsic
-is not a subroutine intrinsic, would result actual error instead of the
-unimplemented-statement catch-all.
-
-@item
-Throughout @command{g77}, don't pass line/column pairs where
-a simple @code{ffewhere} type, which points to the error as much as is
-desired by the configuration, will do, and don't pass @code{ffelexToken} types
-where a simple @code{ffewhere} type will do.
-Then, allow new default
-configuration of @code{ffewhere} such that the source line text is not
-preserved, and leave it to things like Emacs' next-error function
-to point to them (now that @samp{next-error} supports column,
-or, perhaps, character-offset, numbers).
-The change in calling sequences should improve performance somewhat,
-as should not having to save source lines.
-(Whether this whole
-item will improve performance is questionable, but it should
-improve maintainability.)
-
-@item
-Handle @samp{DATA (A(I),I=1,1000000)/1000000*2/} more efficiently, especially
-as regards the assembly output.
-Some of this might require improving
-the back end, but lots of improvement in space/time required in @command{g77}
-itself can be fairly easily obtained without touching the back end.
-Maybe type-conversion, where necessary, can be speeded up as well in
-cases like the one shown (converting the @samp{2} into @samp{2.}).
-
-@item
-If analysis shows it to be worthwhile, optimize @file{lex.c}.
-
-@item
-Consider redesigning @file{lex.c} to not need any feedback
-during tokenization, by keeping track of enough parse state on its
-own.
-@end itemize
-
-@node Better Optimization
-@section Better Optimization
-@cindex optimization, better
-@cindex code generation, improving
-
-Much of this work should be put off until after @command{g77} has
-all the features necessary for its widespread acceptance as a
-useful F77 compiler.
-However, perhaps this work can be done in parallel during
-the feature-adding work.
-
-@itemize @bullet
-@item
-Do the equivalent of the trick of putting @samp{extern inline} in front
-of every function definition in @code{libg2c} and #include'ing the resulting
-file in @command{f2c}+@command{gcc}---that is, inline all run-time-library functions
-that are at all worth inlining.
-(Some of this has already been done, such as for integral exponentiation.)
-
-@item
-When doing @samp{CHAR_VAR = CHAR_FUNC(@dots{})},
-and it's clear that types line up
-and @samp{CHAR_VAR} is addressable or not a @code{VAR_DECL},
-make @samp{CHAR_VAR}, not a
-temporary, be the receiver for @samp{CHAR_FUNC}.
-(This is now done for @code{COMPLEX} variables.)
-
-@item
-Design and implement Fortran-specific optimizations that don't
-really belong in the back end, or where the front end needs to
-give the back end more info than it currently does.
-
-@item
-Design and implement a new run-time library interface, with the
-code going into @code{libgcc} so no special linking is required to
-link Fortran programs using standard language features.
-This library
-would speed up lots of things, from I/O (using precompiled formats,
-doing just one, or, at most, very few, calls for arrays or array sections,
-and so on) to general computing (array/section implementations of
-various intrinsics, implementation of commonly performed loops that
-aren't likely to be optimally compiled otherwise, etc.).
-
-Among the important things the library would do are:
-
-@itemize @bullet
-@item
-Be a one-stop-shop-type
-library, hence shareable and usable by all, in that what are now
-library-build-time options in @code{libg2c} would be moved at least to the
-@command{g77} compile phase, if not to finer grains (such as choosing how
-list-directed I/O formatting is done by default at @code{OPEN} time, for
-preconnected units via options or even statements in the main program
-unit, maybe even on a per-I/O basis with appropriate pragma-like
-devices).
-@end itemize
-
-@item
-Probably requiring the new library design, change interface to
-normally have @code{COMPLEX} functions return their values in the way
-@command{gcc} would if they were declared @code{__complex__ float},
-rather than using
-the mechanism currently used by @code{CHARACTER} functions (whereby the
-functions are compiled as returning void and their first arg is
-a pointer to where to store the result).
-(Don't append underscores to
-external names for @code{COMPLEX} functions in some cases once @command{g77} uses
-@command{gcc} rather than @command{f2c} calling conventions.)
-
-@item
-Do something useful with @code{doiter} references where possible.
-For example, @samp{CALL FOO(I)} cannot modify @samp{I} if within
-a @code{DO} loop that uses @samp{I} as the
-iteration variable, and the back end might find that info useful
-in determining whether it needs to read @samp{I} back into a register after
-the call.
-(It normally has to do that, unless it knows @samp{FOO} never
-modifies its passed-by-reference argument, which is rarely the case
-for Fortran-77 code.)
-@end itemize
-
-@node Simplify Porting
-@section Simplify Porting
-@cindex porting, simplify
-@cindex simplify porting
-
-Making @command{g77} easier to configure, port, build, and install, either
-as a single-system compiler or as a cross-compiler, would be
-very useful.
-
-@itemize @bullet
-@item
-A new library (replacing @code{libg2c}) should improve portability as well as
-produce more optimal code.
-Further, @command{g77} and the new library should
-conspire to simplify naming of externals, such as by removing unnecessarily
-added underscores, and to reduce/eliminate the possibility of naming
-conflicts, while making debugger more straightforward.
-
-Also, it should
-make multi-language applications more feasible, such as by providing
-Fortran intrinsics that get Fortran unit numbers given C @code{FILE *}
-descriptors.
-
-@item
-Possibly related to a new library, @command{g77} should produce the equivalent
-of a @command{gcc} @samp{main(argc, argv)} function when it compiles a
-main program unit, instead of compiling something that must be
-called by a library
-implementation of @code{main()}.
-
-This would do many useful things such as
-provide more flexibility in terms of setting up exception handling,
-not requiring programmers to start their debugging sessions with
-@kbd{breakpoint MAIN__} followed by @kbd{run}, and so on.
-
-@item
-The GBE needs to understand the difference between alignment
-requirements and desires.
-For example, on Intel x86 machines, @command{g77} currently imposes
-overly strict alignment requirements, due to the back end, but it
-would be useful for Fortran and C programmers to be able to override
-these @emph{recommendations} as long as they don't violate the actual
-processor @emph{requirements}.
-@end itemize
-
-@node More Extensions
-@section More Extensions
-@cindex extensions, more
-
-These extensions are not the sort of things users ask for ``by name'',
-but they might improve the usability of @command{g77}, and Fortran in
-general, in the long run.
-Some of these items really pertain to improving @command{g77} internals
-so that some popular extensions can be more easily supported.
-
-@itemize @bullet
-@item
-Look through all the documentation on the GNU Fortran language,
-dialects, compiler, missing features, bugs, and so on.
-Many mentions of incomplete or missing features are
-sprinkled throughout.
-It is not worth repeating them here.
-
-@item
-Consider adding a @code{NUMERIC} type to designate typeless numeric constants,
-named and unnamed.
-The idea is to provide a forward-looking, effective
-replacement for things like the old-style @code{PARAMETER} statement
-when people
-really need typelessness in a maintainable, portable, clearly documented
-way.
-Maybe @code{TYPELESS} would include @code{CHARACTER}, @code{POINTER},
-and whatever else might come along.
-(This is not really a call for polymorphism per se, just
-an ability to express limited, syntactic polymorphism.)
-
-@item
-Support @samp{OPEN(@dots{},KEY=(@dots{}),@dots{})}.
-
-@item
-Support arbitrary file unit numbers, instead of limiting them
-to 0 through @samp{MXUNIT-1}.
-(This is a @code{libg2c} issue.)
-
-@item
-@samp{OPEN(NOSPANBLOCKS,@dots{})} is treated as
-@samp{OPEN(UNIT=NOSPANBLOCKS,@dots{})}, so a
-later @code{UNIT=} in the first example is invalid.
-Make sure this is what users of this feature would expect.
-
-@item
-Currently @command{g77} disallows @samp{READ(1'10)} since
-it is an obnoxious syntax, but
-supporting it might be pretty easy if needed.
-More details are needed, such
-as whether general expressions separated by an apostrophe are supported,
-or maybe the record number can be a general expression, and so on.
-
-@item
-Support @code{STRUCTURE}, @code{UNION}, @code{MAP}, and @code{RECORD}
-fully.
-Currently there is no support at all
-for @code{%FILL} in @code{STRUCTURE} and related syntax,
-whereas the rest of the
-stuff has at least some parsing support.
-This requires either major
-changes to @code{libg2c} or its replacement.
-
-@item
-F90 and @command{g77} probably disagree about label scoping relative to
-@code{INTERFACE} and @code{END INTERFACE}, and their contained
-procedure interface bodies (blocks?).
-
-@item
-@code{ENTRY} doesn't support F90 @code{RESULT()} yet,
-since that was added after S8.112.
-
-@item
-Empty-statement handling (10 ;;CONTINUE;;) probably isn't consistent
-with the final form of the standard (it was vague at S8.112).
-
-@item
-It seems to be an ``open'' question whether a file, immediately after being
-@code{OPEN}ed,is positioned at the beginning, the end, or wherever---it
-might be nice to offer an option of opening to ``undefined'' status, requiring
-an explicit absolute-positioning operation to be performed before any
-other (besides @code{CLOSE}) to assist in making applications port to systems
-(some IBM?) that @code{OPEN} to the end of a file or some such thing.
-@end itemize
-
-@node Machine Model
-@section Machine Model
-
-This items pertain to generalizing @command{g77}'s view of
-the machine model to more fully accept whatever the GBE
-provides it via its configuration.
-
-@itemize @bullet
-@item
-Switch to using @code{REAL_VALUE_TYPE} to represent floating-point constants
-exclusively so the target float format need not be required.
-This
-means changing the way @command{g77} handles initialization of aggregate areas
-having more than one type, such as @code{REAL} and @code{INTEGER},
-because currently
-it initializes them as if they were arrays of @code{char} and uses the
-bit patterns of the constants of the various types in them to determine
-what to stuff in elements of the arrays.
-
-@item
-Rely more and more on back-end info and capabilities, especially in the
-area of constants (where having the @command{g77} front-end's IL just store
-the appropriate tree nodes containing constants might be best).
-
-@item
-Suite of C and Fortran programs that a user/administrator can run on a
-machine to help determine the configuration for @command{g77} before building
-and help determine if the compiler works (especially with whatever
-libraries are installed) after building.
-@end itemize
-
-@node Internals Documentation
-@section Internals Documentation
-
-Better info on how @command{g77} works and how to port it is needed.
-
-@xref{Front End}, which contains some information
-on @command{g77} internals.
-
-@node Internals Improvements
-@section Internals Improvements
-
-Some more items that would make @command{g77} more reliable
-and easier to maintain:
-
-@itemize @bullet
-@item
-Generally make expression handling focus
-more on critical syntax stuff, leaving semantics to callers.
-For example,
-anything a caller can check, semantically, let it do so, rather
-than having @file{expr.c} do it.
-(Exceptions might include things like
-diagnosing @samp{FOO(I--K:)=BAR} where @samp{FOO} is a @code{PARAMETER}---if
-it seems
-important to preserve the left-to-right-in-source order of production
-of diagnostics.)
-
-@item
-Come up with better naming conventions for @option{-D} to establish requirements
-to achieve desired implementation dialect via @file{proj.h}.
-
-@item
-Clean up used tokens and @code{ffewhere}s in @code{ffeglobal_terminate_1}.
-
-@item
-Replace @file{sta.c} @code{outpooldisp} mechanism with @code{malloc_pool_use}.
-
-@item
-Check for @code{opANY} in more places in @file{com.c}, @file{std.c},
-and @file{ste.c}, and get rid of the @samp{opCONVERT(opANY)} kludge
-(after determining if there is indeed no real need for it).
-
-@item
-Utility to read and check @file{bad.def} messages and their references in the
-code, to make sure calls are consistent with message templates.
-
-@item
-Search and fix @samp{&ffe@dots{}} and similar so that
-@samp{ffe@dots{}ptr@dots{}} macros are
-available instead (a good argument for wishing this could have written all
-this stuff in C++, perhaps).
-On the other hand, it's questionable whether this sort of
-improvement is really necessary, given the availability of
-tools such as Emacs and Perl, which make finding any
-address-taking of structure members easy enough?
-
-@item
-Some modules truly export the member names of their structures (and the
-structures themselves), maybe fix this, and fix other modules that just
-appear to as well (by appending @samp{_}, though it'd be ugly and probably
-not worth the time).
-
-@item
-Implement C macros @samp{RETURNS(value)} and @samp{SETS(something,value)}
-in @file{proj.h}
-and use them throughout @command{g77} source code (especially in the definitions
-of access macros in @samp{.h} files) so they can be tailored
-to catch code writing into a @samp{RETURNS()} or reading from a @samp{SETS()}.
-
-@item
-Decorate throughout with @code{const} and other such stuff.
-
-@item
-All F90 notational derivations in the source code are still based
-on the S8.112 version of the draft standard.
-Probably should update
-to the official standard, or put documentation of the rules as used
-in the code@dots{}uh@dots{}in the code.
-
-@item
-Some @code{ffebld_new} calls (those outside of @file{ffeexpr.c} or
-inside but invoked via paths not involving @code{ffeexpr_lhs} or
-@code{ffeexpr_rhs}) might be creating things
-in improper pools, leading to such things staying around too long or
-(doubtful, but possible and dangerous) not long enough.
-
-@item
-Some @code{ffebld_list_new} (or whatever) calls might not be matched by
-@code{ffebld_list_bottom} (or whatever) calls, which might someday matter.
-(It definitely is not a problem just yet.)
-
-@item
-Probably not doing clean things when we fail to @code{EQUIVALENCE} something
-due to alignment/mismatch or other problems---they end up without
-@code{ffestorag} objects, so maybe the backend (and other parts of the front
-end) can notice that and handle like an @code{opANY} (do what it wants, just
-don't complain or crash).
-Most of this seems to have been addressed
-by now, but a code review wouldn't hurt.
-@end itemize
-
-@node Better Diagnostics
-@section Better Diagnostics
-
-These are things users might not ask about, or that need to
-be looked into, before worrying about.
-Also here are items that involve reducing unnecessary diagnostic
-clutter.
-
-@itemize @bullet
-@item
-When @code{FUNCTION} and @code{ENTRY} point types disagree (@code{CHARACTER}
-lengths, type classes, and so on),
-@code{ANY}-ize the offending @code{ENTRY} point and any @emph{new} dummies
-it specifies.
-
-@item
-Speed up and improve error handling for data when repeat-count is
-specified.
-For example, don't output 20 unnecessary messages after the
-first necessary one for:
-
-@smallexample
-INTEGER X(20)
-CONTINUE
-DATA (X(I), J= 1, 20) /20*5/
-END
-@end smallexample
-
-@noindent
-(The @code{CONTINUE} statement ensures the @code{DATA} statement
-is processed in the context of executable, not specification,
-statements.)
-@end itemize
-
-@include ffe.texi
-
-@end ifset
-
-@ifset USING
-@node Diagnostics
-@chapter Diagnostics
-@cindex diagnostics
-
-Some diagnostics produced by @command{g77} require sufficient explanation
-that the explanations are given below, and the diagnostics themselves
-identify the appropriate explanation.
-
-Identification uses the GNU Info format---specifically, the @command{info}
-command that displays the explanation is given within square
-brackets in the diagnostic.
-For example:
-
-@smallexample
-foo.f:5: Invalid statement [info -f g77 M FOOEY]
-@end smallexample
-
-More details about the above diagnostic is found in the @command{g77} Info
-documentation, menu item @samp{M}, submenu item @samp{FOOEY},
-which is displayed by typing the UNIX command
-@samp{info -f g77 M FOOEY}.
-
-Other Info readers, such as EMACS, may be just as easily used to display
-the pertinent node.
-In the above example, @samp{g77} is the Info document name,
-@samp{M} is the top-level menu item to select,
-and, in that node (named @samp{Diagnostics}, the name of
-this chapter, which is the very text you're reading now),
-@samp{FOOEY} is the menu item to select.
-
-@iftex
-In this printed version of the @command{g77} manual, the above example
-points to a section, below, entitled @samp{FOOEY}---though, of course,
-as the above is just a sample, no such section exists.
-@end iftex
-
-@menu
-* CMPAMBIG:: Ambiguous use of intrinsic.
-* EXPIMP:: Intrinsic used explicitly and implicitly.
-* INTGLOB:: Intrinsic also used as name of global.
-* LEX:: Various lexer messages
-* GLOBALS:: Disagreements about globals.
-* LINKFAIL:: When linking @code{f771} fails.
-* Y2KBAD:: Use of non-Y2K-compliant intrinsic.
-@end menu
-
-@node CMPAMBIG
-@section @code{CMPAMBIG}
-
-@noindent
-@smallexample
-Ambiguous use of intrinsic @var{intrinsic} @dots{}
-@end smallexample
-
-The type of the argument to the invocation of the @var{intrinsic}
-intrinsic is a @code{COMPLEX} type other than @code{COMPLEX(KIND=1)}.
-Typically, it is @code{COMPLEX(KIND=2)}, also known as
-@code{DOUBLE COMPLEX}.
-
-The interpretation of this invocation depends on the particular
-dialect of Fortran for which the code was written.
-Some dialects convert the real part of the argument to
-@code{REAL(KIND=1)}, thus losing precision; other dialects,
-and Fortran 90, do no such conversion.
-
-So, GNU Fortran rejects such invocations except under certain
-circumstances, to avoid making an incorrect assumption that results
-in generating the wrong code.
-
-To determine the dialect of the program unit, perhaps even whether
-that particular invocation is properly coded, determine how the
-result of the intrinsic is used.
-
-The result of @var{intrinsic} is expected (by the original programmer)
-to be @code{REAL(KIND=1)} (the non-Fortran-90 interpretation) if:
-
-@itemize @bullet
-@item
-It is passed as an argument to a procedure that explicitly or
-implicitly declares that argument @code{REAL(KIND=1)}.
-
-For example,
-a procedure with no @code{DOUBLE PRECISION} or @code{IMPLICIT DOUBLE PRECISION}
-statement specifying the dummy argument corresponding to an
-actual argument of @samp{REAL(Z)}, where @samp{Z} is declared
-@code{DOUBLE COMPLEX}, strongly suggests that the programmer
-expected @samp{REAL(Z)} to return @code{REAL(KIND=1)} instead
-of @code{REAL(KIND=2)}.
-
-@item
-It is used in a context that would otherwise not include
-any @code{REAL(KIND=2)} but where treating the @var{intrinsic}
-invocation as @code{REAL(KIND=2)} would result in unnecessary
-promotions and (typically) more expensive operations on the
-wider type.
-
-For example:
-
-@smallexample
-DOUBLE COMPLEX Z
-@dots{}
-R(1) = T * REAL(Z)
-@end smallexample
-
-The above example suggests the programmer expected the real part
-of @samp{Z} to be converted to @code{REAL(KIND=1)} before being
-multiplied by @samp{T} (presumed, along with @samp{R} above, to
-be type @code{REAL(KIND=1)}).
-
-Otherwise, the conversion would have to be delayed until after
-the multiplication, requiring not only an extra conversion
-(of @samp{T} to @code{REAL(KIND=2)}), but a (typically) more
-expensive multiplication (a double-precision multiplication instead
-of a single-precision one).
-@end itemize
-
-The result of @var{intrinsic} is expected (by the original programmer)
-to be @code{REAL(KIND=2)} (the Fortran 90 interpretation) if:
-
-@itemize @bullet
-@item
-It is passed as an argument to a procedure that explicitly or
-implicitly declares that argument @code{REAL(KIND=2)}.
-
-For example, a procedure specifying a @code{DOUBLE PRECISION}
-dummy argument corresponding to an
-actual argument of @samp{REAL(Z)}, where @samp{Z} is declared
-@code{DOUBLE COMPLEX}, strongly suggests that the programmer
-expected @samp{REAL(Z)} to return @code{REAL(KIND=2)} instead
-of @code{REAL(KIND=1)}.
-
-@item
-It is used in an expression context that includes
-other @code{REAL(KIND=2)} operands,
-or is assigned to a @code{REAL(KIND=2)} variable or array element.
-
-For example:
-
-@smallexample
-DOUBLE COMPLEX Z
-DOUBLE PRECISION R, T
-@dots{}
-R(1) = T * REAL(Z)
-@end smallexample
-
-The above example suggests the programmer expected the real part
-of @samp{Z} to @emph{not} be converted to @code{REAL(KIND=1)}
-by the @code{REAL()} intrinsic.
-
-Otherwise, the conversion would have to be immediately followed
-by a conversion back to @code{REAL(KIND=2)}, losing
-the original, full precision of the real part of @code{Z},
-before being multiplied by @samp{T}.
-@end itemize
-
-Once you have determined whether a particular invocation of @var{intrinsic}
-expects the Fortran 90 interpretation, you can:
-
-@itemize @bullet
-@item
-Change it to @samp{DBLE(@var{expr})} (if @var{intrinsic} is
-@code{REAL}) or @samp{DIMAG(@var{expr})} (if @var{intrinsic}
-is @code{AIMAG})
-if it expected the Fortran 90 interpretation.
-
-This assumes @var{expr} is @code{COMPLEX(KIND=2)}---if it is
-some other type, such as @code{COMPLEX*32}, you should use the
-appropriate intrinsic, such as the one to convert to @code{REAL*16}
-(perhaps @code{DBLEQ()} in place of @code{DBLE()}, and
-@code{QIMAG()} in place of @code{DIMAG()}).
-
-@item
-Change it to @samp{REAL(@var{intrinsic}(@var{expr}))},
-otherwise.
-This converts to @code{REAL(KIND=1)} in all working
-Fortran compilers.
-@end itemize
-
-If you don't want to change the code, and you are certain that all
-ambiguous invocations of @var{intrinsic} in the source file have
-the same expectation regarding interpretation, you can:
-
-@itemize @bullet
-@item
-Compile with the @command{g77} option @option{-ff90}, to enable the
-Fortran 90 interpretation.
-
-@item
-Compile with the @command{g77} options @samp{-fno-f90 -fugly-complex},
-to enable the non-Fortran-90 interpretations.
-@end itemize
-
-@xref{REAL() and AIMAG() of Complex}, for more information on this
-issue.
-
-Note: If the above suggestions don't produce enough evidence
-as to whether a particular program expects the Fortran 90
-interpretation of this ambiguous invocation of @var{intrinsic},
-there is one more thing you can try.
-
-If you have access to most or all the compilers used on the
-program to create successfully tested and deployed executables,
-read the documentation for, and @emph{also} test out, each compiler
-to determine how it treats the @var{intrinsic} intrinsic in
-this case.
-(If all the compilers don't agree on an interpretation, there
-might be lurking bugs in the deployed versions of the program.)
-
-The following sample program might help:
-
-@cindex JCB003 program
-@smallexample
- PROGRAM JCB003
-C
-C Written by James Craig Burley 1997-02-23.
-C
-C Determine how compilers handle non-standard REAL
-C and AIMAG on DOUBLE COMPLEX operands.
-C
- DOUBLE COMPLEX Z
- REAL R
- Z = (3.3D0, 4.4D0)
- R = Z
- CALL DUMDUM(Z, R)
- R = REAL(Z) - R
- IF (R .NE. 0.) PRINT *, 'REAL() is Fortran 90'
- IF (R .EQ. 0.) PRINT *, 'REAL() is not Fortran 90'
- R = 4.4D0
- CALL DUMDUM(Z, R)
- R = AIMAG(Z) - R
- IF (R .NE. 0.) PRINT *, 'AIMAG() is Fortran 90'
- IF (R .EQ. 0.) PRINT *, 'AIMAG() is not Fortran 90'
- END
-C
-C Just to make sure compiler doesn't use naive flow
-C analysis to optimize away careful work above,
-C which might invalidate results....
-C
- SUBROUTINE DUMDUM(Z, R)
- DOUBLE COMPLEX Z
- REAL R
- END
-@end smallexample
-
-If the above program prints contradictory results on a
-particular compiler, run away!
-
-@node EXPIMP
-@section @code{EXPIMP}
-
-@noindent
-@smallexample
-Intrinsic @var{intrinsic} referenced @dots{}
-@end smallexample
-
-The @var{intrinsic} is explicitly declared in one program
-unit in the source file and implicitly used as an intrinsic
-in another program unit in the same source file.
-
-This diagnostic is designed to catch cases where a program
-might depend on using the name @var{intrinsic} as an intrinsic
-in one program unit and as a global name (such as the name
-of a subroutine or function) in another, but @command{g77} recognizes
-the name as an intrinsic in both cases.
-
-After verifying that the program unit making implicit use
-of the intrinsic is indeed written expecting the intrinsic,
-add an @samp{INTRINSIC @var{intrinsic}} statement to that
-program unit to prevent this warning.
-
-This and related warnings are disabled by using
-the @option{-Wno-globals} option when compiling.
-
-Note that this warning is not issued for standard intrinsics.
-Standard intrinsics include those described in the FORTRAN 77
-standard and, if @option{-ff90} is specified, those described
-in the Fortran 90 standard.
-Such intrinsics are not as likely to be confused with user
-procedures as intrinsics provided as extensions to the
-standard by @command{g77}.
-
-@node INTGLOB
-@section @code{INTGLOB}
-
-@noindent
-@smallexample
-Same name `@var{intrinsic}' given @dots{}
-@end smallexample
-
-The name @var{intrinsic} is used for a global entity (a common
-block or a program unit) in one program unit and implicitly
-used as an intrinsic in another program unit.
-
-This diagnostic is designed to catch cases where a program
-intends to use a name entirely as a global name, but @command{g77}
-recognizes the name as an intrinsic in the program unit that
-references the name, a situation that would likely produce
-incorrect code.
-
-For example:
-
-@smallexample
-INTEGER FUNCTION TIME()
-@dots{}
-END
-@dots{}
-PROGRAM SAMP
-INTEGER TIME
-PRINT *, 'Time is ', TIME()
-END
-@end smallexample
-
-The above example defines a program unit named @samp{TIME}, but
-the reference to @samp{TIME} in the main program unit @samp{SAMP}
-is normally treated by @command{g77} as a reference to the intrinsic
-@code{TIME()} (unless a command-line option that prevents such
-treatment has been specified).
-
-As a result, the program @samp{SAMP} will @emph{not}
-invoke the @samp{TIME} function in the same source file.
-
-Since @command{g77} recognizes @code{libU77} procedures as
-intrinsics, and since some existing code uses the same names
-for its own procedures as used by some @code{libU77}
-procedures, this situation is expected to arise often enough
-to make this sort of warning worth issuing.
-
-After verifying that the program unit making implicit use
-of the intrinsic is indeed written expecting the intrinsic,
-add an @samp{INTRINSIC @var{intrinsic}} statement to that
-program unit to prevent this warning.
-
-Or, if you believe the program unit is designed to invoke the
-program-defined procedure instead of the intrinsic (as
-recognized by @command{g77}), add an @samp{EXTERNAL @var{intrinsic}}
-statement to the program unit that references the name to
-prevent this warning.
-
-This and related warnings are disabled by using
-the @option{-Wno-globals} option when compiling.
-
-Note that this warning is not issued for standard intrinsics.
-Standard intrinsics include those described in the FORTRAN 77
-standard and, if @option{-ff90} is specified, those described
-in the Fortran 90 standard.
-Such intrinsics are not as likely to be confused with user
-procedures as intrinsics provided as extensions to the
-standard by @command{g77}.
-
-@node LEX
-@section @code{LEX}
-
-@noindent
-@smallexample
-Unrecognized character @dots{}
-Invalid first character @dots{}
-Line too long @dots{}
-Non-numeric character @dots{}
-Continuation indicator @dots{}
-Label at @dots{} invalid with continuation line indicator @dots{}
-Character constant @dots{}
-Continuation line @dots{}
-Statement at @dots{} begins with invalid token
-@end smallexample
-
-Although the diagnostics identify specific problems, they can
-be produced when general problems such as the following occur:
-
-@itemize @bullet
-@item
-The source file contains something other than Fortran code.
-
-If the code in the file does not look like many of the examples
-elsewhere in this document, it might not be Fortran code.
-(Note that Fortran code often is written in lower case letters,
-while the examples in this document use upper case letters,
-for stylistic reasons.)
-
-For example, if the file contains lots of strange-looking
-characters, it might be APL source code; if it contains lots
-of parentheses, it might be Lisp source code; if it
-contains lots of bugs, it might be C++ source code.
-
-@item
-The source file contains free-form Fortran code, but @option{-ffree-form}
-was not specified on the command line to compile it.
-
-Free form is a newer form for Fortran code.
-The older, classic form is called fixed form.
-
-@cindex continuation character
-@cindex characters, continuation
-Fixed-form code is visually fairly distinctive, because
-numerical labels and comments are all that appear in
-the first five columns of a line, the sixth column is
-reserved to denote continuation lines,
-and actual statements start at or beyond column 7.
-Spaces generally are not significant, so if you
-see statements such as @samp{REALX,Y} and @samp{DO10I=1,100},
-you are looking at fixed-form code.
-@cindex *
-@cindex asterisk
-Comment lines are indicated by the letter @samp{C} or the symbol
-@samp{*} in column 1.
-@cindex trailing comment
-@cindex comment
-@cindex characters, comment
-@cindex !
-@cindex exclamation point
-(Some code uses @samp{!} or @samp{/*} to begin in-line comments,
-which many compilers support.)
-
-Free-form code is distinguished from fixed-form source
-primarily by the fact that statements may start anywhere.
-(If lots of statements start in columns 1 through 6,
-that's a strong indicator of free-form source.)
-Consecutive keywords must be separated by spaces, so
-@samp{REALX,Y} is not valid, while @samp{REAL X,Y} is.
-There are no comment lines per se, but @samp{!} starts a
-comment anywhere in a line (other than within a character or
-Hollerith constant).
-
-@xref{Source Form}, for more information.
-
-@item
-The source file is in fixed form and has been edited without
-sensitivity to the column requirements.
-
-Statements in fixed-form code must be entirely contained within
-columns 7 through 72 on a given line.
-Starting them ``early'' is more likely to result in diagnostics
-than finishing them ``late'', though both kinds of errors are
-often caught at compile time.
-
-For example, if the following code fragment is edited by following
-the commented instructions literally, the result, shown afterward,
-would produce a diagnostic when compiled:
-
-@smallexample
-C On XYZZY systems, remove "C" on next line:
-C CALL XYZZY_RESET
-@end smallexample
-
-The result of editing the above line might be:
-
-@smallexample
-C On XYZZY systems, remove "C" on next line:
- CALL XYZZY_RESET
-@end smallexample
-
-However, that leaves the first @samp{C} in the @code{CALL}
-statement in column 6, making it a comment line, which is
-not really what the author intended, and which is likely
-to result in one of the above-listed diagnostics.
-
-@emph{Replacing} the @samp{C} in column 1 with a space
-is the proper change to make, to ensure the @code{CALL}
-keyword starts in or after column 7.
-
-Another common mistake like this is to forget that fixed-form
-source lines are significant through only column 72, and that,
-normally, any text beyond column 72 is ignored or is diagnosed
-at compile time.
-
-@xref{Source Form}, for more information.
-
-@item
-The source file requires preprocessing, and the preprocessing
-is not being specified at compile time.
-
-A source file containing lines beginning with @code{#define},
-@code{#include}, @code{#if}, and so on is likely one that
-requires preprocessing.
-
-If the file's suffix is @samp{.f}, @samp{.for}, or @samp{.FOR},
-the file normally will be compiled @emph{without} preprocessing
-by @command{g77}.
-
-Change the file's suffix from @samp{.f} to @samp{.F}
-(or, on systems with case-insensitive file names,
-to @samp{.fpp} or @samp{.FPP}),
-from @samp{.for} to @samp{.fpp},
-or from @samp{.FOR} to @samp{.FPP}.
-@command{g77} compiles files with such names @emph{with}
-preprocessing.
-
-@pindex cpp
-@cindex preprocessor
-@cindex cpp program
-@cindex programs, cpp
-@cindex @option{-x f77-cpp-input} option
-@cindex options, @option{-x f77-cpp-input}
-Or, learn how to use @command{gcc}'s @option{-x} option to specify
-the language @samp{f77-cpp-input} for Fortran files that
-require preprocessing.
-@xref{Overall Options,,Options Controlling the Kind of
-Output,gcc,Using the GNU Compiler Collection (GCC)}.
-
-@item
-The source file is preprocessed, and the results of preprocessing
-result in syntactic errors that are not necessarily obvious to
-someone examining the source file itself.
-
-Examples of errors resulting from preprocessor macro expansion
-include exceeding the line-length limit, improperly starting,
-terminating, or incorporating the apostrophe or double-quote in
-a character constant, improperly forming a Hollerith constant,
-and so on.
-
-@xref{Overall Options,,Options Controlling the Kind of Output},
-for suggestions about how to use, and not use, preprocessing
-for Fortran code.
-@end itemize
-
-@node GLOBALS
-@section @code{GLOBALS}
-
-@noindent
-@smallexample
-Global name @var{name} defined at @dots{} already defined@dots{}
-Global name @var{name} at @dots{} has different type@dots{}
-Too many arguments passed to @var{name} at @dots{}
-Too few arguments passed to @var{name} at @dots{}
-Argument #@var{n} of @var{name} is @dots{}
-@end smallexample
-
-These messages all identify disagreements about the
-global procedure named @var{name} among different program units
-(usually including @var{name} itself).
-
-Whether a particular disagreement is reported
-as a warning or an error
-can depend on the relative order
-of the disagreeing portions of the source file.
-
-Disagreements between a procedure invocation
-and the @emph{subsequent} procedure itself
-are, usually, diagnosed as errors
-when the procedure itself @emph{precedes} the invocation.
-Other disagreements are diagnosed via warnings.
-
-@cindex forward references
-@cindex in-line code
-@cindex compilation, in-line
-This distinction, between warnings and errors,
-is due primarily to the present tendency of the @command{gcc} back end
-to inline only those procedure invocations that are
-@emph{preceded} by the corresponding procedure definitions.
-If the @command{gcc} back end is changed
-to inline ``forward references'',
-in which invocations precede definitions,
-the @command{g77} front end will be changed
-to treat both orderings as errors, accordingly.
-
-The sorts of disagreements that are diagnosed by @command{g77} include
-whether a procedure is a subroutine or function;
-if it is a function, the type of the return value of the procedure;
-the number of arguments the procedure accepts;
-and the type of each argument.
-
-Disagreements regarding global names among program units
-in a Fortran program @emph{should} be fixed in the code itself.
-However, if that is not immediately practical,
-and the code has been working for some time,
-it is possible it will work
-when compiled with the @option{-fno-globals} option.
-
-The @option{-fno-globals} option
-causes these diagnostics to all be warnings
-and disables all inlining of references to global procedures
-(to avoid subsequent compiler crashes and bad-code generation).
-Use of the @option{-Wno-globals} option as well as @option{-fno-globals}
-suppresses all of these diagnostics.
-(@option{-Wno-globals} by itself disables only the warnings,
-not the errors.)
-
-After using @option{-fno-globals} to work around these problems,
-it is wise to stop using that option and address them by fixing
-the Fortran code, because such problems, while they might not
-actually result in bugs on some systems, indicate that the code
-is not as portable as it could be.
-In particular, the code might appear to work on a particular
-system, but have bugs that affect the reliability of the data
-without exhibiting any other outward manifestations of the bugs.
-
-@node LINKFAIL
-@section @code{LINKFAIL}
-
-@noindent
-On AIX 4.1, @command{g77} might not build with the native (non-GNU) tools
-due to a linker bug in coping with the @option{-bbigtoc} option which
-leads to a @samp{Relocation overflow} error. The GNU linker is not
-recommended on current AIX versions, though; it was developed under a
-now-unsupported version. This bug is said to be fixed by `update PTF
-U455193 for APAR IX75823'.
-
-Compiling with @option{-mminimal-toc}
-might solve this problem, e.g.@: by adding
-@smallexample
-BOOT_CFLAGS='-mminimal-toc -O2 -g'
-@end smallexample
-to the @code{make bootstrap} command line.
-
-@node Y2KBAD
-@section @code{Y2KBAD}
-@cindex Y2K compliance
-@cindex Year 2000 compliance
-
-@noindent
-@smallexample
-Intrinsic `@var{name}', invoked at (^), known to be non-Y2K-compliant@dots{}
-@end smallexample
-
-This diagnostic indicates that
-the specific intrinsic invoked by the name @var{name}
-is known to have an interface
-that is not Year-2000 (Y2K) compliant.
-
-@xref{Year 2000 (Y2K) Problems}.
-
-@end ifset
-
-@node Keyword Index
-@unnumbered Keyword Index
-
-@printindex cp
-@bye
+++ /dev/null
-/* Specific flags and argument handling of the Fortran front-end.
- Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004
- Free Software Foundation, Inc.
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCC is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* This file contains a filter for the main `gcc' driver, which is
- replicated for the `g77' driver by adding this filter. The purpose
- of this filter is to be basically identical to gcc (in that
- it faithfully passes all of the original arguments to gcc) but,
- unless explicitly overridden by the user in certain ways, ensure
- that the needs of the language supported by this wrapper are met.
-
- For GNU Fortran (g77), we do the following to the argument list
- before passing it to `gcc':
-
- 1. Make sure `-lg2c -lm' is at the end of the list.
-
- 2. Make sure each time `-lg2c' or `-lm' is seen, it forms
- part of the series `-lg2c -lm'.
-
- #1 and #2 are not done if `-nostdlib' or any option that disables
- the linking phase is present, or if `-xfoo' is in effect. Note that
- a lack of source files or -l options disables linking.
-
- This program was originally made out of gcc/cp/g++spec.c, but the
- way it builds the new argument list was rewritten so it is much
- easier to maintain, improve the way it decides to add or not add
- extra arguments, etc. And several improvements were made in the
- handling of arguments, primarily to make it more consistent with
- `gcc' itself. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "gcc.h"
-#include "intl.h"
-
-#ifndef MATH_LIBRARY
-#define MATH_LIBRARY "-lm"
-#endif
-
-#ifndef FORTRAN_INIT
-#define FORTRAN_INIT "-lfrtbegin"
-#endif
-
-#ifndef FORTRAN_LIBRARY
-#define FORTRAN_LIBRARY "-lg2c"
-#endif
-
-/* Options this driver needs to recognize, not just know how to
- skip over. */
-typedef enum
-{
- OPTION_b, /* Aka --prefix. */
- OPTION_B, /* Aka --target. */
- OPTION_c, /* Aka --compile. */
- OPTION_driver, /* Wrapper-specific option. */
- OPTION_E, /* Aka --preprocess. */
- OPTION_help, /* --help. */
- OPTION_i, /* -imacros, -include, -include-*. */
- OPTION_l,
- OPTION_L, /* Aka --library-directory. */
- OPTION_M, /* Aka --dependencies. */
- OPTION_MM, /* Aka --user-dependencies. */
- OPTION_nostdlib, /* Aka --no-standard-libraries, or
- -nodefaultlibs. */
- OPTION_o, /* Aka --output. */
- OPTION_S, /* Aka --assemble. */
- OPTION_syntax_only, /* -fsyntax-only. */
- OPTION_v, /* Aka --verbose. */
- OPTION_version, /* --version. */
- OPTION_V, /* Aka --use-version. */
- OPTION_x, /* Aka --language. */
- OPTION_ /* Unrecognized or unimportant. */
-} Option;
-
-/* The original argument list and related info is copied here. */
-static int g77_xargc;
-static const char *const *g77_xargv;
-static void lookup_option (Option *, int *, const char **, const char *);
-static void append_arg (const char *);
-
-/* The new argument list will be built here. */
-static int g77_newargc;
-static const char **g77_newargv;
-
-#ifndef SWITCH_TAKES_ARG
-#define SWITCH_TAKES_ARG(CHAR) DEFAULT_SWITCH_TAKES_ARG(CHAR)
-#endif
-
-#ifndef WORD_SWITCH_TAKES_ARG
-#define WORD_SWITCH_TAKES_ARG(STR) DEFAULT_WORD_SWITCH_TAKES_ARG (STR)
-#endif
-
-/* Assumes text[0] == '-'. Returns number of argv items that belong to
- (and follow) this one, an option id for options important to the
- caller, and a pointer to the first char of the arg, if embedded (else
- returns NULL, meaning no arg or it's the next argv).
-
- Note that this also assumes gcc.c's pass converting long options
- to short ones, where available, has already been run. */
-
-static void
-lookup_option (Option *xopt, int *xskip, const char **xarg, const char *text)
-{
- Option opt = OPTION_;
- int skip;
- const char *arg = NULL;
-
- if ((skip = SWITCH_TAKES_ARG (text[1])))
- skip -= (text[2] != '\0'); /* See gcc.c. */
-
- if (text[1] == 'B')
- opt = OPTION_B, skip = (text[2] == '\0'), arg = text + 2;
- else if (text[1] == 'b')
- opt = OPTION_b, skip = (text[2] == '\0'), arg = text + 2;
- else if ((text[1] == 'c') && (text[2] == '\0'))
- opt = OPTION_c, skip = 0;
- else if ((text[1] == 'E') && (text[2] == '\0'))
- opt = OPTION_E, skip = 0;
- else if (text[1] == 'i')
- opt = OPTION_i, skip = 0;
- else if (text[1] == 'l')
- opt = OPTION_l;
- else if (text[1] == 'L')
- opt = OPTION_L, arg = text + 2;
- else if (text[1] == 'o')
- opt = OPTION_o;
- else if ((text[1] == 'S') && (text[2] == '\0'))
- opt = OPTION_S, skip = 0;
- else if (text[1] == 'V')
- opt = OPTION_V, skip = (text[2] == '\0');
- else if ((text[1] == 'v') && (text[2] == '\0'))
- opt = OPTION_v, skip = 0;
- else if (text[1] == 'x')
- opt = OPTION_x, arg = text + 2;
- else
- {
- if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */
- ;
- else if (! strncmp (text, "-fdriver", 8)) /* Really --driver!! */
- opt = OPTION_driver; /* Never mind arg, this is unsupported. */
- else if (! strcmp (text, "-fhelp")) /* Really --help!! */
- opt = OPTION_help;
- else if (! strcmp (text, "-M"))
- opt = OPTION_M;
- else if (! strcmp (text, "-MM"))
- opt = OPTION_MM;
- else if (! strcmp (text, "-nostdlib")
- || ! strcmp (text, "-nodefaultlibs"))
- opt = OPTION_nostdlib;
- else if (! strcmp (text, "-fsyntax-only"))
- opt = OPTION_syntax_only;
- else if (! strcmp (text, "-dumpversion"))
- opt = OPTION_version;
- else if (! strcmp (text, "-fversion")) /* Really --version!! */
- opt = OPTION_version;
- else if (! strcmp (text, "-Xlinker")
- || ! strcmp (text, "-specs"))
- skip = 1;
- else
- skip = 0;
- }
-
- if (xopt != NULL)
- *xopt = opt;
- if (xskip != NULL)
- *xskip = skip;
- if (xarg != NULL)
- {
- if ((arg != NULL)
- && (arg[0] == '\0'))
- *xarg = NULL;
- else
- *xarg = arg;
- }
-}
-
-/* Append another argument to the list being built. As long as it is
- identical to the corresponding arg in the original list, just increment
- the new arg count. Otherwise allocate a new list, etc. */
-
-static void
-append_arg (const char *arg)
-{
- static int newargsize;
-
-#if 0
- fprintf (stderr, "`%s'\n", arg);
-#endif
-
- if (g77_newargv == g77_xargv
- && g77_newargc < g77_xargc
- && (arg == g77_xargv[g77_newargc]
- || ! strcmp (arg, g77_xargv[g77_newargc])))
- {
- ++g77_newargc;
- return; /* Nothing new here. */
- }
-
- if (g77_newargv == g77_xargv)
- { /* Make new arglist. */
- int i;
-
- newargsize = (g77_xargc << 2) + 20; /* This should handle all. */
- g77_newargv = xmalloc (newargsize * sizeof (char *));
-
- /* Copy what has been done so far. */
- for (i = 0; i < g77_newargc; ++i)
- g77_newargv[i] = g77_xargv[i];
- }
-
- if (g77_newargc == newargsize)
- fatal ("overflowed output arg list for `%s'", arg);
-
- g77_newargv[g77_newargc++] = arg;
-}
-
-void
-lang_specific_driver (int *in_argc, const char *const **in_argv,
- int *in_added_libraries ATTRIBUTE_UNUSED)
-{
- int argc = *in_argc;
- const char *const *argv = *in_argv;
- int i;
- int verbose = 0;
- Option opt;
- int skip;
- const char *arg;
-
- /* This will be NULL if we encounter a situation where we should not
- link in libf2c. */
- const char *library = FORTRAN_LIBRARY;
-
- /* 0 => -xnone in effect.
- 1 => -xfoo in effect. */
- int saw_speclang = 0;
-
- /* 0 => initial/reset state
- 1 => last arg was -l<library>
- 2 => last two args were -l<library> -lm. */
- int saw_library = 0;
-
- /* 0 => initial/reset state
- 1 => FORTRAN_INIT linked in */
- int use_init = 0;
- /* By default, we throw on the math library if we have one. */
- int need_math = (MATH_LIBRARY[0] != '\0');
-
- /* The number of input and output files in the incoming arg list. */
- int n_infiles = 0;
- int n_outfiles = 0;
-
-#if 0
- fprintf (stderr, "Incoming:");
- for (i = 0; i < argc; i++)
- fprintf (stderr, " %s", argv[i]);
- fprintf (stderr, "\n");
-#endif
-
- g77_xargc = argc;
- g77_xargv = argv;
- g77_newargc = 0;
- g77_newargv = (const char **) argv;
-
- /* First pass through arglist.
-
- If -nostdlib or a "turn-off-linking" option is anywhere in the
- command line, don't do any library-option processing (except
- relating to -x). Also, if -v is specified, but no other options
- that do anything special (allowing -V version, etc.), remember
- to add special stuff to make gcc command actually invoke all
- the different phases of the compilation process so all the version
- numbers can be seen.
-
- Also, here is where all problems with missing arguments to options
- are caught. If this loop is exited normally, it means all options
- have the appropriate number of arguments as far as the rest of this
- program is concerned. */
-
- for (i = 1; i < argc; ++i)
- {
- if ((argv[i][0] == '+') && (argv[i][1] == 'e'))
- {
- continue;
- }
-
- if ((argv[i][0] != '-') || (argv[i][1] == '\0'))
- {
- ++n_infiles;
- continue;
- }
-
- lookup_option (&opt, &skip, NULL, argv[i]);
-
- switch (opt)
- {
- case OPTION_nostdlib:
- case OPTION_c:
- case OPTION_S:
- case OPTION_syntax_only:
- case OPTION_E:
- case OPTION_M:
- case OPTION_MM:
- /* These options disable linking entirely or linking of the
- standard libraries. */
- library = 0;
- break;
-
- case OPTION_l:
- ++n_infiles;
- break;
-
- case OPTION_o:
- ++n_outfiles;
- break;
-
- case OPTION_v:
- verbose = 1;
- break;
-
- case OPTION_b:
- case OPTION_B:
- case OPTION_L:
- case OPTION_i:
- case OPTION_V:
- /* These options are useful in conjunction with -v to get
- appropriate version info. */
- break;
-
- case OPTION_version:
- printf ("GNU Fortran (GCC) %s\n", version_string);
- printf ("Copyright %s 2004 Free Software Foundation, Inc.\n",
- _("(C)"));
- printf ("\n");
- printf (_("\
-GNU Fortran comes with NO WARRANTY, to the extent permitted by law.\n\
-You may redistribute copies of GNU Fortran\n\
-under the terms of the GNU General Public License.\n\
-For more information about these matters, see the file named COPYING\n\
-or type the command `info -f g77 Copying'.\n\
-"));
- exit (0);
- break;
-
- case OPTION_help:
- /* Let gcc.c handle this, as it has a really
- cool facility for handling --help and --verbose --help. */
- return;
-
- case OPTION_driver:
- fatal ("--driver no longer supported");
- break;
-
- default:
- break;
- }
-
- /* This is the one place we check for missing arguments in the
- program. */
-
- if (i + skip < argc)
- i += skip;
- else
- fatal ("argument to `%s' missing", argv[i]);
- }
-
- if ((n_outfiles != 0) && (n_infiles == 0))
- fatal ("no input files; unwilling to write output files");
-
- /* If there are no input files, no need for the library. */
- if (n_infiles == 0)
- library = 0;
-
- /* Second pass through arglist, transforming arguments as appropriate. */
-
- append_arg (argv[0]); /* Start with command name, of course. */
-
- for (i = 1; i < argc; ++i)
- {
- if (argv[i][0] == '\0')
- {
- append_arg (argv[i]); /* Interesting. Just append as is. */
- continue;
- }
-
- if ((argv[i][0] == '-') && (argv[i][1] != 'l'))
- {
- /* Not a filename or library. */
-
- if (saw_library == 1 && need_math) /* -l<library>. */
- append_arg (MATH_LIBRARY);
-
- saw_library = 0;
-
- lookup_option (&opt, &skip, &arg, argv[i]);
-
- if (argv[i][1] == '\0')
- {
- append_arg (argv[i]); /* "-" == Standard input. */
- continue;
- }
-
- if (opt == OPTION_x)
- {
- /* Track input language. */
- const char *lang;
-
- if (arg == NULL)
- lang = argv[i+1];
- else
- lang = arg;
-
- saw_speclang = (strcmp (lang, "none") != 0);
- }
-
- append_arg (argv[i]);
-
- for (; skip != 0; --skip)
- append_arg (argv[++i]);
-
- continue;
- }
-
- /* A filename/library, not an option. */
-
- if (saw_speclang)
- saw_library = 0; /* -xfoo currently active. */
- else
- { /* -lfoo or filename. */
- if (strcmp (argv[i], MATH_LIBRARY) == 0)
- {
- if (saw_library == 1)
- saw_library = 2; /* -l<library> -lm. */
- else
- {
- if (0 == use_init)
- {
- append_arg (FORTRAN_INIT);
- use_init = 1;
- }
- append_arg (FORTRAN_LIBRARY);
- }
- }
- else if (strcmp (argv[i], FORTRAN_LIBRARY) == 0)
- saw_library = 1; /* -l<library>. */
- else
- { /* Other library, or filename. */
- if (saw_library == 1 && need_math)
- append_arg (MATH_LIBRARY);
- saw_library = 0;
- }
- }
- append_arg (argv[i]);
- }
-
- /* Append `-lg2c -lm' as necessary. */
-
- if (library)
- { /* Doing a link and no -nostdlib. */
- if (saw_speclang)
- append_arg ("-xnone");
-
- switch (saw_library)
- {
- case 0:
- if (0 == use_init)
- {
- append_arg (FORTRAN_INIT);
- use_init = 1;
- }
- append_arg (library);
- case 1:
- if (need_math)
- append_arg (MATH_LIBRARY);
- default:
- break;
- }
- }
-
-#ifdef ENABLE_SHARED_LIBGCC
- if (library)
- {
- int i;
-
- for (i = 1; i < g77_newargc; i++)
- if (g77_newargv[i][0] == '-')
- if (strcmp (g77_newargv[i], "-static-libgcc") == 0
- || strcmp (g77_newargv[i], "-static") == 0)
- break;
-
- if (i == g77_newargc)
- append_arg ("-shared-libgcc");
- }
-
-#endif
-
- if (verbose
- && g77_newargv != g77_xargv)
- {
- fprintf (stderr, "Driving:");
- for (i = 0; i < g77_newargc; i++)
- fprintf (stderr, " %s", g77_newargv[i]);
- fprintf (stderr, "\n");
- }
-
- *in_argc = g77_newargc;
- *in_argv = g77_newargv;
-}
-
-/* Called before linking. Returns 0 on success and -1 on failure. */
-int lang_specific_pre_link (void) /* Not used for F77. */
-{
- return 0;
-}
-
-/* Number of extra output files that lang_specific_pre_link may generate. */
-int lang_specific_extra_outfiles = 0; /* Not used for F77. */
-
-/* Table of language-specific spec functions. */
-const struct spec_function lang_specific_spec_functions[] =
-{
- { 0, 0 }
-};
+++ /dev/null
-/* global.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
-
- Description:
- Manages information kept across individual program units within a single
- source file. This includes reporting errors when a name is defined
- multiple times (for example, two program units named FOO) and when a
- COMMON block is given initial data in more than one program unit.
-
- Modifications:
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "global.h"
-#include "info.h"
-#include "lex.h"
-#include "malloc.h"
-#include "name.h"
-#include "symbol.h"
-#include "top.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-
-/* Static objects accessed by functions in this module. */
-
-#if FFEGLOBAL_ENABLED
-static ffenameSpace ffeglobal_filewide_ = NULL;
-static const char *const ffeglobal_type_string_[] =
-{
- [FFEGLOBAL_typeNONE] = "??",
- [FFEGLOBAL_typeMAIN] = "main program",
- [FFEGLOBAL_typeEXT] = "external",
- [FFEGLOBAL_typeSUBR] = "subroutine",
- [FFEGLOBAL_typeFUNC] = "function",
- [FFEGLOBAL_typeBDATA] = "block data",
- [FFEGLOBAL_typeCOMMON] = "common block",
- [FFEGLOBAL_typeANY] = "?any?"
-};
-#endif
-
-/* Static functions (internal). */
-
-
-/* Internal macros. */
-\f
-
-/* Call given fn with all globals
-
- ffeglobal (*fn)(ffeglobal g);
- ffeglobal_drive(fn); */
-
-#if FFEGLOBAL_ENABLED
-void
-ffeglobal_drive (ffeglobal (*fn) (ffeglobal))
-{
- if (ffeglobal_filewide_ != NULL)
- ffename_space_drive_global (ffeglobal_filewide_, fn);
-}
-
-#endif
-/* ffeglobal_new_ -- Make new global
-
- ffename n;
- ffeglobal g;
- g = ffeglobal_new_(n); */
-
-#if FFEGLOBAL_ENABLED
-static ffeglobal
-ffeglobal_new_ (ffename n)
-{
- ffeglobal g;
-
- assert (n != NULL);
-
- g = malloc_new_ks (malloc_pool_image (), "FFEGLOBAL", sizeof (*g));
- g->n = n;
- g->hook = FFECOM_globalNULL;
- g->tick = 0;
-
- ffename_set_global (n, g);
-
- return g;
-}
-
-#endif
-/* ffeglobal_init_1 -- Initialize per file
-
- ffeglobal_init_1(); */
-
-void
-ffeglobal_init_1 (void)
-{
-#if FFEGLOBAL_ENABLED
- if (ffeglobal_filewide_ != NULL)
- ffename_space_kill (ffeglobal_filewide_);
- ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ());
-#endif
-}
-
-/* ffeglobal_init_common -- Initial value specified for common block
-
- ffesymbol s; // the ffesymbol for the common block
- ffelexToken t; // the token with the point of initialization
- ffeglobal_init_common(s,t);
-
- For back ends where file-wide global symbols are not maintained, does
- nothing. Otherwise, makes sure this common block hasn't already been
- initialized in a previous program unit, and flag that it's been
- initialized in this one. */
-
-void
-ffeglobal_init_common (ffesymbol s, ffelexToken t)
-{
-#if FFEGLOBAL_ENABLED
- ffeglobal g;
-
- g = ffesymbol_global (s);
-
- if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
- return;
- if (g->type == FFEGLOBAL_typeANY)
- return;
-
- if (g->tick == ffe_count_2)
- return;
-
- if (g->tick != 0)
- {
- if (g->u.common.initt != NULL)
- {
- ffebad_start (FFEBAD_COMMON_ALREADY_INIT);
- ffebad_string (ffesymbol_text (s));
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->u.common.initt),
- ffelex_token_where_column (g->u.common.initt));
- ffebad_finish ();
- }
-
- /* Complain about just one attempt to reinit per program unit, but
- continue referring back to the first such successful attempt. */
- }
- else
- {
- if (g->u.common.blank)
- {
- /* Not supposed to initialize blank common, though it works. */
- ffebad_start (FFEBAD_COMMON_BLANK_INIT);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- g->u.common.initt = ffelex_token_use (t);
- }
-
- g->tick = ffe_count_2;
-#endif
-}
-
-/* ffeglobal_new_common -- New common block
-
- ffesymbol s; // the ffesymbol for the new common block
- ffelexToken t; // the token with the name of the common block
- bool blank; // TRUE if blank common
- ffeglobal_new_common(s,t,blank);
-
- For back ends where file-wide global symbols are not maintained, does
- nothing. Otherwise, makes sure this symbol hasn't been seen before or
- is known as a common block. */
-
-void
-ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
-{
-#if FFEGLOBAL_ENABLED
- ffename n;
- ffeglobal g;
-
- if (ffesymbol_global (s) == NULL)
- {
- n = ffename_find (ffeglobal_filewide_, t);
- g = ffename_global (n);
- }
- else
- {
- g = ffesymbol_global (s);
- n = NULL;
- }
-
- if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
- return;
-
- if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
- {
- if (g->type == FFEGLOBAL_typeCOMMON)
- {
- /* The names match, so the "blankness" should match too! */
- assert (g->u.common.blank == blank);
- }
- else
- {
- /* This global name has already been established,
- but as something other than a common block. */
- if (ffe_is_globals () || ffe_is_warn_globals ())
- {
- ffebad_start (ffe_is_globals ()
- ? FFEBAD_FILEWIDE_ALREADY_SEEN
- : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
- ffebad_string (ffelex_token_text (t));
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- g->type = FFEGLOBAL_typeANY;
- }
- }
- else
- {
- if (g == NULL)
- {
- g = ffeglobal_new_ (n);
- g->intrinsic = FALSE;
- }
- else if (g->intrinsic
- && !g->explicit_intrinsic
- && ffe_is_warn_globals ())
- {
- /* Common name previously used as intrinsic. Though it works,
- warn, because the intrinsic reference might have been intended
- as a ref to an external procedure, but g77's vast list of
- intrinsics happened to snarf the name. */
- ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
- ffebad_string (ffelex_token_text (t));
- ffebad_string ("common block");
- ffebad_string ("intrinsic");
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- g->t = ffelex_token_use (t);
- g->type = FFEGLOBAL_typeCOMMON;
- g->u.common.have_pad = FALSE;
- g->u.common.have_save = FALSE;
- g->u.common.have_size = FALSE;
- g->u.common.blank = blank;
- }
-
- ffesymbol_set_global (s, g);
-#endif
-}
-
-/* ffeglobal_new_progunit_ -- New program unit
-
- ffesymbol s; // the ffesymbol for the new unit
- ffelexToken t; // the token with the name of the unit
- ffeglobalType type; // the type of the new unit
- ffeglobal_new_progunit_(s,t,type);
-
- For back ends where file-wide global symbols are not maintained, does
- nothing. Otherwise, makes sure this symbol hasn't been seen before. */
-
-void
-ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
-{
-#if FFEGLOBAL_ENABLED
- ffename n;
- ffeglobal g;
-
- n = ffename_find (ffeglobal_filewide_, t);
- g = ffename_global (n);
- if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
- return;
-
- if ((g != NULL)
- && ((g->type == FFEGLOBAL_typeMAIN)
- || (g->type == FFEGLOBAL_typeSUBR)
- || (g->type == FFEGLOBAL_typeFUNC)
- || (g->type == FFEGLOBAL_typeBDATA))
- && g->u.proc.defined)
- {
- /* This program unit has already been defined. */
- if (ffe_is_globals () || ffe_is_warn_globals ())
- {
- ffebad_start (ffe_is_globals ()
- ? FFEBAD_FILEWIDE_ALREADY_SEEN
- : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
- ffebad_string (ffelex_token_text (t));
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- g->type = FFEGLOBAL_typeANY;
- }
- else if ((g != NULL)
- && (g->type != FFEGLOBAL_typeNONE)
- && (g->type != FFEGLOBAL_typeEXT)
- && (g->type != type))
- {
- /* A reference to this program unit has been seen, but its
- context disagrees about the new definition regarding
- what kind of program unit it is. (E.g. `call foo' followed
- by `function foo'.) But `external foo' alone doesn't mean
- disagreement with either a function or subroutine, though
- g77 normally interprets it as a request to force-load
- a block data program unit by that name (to cope with libs). */
- if (ffe_is_globals () || ffe_is_warn_globals ())
- {
- ffebad_start (ffe_is_globals ()
- ? FFEBAD_FILEWIDE_DISAGREEMENT
- : FFEBAD_FILEWIDE_DISAGREEMENT_W);
- ffebad_string (ffelex_token_text (t));
- ffebad_string (ffeglobal_type_string_[type]);
- ffebad_string (ffeglobal_type_string_[g->type]);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- g->type = FFEGLOBAL_typeANY;
- }
- else
- {
- if (g == NULL)
- {
- g = ffeglobal_new_ (n);
- g->intrinsic = FALSE;
- g->u.proc.n_args = -1;
- g->u.proc.other_t = NULL;
- }
- else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
- && (g->type == FFEGLOBAL_typeFUNC)
- && ((ffesymbol_basictype (s) != g->u.proc.bt)
- || (ffesymbol_kindtype (s) != g->u.proc.kt)
- || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE)
- && (ffesymbol_size (s) != g->u.proc.sz))))
- {
- /* The previous reference and this new function definition
- disagree about the type of the function. I (Burley) think
- this rarely occurs, because when this code is reached,
- the type info doesn't appear to be filled in yet. */
- if (ffe_is_globals () || ffe_is_warn_globals ())
- {
- ffebad_start (ffe_is_globals ()
- ? FFEBAD_FILEWIDE_TYPE_MISMATCH
- : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
- ffebad_string (ffelex_token_text (t));
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- g->type = FFEGLOBAL_typeANY;
- return;
- }
- if (g->intrinsic
- && !g->explicit_intrinsic
- && ffe_is_warn_globals ())
- {
- /* This name, previously used as an intrinsic, now is known
- to also be a global procedure name. Warn, since the previous
- use as an intrinsic might have been intended to refer to
- this procedure. */
- ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
- ffebad_string (ffelex_token_text (t));
- ffebad_string ("global");
- ffebad_string ("intrinsic");
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- g->t = ffelex_token_use (t);
- if ((g->tick == 0)
- || (g->u.proc.bt == FFEINFO_basictypeNONE)
- || (g->u.proc.kt == FFEINFO_kindtypeNONE))
- {
- g->u.proc.bt = ffesymbol_basictype (s);
- g->u.proc.kt = ffesymbol_kindtype (s);
- g->u.proc.sz = ffesymbol_size (s);
- }
- /* If there's a known disagreement about the kind of program
- unit, then don't even bother tracking arglist argreement. */
- if ((g->tick != 0)
- && (g->type != type))
- g->u.proc.n_args = -1;
- g->tick = ffe_count_2;
- g->type = type;
- g->u.proc.defined = TRUE;
- }
-
- ffesymbol_set_global (s, g);
-#endif
-}
-
-/* ffeglobal_pad_common -- Check initial padding of common area
-
- ffesymbol s; // the common area
- ffetargetAlign pad; // the initial padding
- ffeglobal_pad_common(s,pad,ffesymbol_where_line(s),
- ffesymbol_where_column(s));
-
- In global-enabled mode, make sure the padding agrees with any existing
- padding established for the common area, otherwise complain.
- In global-disabled mode, warn about nonzero padding. */
-
-void
-ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
- ffewhereColumn wc)
-{
-#if FFEGLOBAL_ENABLED
- ffeglobal g;
-
- g = ffesymbol_global (s);
- if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
- return; /* Let someone else catch this! */
- if (g->type == FFEGLOBAL_typeANY)
- return;
-
- if (!g->u.common.have_pad)
- {
- g->u.common.have_pad = TRUE;
- g->u.common.pad = pad;
- g->u.common.pad_where_line = ffewhere_line_use (wl);
- g->u.common.pad_where_col = ffewhere_column_use (wc);
-
- if (pad != 0)
- {
- char padding[20];
-
- sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
- ffebad_start (FFEBAD_COMMON_INIT_PAD);
- ffebad_string (ffesymbol_text (s));
- ffebad_string (padding);
- ffebad_string ((pad == 1)
- ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
- ffebad_here (0, wl, wc);
- ffebad_finish ();
- }
- }
- else
- {
- if (g->u.common.pad != pad)
- {
- char padding_1[20];
- char padding_2[20];
-
- sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad);
- sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad);
- ffebad_start (FFEBAD_COMMON_DIFF_PAD);
- ffebad_string (ffesymbol_text (s));
- ffebad_string (padding_1);
- ffebad_here (0, wl, wc);
- ffebad_string (padding_2);
- ffebad_string ((pad == 1)
- ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
- ffebad_string ((g->u.common.pad == 1)
- ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
- ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col);
- ffebad_finish ();
- }
-
- if (g->u.common.pad < pad)
- {
- g->u.common.pad = pad;
- g->u.common.pad_where_line = ffewhere_line_use (wl);
- g->u.common.pad_where_col = ffewhere_column_use (wc);
- }
- }
-#endif
-}
-
-/* Collect info for a global's argument. */
-
-void
-ffeglobal_proc_def_arg (ffesymbol s, int argno, const char *name, ffeglobalArgSummary as,
- ffeinfoBasictype bt, ffeinfoKindtype kt,
- bool array)
-{
- ffeglobal g = ffesymbol_global (s);
- ffeglobalArgInfo_ ai;
-
- assert (g != NULL);
-
- if (g->type == FFEGLOBAL_typeANY)
- return;
-
- assert (g->u.proc.n_args >= 0);
-
- if (argno >= g->u.proc.n_args)
- return; /* Already complained about this discrepancy. */
-
- ai = &g->u.proc.arg_info[argno];
-
- /* Maybe warn about previous references. */
-
- if ((ai->t != NULL)
- && ffe_is_warn_globals ())
- {
- const char *refwhy = NULL;
- const char *defwhy = NULL;
- bool warn = FALSE;
-
- switch (as)
- {
- case FFEGLOBAL_argsummaryREF:
- if ((ai->as != FFEGLOBAL_argsummaryREF)
- && (ai->as != FFEGLOBAL_argsummaryNONE)
- && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
- || (ai->bt != FFEINFO_basictypeCHARACTER)
- || (ai->bt == bt)))
- {
- warn = TRUE;
- refwhy = "passed by reference";
- }
- break;
-
- case FFEGLOBAL_argsummaryDESCR:
- if ((ai->as != FFEGLOBAL_argsummaryDESCR)
- && (ai->as != FFEGLOBAL_argsummaryNONE)
- && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
- || (bt != FFEINFO_basictypeCHARACTER)
- || (ai->bt == bt)))
- {
- warn = TRUE;
- refwhy = "passed by descriptor";
- }
- break;
-
- case FFEGLOBAL_argsummaryPROC:
- if ((ai->as != FFEGLOBAL_argsummaryPROC)
- && (ai->as != FFEGLOBAL_argsummarySUBR)
- && (ai->as != FFEGLOBAL_argsummaryFUNC)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- warn = TRUE;
- refwhy = "a procedure";
- }
- break;
-
- case FFEGLOBAL_argsummarySUBR:
- if ((ai->as != FFEGLOBAL_argsummaryPROC)
- && (ai->as != FFEGLOBAL_argsummarySUBR)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- warn = TRUE;
- refwhy = "a subroutine";
- }
- break;
-
- case FFEGLOBAL_argsummaryFUNC:
- if ((ai->as != FFEGLOBAL_argsummaryPROC)
- && (ai->as != FFEGLOBAL_argsummaryFUNC)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- warn = TRUE;
- refwhy = "a function";
- }
- break;
-
- case FFEGLOBAL_argsummaryALTRTN:
- if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- warn = TRUE;
- refwhy = "an alternate-return label";
- }
- break;
-
- default:
- break;
- }
-
- if ((refwhy != NULL) && (defwhy == NULL))
- {
- /* Fill in the def info. */
-
- switch (ai->as)
- {
- case FFEGLOBAL_argsummaryNONE:
- defwhy = "omitted";
- break;
-
- case FFEGLOBAL_argsummaryVAL:
- defwhy = "passed by value";
- break;
-
- case FFEGLOBAL_argsummaryREF:
- defwhy = "passed by reference";
- break;
-
- case FFEGLOBAL_argsummaryDESCR:
- defwhy = "passed by descriptor";
- break;
-
- case FFEGLOBAL_argsummaryPROC:
- defwhy = "a procedure";
- break;
-
- case FFEGLOBAL_argsummarySUBR:
- defwhy = "a subroutine";
- break;
-
- case FFEGLOBAL_argsummaryFUNC:
- defwhy = "a function";
- break;
-
- case FFEGLOBAL_argsummaryALTRTN:
- defwhy = "an alternate-return label";
- break;
-
-#if 0
- case FFEGLOBAL_argsummaryPTR:
- defwhy = "a pointer";
- break;
-#endif
-
- default:
- defwhy = "???";
- break;
- }
- }
-
- if (!warn
- && (bt != FFEINFO_basictypeHOLLERITH)
- && (bt != FFEINFO_basictypeTYPELESS)
- && (bt != FFEINFO_basictypeNONE)
- && (ai->bt != FFEINFO_basictypeHOLLERITH)
- && (ai->bt != FFEINFO_basictypeTYPELESS)
- && (ai->bt != FFEINFO_basictypeNONE))
- {
- /* Check types. */
-
- if ((bt != ai->bt)
- && ((bt != FFEINFO_basictypeREAL)
- || (ai->bt != FFEINFO_basictypeCOMPLEX))
- && ((bt != FFEINFO_basictypeCOMPLEX)
- || (ai->bt != FFEINFO_basictypeREAL)))
- {
- warn = TRUE; /* We can cope with these differences. */
- refwhy = "one type";
- defwhy = "some other type";
- }
-
- if (!warn && (kt != ai->kt))
- {
- warn = TRUE;
- refwhy = "one precision";
- defwhy = "some other precision";
- }
- }
-
- if (warn)
- {
- char num[60];
-
- if (name == NULL)
- sprintf (&num[0], "%d", argno + 1);
- else
- {
- if (strlen (name) < 30)
- sprintf (&num[0], "%d (named `%s')", argno + 1, name);
- else
- sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name);
- }
- ffebad_start (FFEBAD_FILEWIDE_ARG_W);
- ffebad_string (ffesymbol_text (s));
- ffebad_string (num);
- ffebad_string (refwhy);
- ffebad_string (defwhy);
- ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t));
- ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
- ffebad_finish ();
- }
- }
-
- /* Define this argument. */
-
- if (ai->t != NULL)
- ffelex_token_kill (ai->t);
- if ((as != FFEGLOBAL_argsummaryPROC)
- || (ai->t == NULL))
- ai->as = as; /* Otherwise leave SUBR/FUNC info intact. */
- ai->t = ffelex_token_use (g->t);
- if (name == NULL)
- ai->name = NULL;
- else
- {
- ai->name = malloc_new_ks (malloc_pool_image (),
- "ffeglobalArgInfo_ name",
- strlen (name) + 1);
- strcpy (ai->name, name);
- }
- ai->bt = bt;
- ai->kt = kt;
- ai->array = array;
-}
-
-/* Collect info on #args a global accepts. */
-
-void
-ffeglobal_proc_def_nargs (ffesymbol s, int n_args)
-{
- ffeglobal g = ffesymbol_global (s);
-
- assert (g != NULL);
-
- if (g->type == FFEGLOBAL_typeANY)
- return;
-
- if (g->u.proc.n_args >= 0)
- {
- if (g->u.proc.n_args == n_args)
- return;
-
- if (ffe_is_warn_globals ())
- {
- ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
- ffebad_string (ffesymbol_text (s));
- if (g->u.proc.n_args > n_args)
- ffebad_string ("few");
- else
- ffebad_string ("many");
- ffebad_here (0, ffelex_token_where_line (g->u.proc.other_t),
- ffelex_token_where_column (g->u.proc.other_t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- }
-
- /* This is new info we can use in cross-checking future references
- and a possible future definition. */
-
- g->u.proc.n_args = n_args;
- g->u.proc.other_t = NULL; /* No other reference yet. */
-
- if (n_args == 0)
- {
- g->u.proc.arg_info = NULL;
- return;
- }
-
- g->u.proc.arg_info = malloc_new_ks (malloc_pool_image (),
- "ffeglobalArgInfo_",
- n_args * sizeof (g->u.proc.arg_info[0]));
- while (n_args-- > 0)
- g->u.proc.arg_info[n_args].t = NULL;
-}
-
-/* Verify that the info for a global's argument is valid. */
-
-bool
-ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
- ffeinfoBasictype bt, ffeinfoKindtype kt,
- bool array, ffelexToken t)
-{
- ffeglobal g = ffesymbol_global (s);
- ffeglobalArgInfo_ ai;
-
- assert (g != NULL);
-
- if (g->type == FFEGLOBAL_typeANY)
- return FALSE;
-
- assert (g->u.proc.n_args >= 0);
-
- if (argno >= g->u.proc.n_args)
- return TRUE; /* Already complained about this discrepancy. */
-
- ai = &g->u.proc.arg_info[argno];
-
- /* Warn about previous references. */
-
- if (ai->t != NULL)
- {
- const char *refwhy = NULL;
- const char *defwhy = NULL;
- bool fail = FALSE;
- bool warn = FALSE;
-
- switch (as)
- {
- case FFEGLOBAL_argsummaryNONE:
- if (g->u.proc.defined)
- {
- fail = TRUE;
- refwhy = "omitted";
- defwhy = "not optional";
- }
- break;
-
- case FFEGLOBAL_argsummaryVAL:
- if (ai->as != FFEGLOBAL_argsummaryVAL)
- {
- fail = TRUE;
- refwhy = "passed by value";
- }
- break;
-
- case FFEGLOBAL_argsummaryREF:
- if ((ai->as != FFEGLOBAL_argsummaryREF)
- && (ai->as != FFEGLOBAL_argsummaryNONE)
- && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
- || (ai->bt != FFEINFO_basictypeCHARACTER)
- || (ai->bt == bt)))
- {
- fail = TRUE;
- refwhy = "passed by reference";
- }
- break;
-
- case FFEGLOBAL_argsummaryDESCR:
- if ((ai->as != FFEGLOBAL_argsummaryDESCR)
- && (ai->as != FFEGLOBAL_argsummaryNONE)
- && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
- || (bt != FFEINFO_basictypeCHARACTER)
- || (ai->bt == bt)))
- {
- fail = TRUE;
- refwhy = "passed by descriptor";
- }
- break;
-
- case FFEGLOBAL_argsummaryPROC:
- if ((ai->as != FFEGLOBAL_argsummaryPROC)
- && (ai->as != FFEGLOBAL_argsummarySUBR)
- && (ai->as != FFEGLOBAL_argsummaryFUNC)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- fail = TRUE;
- refwhy = "a procedure";
- }
- break;
-
- case FFEGLOBAL_argsummarySUBR:
- if ((ai->as != FFEGLOBAL_argsummaryPROC)
- && (ai->as != FFEGLOBAL_argsummarySUBR)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- fail = TRUE;
- refwhy = "a subroutine";
- }
- break;
-
- case FFEGLOBAL_argsummaryFUNC:
- if ((ai->as != FFEGLOBAL_argsummaryPROC)
- && (ai->as != FFEGLOBAL_argsummaryFUNC)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- fail = TRUE;
- refwhy = "a function";
- }
- break;
-
- case FFEGLOBAL_argsummaryALTRTN:
- if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- fail = TRUE;
- refwhy = "an alternate-return label";
- }
- break;
-
-#if 0
- case FFEGLOBAL_argsummaryPTR:
- if ((ai->as != FFEGLOBAL_argsummaryPTR)
- && (ai->as != FFEGLOBAL_argsummaryNONE))
- {
- fail = TRUE;
- refwhy = "a pointer";
- }
- break;
-#endif
-
- default:
- break;
- }
-
- if ((refwhy != NULL) && (defwhy == NULL))
- {
- /* Fill in the def info. */
-
- switch (ai->as)
- {
- case FFEGLOBAL_argsummaryNONE:
- defwhy = "omitted";
- break;
-
- case FFEGLOBAL_argsummaryVAL:
- defwhy = "passed by value";
- break;
-
- case FFEGLOBAL_argsummaryREF:
- defwhy = "passed by reference";
- break;
-
- case FFEGLOBAL_argsummaryDESCR:
- defwhy = "passed by descriptor";
- break;
-
- case FFEGLOBAL_argsummaryPROC:
- defwhy = "a procedure";
- break;
-
- case FFEGLOBAL_argsummarySUBR:
- defwhy = "a subroutine";
- break;
-
- case FFEGLOBAL_argsummaryFUNC:
- defwhy = "a function";
- break;
-
- case FFEGLOBAL_argsummaryALTRTN:
- defwhy = "an alternate-return label";
- break;
-
-#if 0
- case FFEGLOBAL_argsummaryPTR:
- defwhy = "a pointer";
- break;
-#endif
-
- default:
- defwhy = "???";
- break;
- }
- }
-
- if (!fail && !warn
- && (bt != FFEINFO_basictypeHOLLERITH)
- && (bt != FFEINFO_basictypeTYPELESS)
- && (bt != FFEINFO_basictypeNONE)
- && (ai->bt != FFEINFO_basictypeHOLLERITH)
- && (ai->bt != FFEINFO_basictypeNONE)
- && (ai->bt != FFEINFO_basictypeTYPELESS))
- {
- /* Check types. */
-
- if ((bt != ai->bt)
- && ((bt != FFEINFO_basictypeREAL)
- || (ai->bt != FFEINFO_basictypeCOMPLEX))
- && ((bt != FFEINFO_basictypeCOMPLEX)
- || (ai->bt != FFEINFO_basictypeREAL)))
- {
- if (((bt == FFEINFO_basictypeINTEGER)
- && (ai->bt == FFEINFO_basictypeLOGICAL))
- || ((bt == FFEINFO_basictypeLOGICAL)
- && (ai->bt == FFEINFO_basictypeINTEGER)))
- warn = TRUE; /* We can cope with these differences. */
- else
- fail = TRUE;
- refwhy = "one type";
- defwhy = "some other type";
- }
-
- if (!fail && !warn && (kt != ai->kt))
- {
- fail = TRUE;
- refwhy = "one precision";
- defwhy = "some other precision";
- }
- }
-
- if (fail && ! g->u.proc.defined)
- {
- /* No point failing if we're worried only about invocations. */
- fail = FALSE;
- warn = TRUE;
- }
-
- if (fail && ! ffe_is_globals ())
- {
- warn = TRUE;
- fail = FALSE;
- }
-
- if (fail || (warn && ffe_is_warn_globals ()))
- {
- char num[60];
-
- if (ai->name == NULL)
- sprintf (&num[0], "%d", argno + 1);
- else
- {
- if (strlen (ai->name) < 30)
- sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name);
- else
- sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name);
- }
- ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W);
- ffebad_string (ffesymbol_text (s));
- ffebad_string (num);
- ffebad_string (refwhy);
- ffebad_string (defwhy);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
- ffebad_finish ();
- return (fail ? FALSE : TRUE);
- }
-
- if (warn)
- return TRUE;
- }
-
- /* Define this argument. */
-
- if (ai->t != NULL)
- ffelex_token_kill (ai->t);
- if ((as != FFEGLOBAL_argsummaryPROC)
- || (ai->t == NULL))
- ai->as = as;
- ai->t = ffelex_token_use (g->t);
- ai->name = NULL;
- ai->bt = bt;
- ai->kt = kt;
- ai->array = array;
- return TRUE;
-}
-
-bool
-ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t)
-{
- ffeglobal g = ffesymbol_global (s);
-
- assert (g != NULL);
-
- if (g->type == FFEGLOBAL_typeANY)
- return FALSE;
-
- if (g->u.proc.n_args >= 0)
- {
- if (g->u.proc.n_args == n_args)
- return TRUE;
-
- if (g->u.proc.defined && ffe_is_globals ())
- {
- ffebad_start (FFEBAD_FILEWIDE_NARGS);
- ffebad_string (ffesymbol_text (s));
- if (g->u.proc.n_args > n_args)
- ffebad_string ("few");
- else
- ffebad_string ("many");
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- return FALSE;
- }
-
- if (ffe_is_warn_globals ())
- {
- ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
- ffebad_string (ffesymbol_text (s));
- if (g->u.proc.n_args > n_args)
- ffebad_string ("few");
- else
- ffebad_string ("many");
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
-
- return TRUE; /* Don't replace the info we already have. */
- }
-
- /* This is new info we can use in cross-checking future references
- and a possible future definition. */
-
- g->u.proc.n_args = n_args;
- g->u.proc.other_t = ffelex_token_use (t);
-
- /* Make this "the" place we found the global, since it has the most info. */
-
- if (g->t != NULL)
- ffelex_token_kill (g->t);
- g->t = ffelex_token_use (t);
-
- if (n_args == 0)
- {
- g->u.proc.arg_info = NULL;
- return TRUE;
- }
-
- g->u.proc.arg_info = malloc_new_ks (malloc_pool_image (),
- "ffeglobalArgInfo_",
- n_args * sizeof (g->u.proc.arg_info[0]));
- while (n_args-- > 0)
- g->u.proc.arg_info[n_args].t = NULL;
-
- return TRUE;
-}
-
-/* Return a global for a promoted symbol (one that has heretofore
- been assumed to be local, but since discovered to be global). */
-
-ffeglobal
-ffeglobal_promoted (ffesymbol s)
-{
-#if FFEGLOBAL_ENABLED
- ffename n;
- ffeglobal g;
-
- assert (ffesymbol_global (s) == NULL);
-
- n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s)));
- g = ffename_global (n);
-
- return g;
-#else
- return NULL;
-#endif
-}
-
-/* Register a reference to an intrinsic. Such a reference is always
- valid, though a warning might be in order if the same name has
- already been used for a global. */
-
-void
-ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit)
-{
-#if FFEGLOBAL_ENABLED
- ffename n;
- ffeglobal g;
-
- if (ffesymbol_global (s) == NULL)
- {
- n = ffename_find (ffeglobal_filewide_, t);
- g = ffename_global (n);
- }
- else
- {
- g = ffesymbol_global (s);
- n = NULL;
- }
-
- if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
- return;
-
- if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
- {
- if (! explicit
- && ! g->intrinsic
- && ffe_is_warn_globals ())
- {
- /* This name, previously used as a global, now is used
- for an intrinsic. Warn, since this new use as an
- intrinsic might have been intended to refer to
- the global procedure. */
- ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
- ffebad_string (ffelex_token_text (t));
- ffebad_string ("intrinsic");
- ffebad_string ("global");
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- }
- else
- {
- if (g == NULL)
- {
- g = ffeglobal_new_ (n);
- g->tick = ffe_count_2;
- g->type = FFEGLOBAL_typeNONE;
- g->intrinsic = TRUE;
- g->explicit_intrinsic = explicit;
- g->t = ffelex_token_use (t);
- }
- else if (g->intrinsic
- && (explicit != g->explicit_intrinsic)
- && (g->tick != ffe_count_2)
- && ffe_is_warn_globals ())
- {
- /* An earlier reference to this intrinsic disagrees with
- this reference vis-a-vis explicit `intrinsic foo',
- which suggests that the one relying on implicit
- intrinsicacity might have actually intended to refer
- to a global of the same name. */
- ffebad_start (FFEBAD_INTRINSIC_EXPIMP);
- ffebad_string (ffelex_token_text (t));
- ffebad_string (explicit ? "explicit" : "implicit");
- ffebad_string (explicit ? "implicit" : "explicit");
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
- }
-
- g->intrinsic = TRUE;
- if (explicit)
- g->explicit_intrinsic = TRUE;
-
- ffesymbol_set_global (s, g);
-#endif
-}
-
-/* Register a reference to a global. Returns TRUE if the reference
- is valid. */
-
-bool
-ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
-{
-#if FFEGLOBAL_ENABLED
- ffename n = NULL;
- ffeglobal g;
-
- /* It is never really _known_ that an EXTERNAL statement
- names a BLOCK DATA by just looking at the program unit,
- so override a different notion here. */
- if (type == FFEGLOBAL_typeBDATA)
- type = FFEGLOBAL_typeEXT;
-
- g = ffesymbol_global (s);
- if (g == NULL)
- {
- n = ffename_find (ffeglobal_filewide_, t);
- g = ffename_global (n);
- if (g != NULL)
- ffesymbol_set_global (s, g);
- }
-
- if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
- return TRUE;
-
- if ((g != NULL)
- && (g->type != FFEGLOBAL_typeNONE)
- && (g->type != FFEGLOBAL_typeEXT)
- && (g->type != type)
- && (type != FFEGLOBAL_typeEXT))
- {
- /* Disagreement about (fully refined) class of program unit
- (main, subroutine, function, block data). Treat EXTERNAL/
- COMMON disagreements distinctly. */
- if ((((type == FFEGLOBAL_typeBDATA)
- && (g->type != FFEGLOBAL_typeCOMMON))
- || ((g->type == FFEGLOBAL_typeBDATA)
- && (type != FFEGLOBAL_typeCOMMON)
- && ! g->u.proc.defined)))
- {
-#if 0 /* This is likely to just annoy people. */
- if (ffe_is_warn_globals ())
- {
- /* Warn about EXTERNAL of a COMMON name, though it works. */
- ffebad_start (FFEBAD_FILEWIDE_TIFF);
- ffebad_string (ffelex_token_text (t));
- ffebad_string (ffeglobal_type_string_[type]);
- ffebad_string (ffeglobal_type_string_[g->type]);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
-#endif
- }
- else if (ffe_is_globals () || ffe_is_warn_globals ())
- {
- ffebad_start (ffe_is_globals ()
- ? FFEBAD_FILEWIDE_DISAGREEMENT
- : FFEBAD_FILEWIDE_DISAGREEMENT_W);
- ffebad_string (ffelex_token_text (t));
- ffebad_string (ffeglobal_type_string_[type]);
- ffebad_string (ffeglobal_type_string_[g->type]);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- g->type = FFEGLOBAL_typeANY;
- return (! ffe_is_globals ());
- }
- }
-
- if ((g != NULL)
- && (type == FFEGLOBAL_typeFUNC))
- {
- /* If just filling in this function's type, do so. */
- if ((g->tick == ffe_count_2)
- && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
- && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE))
- {
- g->u.proc.bt = ffesymbol_basictype (s);
- g->u.proc.kt = ffesymbol_kindtype (s);
- g->u.proc.sz = ffesymbol_size (s);
- }
- /* Make sure there is type agreement. */
- if (g->type == FFEGLOBAL_typeFUNC
- && g->u.proc.bt != FFEINFO_basictypeNONE
- && ffesymbol_basictype (s) != FFEINFO_basictypeNONE
- && (ffesymbol_basictype (s) != g->u.proc.bt
- || ffesymbol_kindtype (s) != g->u.proc.kt
- /* CHARACTER*n disagreements matter only once a
- definition is involved, since the definition might
- be CHARACTER*(*), which accepts all references. */
- || (g->u.proc.defined
- && ffesymbol_size (s) != g->u.proc.sz
- && ffesymbol_size (s) != FFETARGET_charactersizeNONE
- && g->u.proc.sz != FFETARGET_charactersizeNONE)))
- {
- int error;
-
- /* Type mismatch between function reference/definition and
- this subsequent reference (which might just be the filling-in
- of type info for the definition, but we can't reach here
- if that's the case and there was a previous definition).
-
- It's an error given a previous definition, since that
- implies inlining can crash the compiler, unless the user
- asked for no such inlining. */
- error = (g->tick != ffe_count_2
- && g->u.proc.defined
- && ffe_is_globals ());
- if (error || ffe_is_warn_globals ())
- {
- ffebad_start (error
- ? FFEBAD_FILEWIDE_TYPE_MISMATCH
- : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
- ffebad_string (ffelex_token_text (t));
- if (g->tick == ffe_count_2)
- {
- /* Current reference fills in type info for definition.
- The current token doesn't necessarily point to the actual
- definition of the function, so use the definition pointer
- and the pointer to the pre-definition type info. */
- ffebad_here (0, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t),
- ffelex_token_where_column (g->u.proc.other_t));
- }
- else
- {
- /* Current reference is not a filling-in of a current
- definition. The current token is fine, as is
- the previous-mention token. */
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- }
- ffebad_finish ();
- if (error)
- g->type = FFEGLOBAL_typeANY;
- return FALSE;
- }
- }
- }
-
- if (g == NULL)
- {
- g = ffeglobal_new_ (n);
- g->t = ffelex_token_use (t);
- g->tick = ffe_count_2;
- g->intrinsic = FALSE;
- g->type = type;
- g->u.proc.defined = FALSE;
- g->u.proc.bt = ffesymbol_basictype (s);
- g->u.proc.kt = ffesymbol_kindtype (s);
- g->u.proc.sz = ffesymbol_size (s);
- g->u.proc.n_args = -1;
- ffesymbol_set_global (s, g);
- }
- else if (g->intrinsic
- && !g->explicit_intrinsic
- && (g->tick != ffe_count_2)
- && ffe_is_warn_globals ())
- {
- /* Now known as a global, this name previously was seen as an
- intrinsic. Warn, in case the previous reference was intended
- for the same global. */
- ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
- ffebad_string (ffelex_token_text (t));
- ffebad_string ("global");
- ffebad_string ("intrinsic");
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_finish ();
- }
-
- if ((g->type != type)
- && (type != FFEGLOBAL_typeEXT))
- {
- /* We've learned more, so point to where we learned it. */
- g->t = ffelex_token_use (t);
- g->type = type;
- g->hook = FFECOM_globalNULL; /* Discard previous _DECL. */
- g->u.proc.n_args = -1;
- }
-
- return TRUE;
-#endif
-}
-
-/* ffeglobal_save_common -- Check SAVE status of common area
-
- ffesymbol s; // the common area
- bool save; // TRUE if SAVEd, FALSE otherwise
- ffeglobal_save_common(s,save,ffesymbol_where_line(s),
- ffesymbol_where_column(s));
-
- In global-enabled mode, make sure the save info agrees with any existing
- info established for the common area, otherwise complain.
- In global-disabled mode, do nothing. */
-
-void
-ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
- ffewhereColumn wc)
-{
-#if FFEGLOBAL_ENABLED
- ffeglobal g;
-
- g = ffesymbol_global (s);
- if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
- return; /* Let someone else catch this! */
- if (g->type == FFEGLOBAL_typeANY)
- return;
-
- if (!g->u.common.have_save)
- {
- g->u.common.have_save = TRUE;
- g->u.common.save = save;
- g->u.common.save_where_line = ffewhere_line_use (wl);
- g->u.common.save_where_col = ffewhere_column_use (wc);
- }
- else
- {
- if ((g->u.common.save != save) && ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_COMMON_DIFF_SAVE);
- ffebad_string (ffesymbol_text (s));
- ffebad_here (save ? 0 : 1, wl, wc);
- ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col);
- ffebad_finish ();
- }
- }
-#endif
-}
-
-/* ffeglobal_size_common -- Establish size of COMMON area
-
- ffesymbol s; // the common area
- ffetargetOffset size; // size in units
- if (ffeglobal_size_common(s,size)) // new size is largest seen
-
- In global-enabled mode, set the size if it current size isn't known or is
- smaller than new size, and for non-blank common, complain if old size
- is different from new. Return TRUE if the new size is the largest seen
- for this COMMON area (or if no size was known for it previously).
- In global-disabled mode, do nothing. */
-
-#if FFEGLOBAL_ENABLED
-bool
-ffeglobal_size_common (ffesymbol s, ffetargetOffset size)
-{
- ffeglobal g;
-
- g = ffesymbol_global (s);
- if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
- return FALSE;
- if (g->type == FFEGLOBAL_typeANY)
- return FALSE;
-
- if (!g->u.common.have_size)
- {
- g->u.common.have_size = TRUE;
- g->u.common.size = size;
- return TRUE;
- }
-
- if ((g->tick > 0) && (g->tick < ffe_count_2)
- && (g->u.common.size < size))
- {
- char oldsize[40];
- char newsize[40];
-
- /* Common block initialized in a previous program unit, which
- effectively freezes its size, but now the program is trying
- to enlarge it. */
-
- sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
- sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
-
- ffebad_start (FFEBAD_COMMON_ENLARGED);
- ffebad_string (ffesymbol_text (s));
- ffebad_string (oldsize);
- ffebad_string (newsize);
- ffebad_string ((g->u.common.size == 1)
- ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
- ffebad_string ((size == 1)
- ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
- ffebad_here (0, ffelex_token_where_line (g->u.common.initt),
- ffelex_token_where_column (g->u.common.initt));
- ffebad_here (1, ffesymbol_where_line (s),
- ffesymbol_where_column (s));
- ffebad_finish ();
- }
- else if ((g->u.common.size != size) && !g->u.common.blank)
- {
- char oldsize[40];
- char newsize[40];
-
- /* Warn about this even if not -pedantic, because putting all
- program units in a single source file is the only way to
- detect this. Apparently UNIX-model linkers neither handle
- nor report when they make a common unit smaller than
- requested, such as when the smaller-declared version is
- initialized and the larger-declared version is not. So
- if people complain about strange overwriting, we can tell
- them to put all their code in a single file and compile
- that way. Warnings about differing sizes must therefore
- always be issued. */
-
- sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
- sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
-
- ffebad_start (FFEBAD_COMMON_DIFF_SIZE);
- ffebad_string (ffesymbol_text (s));
- ffebad_string (oldsize);
- ffebad_string (newsize);
- ffebad_string ((g->u.common.size == 1)
- ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
- ffebad_string ((size == 1)
- ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
- ffebad_here (0, ffelex_token_where_line (g->t),
- ffelex_token_where_column (g->t));
- ffebad_here (1, ffesymbol_where_line (s),
- ffesymbol_where_column (s));
- ffebad_finish ();
- }
-
- if (size > g->u.common.size)
- {
- g->u.common.size = size;
- return TRUE;
- }
-
- return FALSE;
-}
-
-#endif
-void
-ffeglobal_terminate_1 (void)
-{
-}
+++ /dev/null
-/* global.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- global.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_GLOBAL_H
-#define GCC_F_GLOBAL_H
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFEGLOBAL_typeNONE,
- FFEGLOBAL_typeMAIN,
- FFEGLOBAL_typeEXT, /* EXTERNAL is all we know. */
- FFEGLOBAL_typeSUBR,
- FFEGLOBAL_typeFUNC,
- FFEGLOBAL_typeBDATA,
- FFEGLOBAL_typeCOMMON,
- FFEGLOBAL_typeANY, /* Confusion reigns, so just ignore. */
- FFEGLOBAL_type
- } ffeglobalType;
-
-typedef enum
- {
- FFEGLOBAL_argsummaryNONE, /* No arg present. */
- FFEGLOBAL_argsummaryVAL, /* Pass-by-value. */
- FFEGLOBAL_argsummaryREF, /* Pass-by-reference. */
- FFEGLOBAL_argsummaryDESCR, /* Pass-by-descriptor. */
- FFEGLOBAL_argsummaryPROC, /* Procedure (intrinsic, external). */
- FFEGLOBAL_argsummarySUBR, /* Subroutine (intrinsic, external). */
- FFEGLOBAL_argsummaryFUNC, /* Function (intrinsic, external). */
- FFEGLOBAL_argsummaryALTRTN, /* Alternate-return (label). */
- FFEGLOBAL_argsummaryANY,
- FFEGLOBAL_argsummary
- } ffeglobalArgSummary;
-
-/* Typedefs. */
-
-typedef struct _ffeglobal_arginfo_ *ffeglobalArgInfo_;
-typedef struct _ffeglobal_ *ffeglobal;
-
-/* Include files needed by this one. */
-
-#include "info.h"
-#include "lex.h"
-#include "name.h"
-#include "symbol.h"
-#include "target.h"
-#include "top.h"
-
-/* Structure definitions. */
-
-struct _ffeglobal_arginfo_
-{
- ffelexToken t; /* Different from master token when difference is important. */
- char *name; /* Name of dummy arg, or NULL if not yet known. */
- ffeglobalArgSummary as;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- bool array;
-};
-
-struct _ffeglobal_
-{
- ffelexToken t;
- ffename n;
- ffecomGlobal hook;
- ffeCounter tick; /* Recent transition in this progunit. */
- ffeglobalType type;
- bool intrinsic; /* Known as intrinsic? */
- bool explicit_intrinsic; /* Explicit intrinsic? */
- union {
- struct {
- ffelexToken initt; /* First initial value. */
- bool have_pad; /* Padding info avail for COMMON? */
- ffetargetAlign pad; /* Initial padding for COMMON. */
- ffewhereLine pad_where_line;
- ffewhereColumn pad_where_col;
- bool have_save; /* Save info avail for COMMON? */
- bool save; /* Save info for COMMON. */
- ffewhereLine save_where_line;
- ffewhereColumn save_where_col;
- bool have_size; /* Size info avail for COMMON? */
- ffetargetOffset size; /* Size info for COMMON. */
- bool blank; /* TRUE if blank COMMON. */
- } common;
- struct {
- bool defined; /* Seen actual code yet? */
- ffeinfoBasictype bt; /* NONE for non-function. */
- ffeinfoKindtype kt; /* NONE for non-function. */
- ffetargetCharacterSize sz;
- int n_args; /* 0 for main/blockdata. */
- ffelexToken other_t; /* Location of reference. */
- ffeglobalArgInfo_ arg_info; /* Info on each argument. */
- } proc;
- } u;
-};
-
-/* Global objects accessed by users of this module. */
-
-
-/* Declare functions with prototypes. */
-
-void ffeglobal_drive (ffeglobal (*fn) (ffeglobal));
-void ffeglobal_init_1 (void);
-void ffeglobal_init_common (ffesymbol s, ffelexToken t);
-void ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type);
-void ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank);
-void ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
- ffewhereColumn wc);
-void ffeglobal_proc_def_arg (ffesymbol s, int argno, const char *name, ffeglobalArgSummary as,
- ffeinfoBasictype bt, ffeinfoKindtype kt,
- bool array);
-void ffeglobal_proc_def_nargs (ffesymbol s, int n_args);
-bool ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
- ffeinfoBasictype bt, ffeinfoKindtype kt,
- bool array, ffelexToken t);
-bool ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t);
-ffeglobal ffeglobal_promoted (ffesymbol s);
-void ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit);
-bool ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type);
-void ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
- ffewhereColumn wc);
-bool ffeglobal_size_common (ffesymbol s, ffetargetOffset size);
-void ffeglobal_terminate_1 (void);
-
-/* Define macros. */
-
-#define FFEGLOBAL_ENABLED 1
-
-#define ffeglobal_common_init(g) ((g)->tick != 0)
-#define ffeglobal_common_have_pad(g) ((g)->u.common.have_pad)
-#define ffeglobal_common_have_size(g) ((g)->u.common.have_size)
-#define ffeglobal_common_pad(g) ((g)->u.common.pad)
-#define ffeglobal_common_size(g) ((g)->u.common.size)
-#define ffeglobal_hook(g) ((g)->hook)
-#define ffeglobal_init_0()
-#define ffeglobal_init_2()
-#define ffeglobal_init_3()
-#define ffeglobal_init_4()
-#define ffeglobal_new_blockdata(s,t) \
- ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeBDATA)
-#define ffeglobal_new_function(s,t) \
- ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeFUNC)
-#define ffeglobal_new_program(s,t) \
- ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeMAIN)
-#define ffeglobal_new_subroutine(s,t) \
- ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeSUBR)
-#define ffeglobal_ref_blockdata(s,t) \
- ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeBDATA)
-#define ffeglobal_ref_external(s,t) \
- ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeEXT)
-#define ffeglobal_ref_function(s,t) \
- ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeFUNC)
-#define ffeglobal_ref_subroutine(s,t) \
- ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeSUBR)
-#define ffeglobal_set_hook(g,h) ((g)->hook = (h))
-#define ffeglobal_terminate_0()
-#define ffeglobal_terminate_2()
-#define ffeglobal_terminate_3()
-#define ffeglobal_terminate_4()
-#define ffeglobal_text(g) ffename_text((g)->n)
-#define ffeglobal_type(g) ((g)->type)
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_GLOBAL_H */
-
+++ /dev/null
-/* implic.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None.
-
- Description:
- The GNU Fortran Front End.
-
- Modifications:
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "implic.h"
-#include "info.h"
-#include "src.h"
-#include "symbol.h"
-#include "target.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFEIMPLIC_stateINITIAL_,
- FFEIMPLIC_stateASSUMED_,
- FFEIMPLIC_stateESTABLISHED_,
- FFEIMPLIC_state
- } ffeimplicState_;
-
-/* Internal typedefs. */
-
-typedef struct _ffeimplic_ *ffeimplic_;
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-struct _ffeimplic_
- {
- ffeimplicState_ state;
- ffeinfo info;
- };
-
-/* Static objects accessed by functions in this module. */
-
-/* NOTE: This is definitely ASCII-specific!! */
-
-static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1];
-
-/* Static functions (internal). */
-
-static ffeimplic_ ffeimplic_lookup_ (unsigned char c);
-
-/* Internal macros. */
-\f
-
-/* ffeimplic_lookup_ -- Look up implicit descriptor for initial character
-
- ffeimplic_ imp;
- if ((imp = ffeimplic_lookup_('A')) == NULL)
- // error
-
- Returns a pointer to an implicit descriptor block based on the character
- passed, or NULL if it is not a valid initial character for an implicit
- data type. */
-
-static ffeimplic_
-ffeimplic_lookup_ (unsigned char c)
-{
- /* NOTE: This is definitely ASCII-specific!! */
- if (ISIDST (c))
- return &ffeimplic_table_[c - 'A'];
- return NULL;
-}
-
-/* ffeimplic_establish_initial -- Establish type of implicit initial letter
-
- ffesymbol s;
- if (!ffeimplic_establish_initial(s))
- // error
-
- Assigns implicit type information to the symbol based on the first
- character of the symbol's name. */
-
-bool
-ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
- ffeinfoKindtype kind_type, ffetargetCharacterSize size)
-{
- ffeimplic_ imp;
-
- imp = ffeimplic_lookup_ (c);
- if (imp == NULL)
- return FALSE; /* Character not A-Z or some such thing. */
- if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
- return FALSE; /* IMPLICIT NONE in effect here. */
-
- switch (imp->state)
- {
- case FFEIMPLIC_stateINITIAL_:
- imp->info = ffeinfo_new (basic_type,
- kind_type,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- size);
- imp->state = FFEIMPLIC_stateESTABLISHED_;
- return TRUE;
-
- case FFEIMPLIC_stateASSUMED_:
- if ((ffeinfo_basictype (imp->info) != basic_type)
- || (ffeinfo_kindtype (imp->info) != kind_type)
- || (ffeinfo_size (imp->info) != size))
- return FALSE;
- imp->state = FFEIMPLIC_stateESTABLISHED_;
- return TRUE;
-
- case FFEIMPLIC_stateESTABLISHED_:
- return FALSE;
-
- default:
- assert ("Weird state for implicit object" == NULL);
- return FALSE;
- }
-}
-
-/* ffeimplic_establish_symbol -- Establish implicit type of a symbol
-
- ffesymbol s;
- if (!ffeimplic_establish_symbol(s))
- // error
-
- Assigns implicit type information to the symbol based on the first
- character of the symbol's name.
-
- If symbol already has a type, return TRUE.
- Get first character of symbol's name.
- Get ffeimplic_ object for it (return FALSE if NULL returned).
- Return FALSE if object has no assigned type (IMPLICIT NONE).
- Copy the type information from the object to the symbol.
- If the object is state "INITIAL", set to state "ASSUMED" so no
- subsequent IMPLICIT statement may change the state.
- Return TRUE. */
-
-bool
-ffeimplic_establish_symbol (ffesymbol s)
-{
- char c;
- ffeimplic_ imp;
-
- if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
- return TRUE;
-
- c = *(ffesymbol_text (s));
- imp = ffeimplic_lookup_ (c);
- if (imp == NULL)
- return FALSE; /* First character not A-Z or some such
- thing. */
- if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
- return FALSE; /* IMPLICIT NONE in effect here. */
-
- ffesymbol_signal_change (s); /* Gonna change, save existing? */
-
- /* Establish basictype, kindtype, size; preserve rank, kind, where. */
-
- ffesymbol_set_info (s,
- ffeinfo_new (ffeinfo_basictype (imp->info),
- ffeinfo_kindtype (imp->info),
- ffesymbol_rank (s),
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffeinfo_size (imp->info)));
-
- if (imp->state == FFEIMPLIC_stateINITIAL_)
- imp->state = FFEIMPLIC_stateASSUMED_;
-
- if (ffe_is_warn_implicit ())
- {
- /* xgettext:no-c-format */
- ffebad_start_msg ("Implicit declaration of `%A' at %0",
- FFEBAD_severityWARNING);
- ffebad_here (0, ffesymbol_where_line (s),
- ffesymbol_where_column (s));
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- }
-
- return TRUE;
-}
-
-/* ffeimplic_init_2 -- Initialize table
-
- ffeimplic_init_2();
-
- Assigns initial type information to all initial letters.
-
- Allows for holes in the sequence of letters (i.e. EBCDIC). */
-
-void
-ffeimplic_init_2 (void)
-{
- ffeimplic_ imp;
- char c;
-
- for (c = 'A'; c <= 'z'; ++c)
- {
- imp = &ffeimplic_table_[c - 'A'];
- imp->state = FFEIMPLIC_stateINITIAL_;
- switch (c)
- {
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- imp->info = ffeinfo_new (FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREALDEFAULT,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE);
- break;
-
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE);
- break;
-
- default:
- imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0,
- FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE);
- break;
- }
- }
-}
-
-/* ffeimplic_none -- Implement IMPLICIT NONE statement
-
- ffeimplic_none();
-
- Assigns null type information to all initial letters. */
-
-void
-ffeimplic_none (void)
-{
- ffeimplic_ imp;
-
- for (imp = &ffeimplic_table_[0];
- imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)];
- imp++)
- {
- imp->info = ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE);
- }
-}
-
-/* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol
-
- ffesymbol s;
- const char *name; // name for s in case it is NULL, or NULL if s never NULL
- if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER)
- // is or will be a CHARACTER-typed name
-
- Like establish_symbol, but doesn't change anything.
-
- If symbol is non-NULL and already has a type, return it.
- Get first character of symbol's name or from name arg if symbol is NULL.
- Get ffeimplic_ object for it (return FALSE if NULL returned).
- Return NONE if object has no assigned type (IMPLICIT NONE).
- Return the data type indicated in the object.
-
- 24-Oct-91 JCB 2.0
- Take a char * instead of ffelexToken, since the latter isn't always
- needed anyway (as when ffecom calls it). */
-
-ffeinfoBasictype
-ffeimplic_peek_symbol_type (ffesymbol s, const char *name)
-{
- char c;
- ffeimplic_ imp;
-
- if (s == NULL)
- c = *name;
- else
- {
- if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
- return ffesymbol_basictype (s);
-
- c = *(ffesymbol_text (s));
- }
-
- imp = ffeimplic_lookup_ (c);
- if (imp == NULL)
- return FFEINFO_basictypeNONE; /* First character not A-Z or
- something. */
- return ffeinfo_basictype (imp->info);
-}
-
-/* ffeimplic_terminate_2 -- Terminate table
-
- ffeimplic_terminate_2();
-
- Kills info object for each entry in table. */
-
-void
-ffeimplic_terminate_2 (void)
-{
-}
+++ /dev/null
-/* implic.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- implic.c
-
- Modifications:
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_IMPLIC_H
-#define GCC_F_IMPLIC_H
-
-/* Simple definitions and enumerations. */
-
-
-/* Typedefs. */
-
-
-/* Include files needed by this one. */
-
-#include "info.h"
-#include "symbol.h"
-#include "target.h"
-
-/* Structure definitions. */
-
-
-/* Global objects accessed by users of this module. */
-
-
-/* Declare functions with prototypes. */
-
-bool ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
- ffeinfoKindtype kind_type, ffetargetCharacterSize size);
-bool ffeimplic_establish_symbol (ffesymbol s);
-void ffeimplic_init_2 (void);
-void ffeimplic_none (void);
-ffeinfoBasictype ffeimplic_peek_symbol_type (ffesymbol s, const char *name);
-void ffeimplic_terminate_2 (void);
-
-/* Define macros. */
-
-#define ffeimplic_init_0()
-#define ffeimplic_init_1()
-#define ffeimplic_init_3()
-#define ffeimplic_init_4()
-#define ffeimplic_terminate_0()
-#define ffeimplic_terminate_1()
-#define ffeimplic_terminate_3()
-#define ffeimplic_terminate_4()
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_IMPLIC_H */
+++ /dev/null
-/* info-b.def -- Public #include File (module.h template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- info.c
-
- Modifications:
-*/
-
-FFEINFO_BASICTYPE (FFEINFO_basictypeNONE, "None", "")
-FFEINFO_BASICTYPE (FFEINFO_basictypeINTEGER, "INTEGER", "i")
-FFEINFO_BASICTYPE (FFEINFO_basictypeLOGICAL, "LOGICAL", "l")
-FFEINFO_BASICTYPE (FFEINFO_basictypeREAL, "REAL", "r")
-FFEINFO_BASICTYPE (FFEINFO_basictypeCOMPLEX, "COMPLEX", "c")
-FFEINFO_BASICTYPE (FFEINFO_basictypeCHARACTER, "CHARACTER", "a")
-FFEINFO_BASICTYPE (FFEINFO_basictypeHOLLERITH, "Hollerith", "h")
-FFEINFO_BASICTYPE (FFEINFO_basictypeTYPELESS, "Typeless", "t")
-FFEINFO_BASICTYPE (FFEINFO_basictypeANY, "Any", "~")
+++ /dev/null
-/* info-k.def -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 2002 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- info.c
-
- Modifications:
-*/
-
-#
-/* Kind messages are used in diagnostic location reports of the
- form "<file>: In function `foo': <error message>". */
-
-FFEINFO_KIND (FFEINFO_kindNONE, "In unknown kind", "")
-FFEINFO_KIND (FFEINFO_kindENTITY, "In entity", "e")
-FFEINFO_KIND (FFEINFO_kindFUNCTION, "In function", "f")
-FFEINFO_KIND (FFEINFO_kindSUBROUTINE, "In subroutine", "u")
-FFEINFO_KIND (FFEINFO_kindPROGRAM, "In program", "p")
-FFEINFO_KIND (FFEINFO_kindBLOCKDATA, "In block-data unit", "b")
-FFEINFO_KIND (FFEINFO_kindCOMMON, "In common block", "c")
-FFEINFO_KIND (FFEINFO_kindCONSTRUCT, "In construct", ":")
-FFEINFO_KIND (FFEINFO_kindNAMELIST, "In namelist", "n")
-FFEINFO_KIND (FFEINFO_kindANY, "In anything", "~")
+++ /dev/null
-/* info-w.def -- Public #include File (module.h template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- info.c
-
- Modifications:
-*/
-
-FFEINFO_WHERE (FFEINFO_whereNONE, "None", "")
-FFEINFO_WHERE (FFEINFO_whereLOCAL, "Local", "l") /* Defined locally. */
-FFEINFO_WHERE (FFEINFO_whereCOMMON, "Common", "c") /* In a common area. */
-FFEINFO_WHERE (FFEINFO_whereDUMMY, "Dummy", "d") /* A dummy argument. */
-FFEINFO_WHERE (FFEINFO_whereGLOBAL, "Global", "g") /* Reference to external global like FUNCTION, SUBR. */
-FFEINFO_WHERE (FFEINFO_whereRESULT, "Result", "r") /* Result of this function. */
-FFEINFO_WHERE (FFEINFO_whereFLEETING, "Fleeting", "f") /* Result of "X*Y", "FUNCREF(5,1.3)", "ARRAY(X)", etc. */
-FFEINFO_WHERE (FFEINFO_whereFLEETING_CADDR, "Fleet-Const", "fp") /* "A(3)", "CHARS(4:5)". */
-FFEINFO_WHERE (FFEINFO_whereFLEETING_IADDR, "Fleet-Immed", "fi") /* A(IX) in "DATA (A(IX),IX=1,100)/.../". */
-FFEINFO_WHERE (FFEINFO_whereIMMEDIATE, "Immediate", "i") /* IX in "DATA (A(IX),IX=1,100)/.../". */
-FFEINFO_WHERE (FFEINFO_whereINTRINSIC, "Intrinsic", "b")
-FFEINFO_WHERE (FFEINFO_whereCONSTANT, "Constant", "p") /* For kindFUNCTION, means statement function! */
-FFEINFO_WHERE (FFEINFO_whereCONSTANT_SUBOBJECT, "Const-subobj", "q") /* As in "'FOO'(I:J)". */
-FFEINFO_WHERE (FFEINFO_whereANY, "Any", "~")
+++ /dev/null
-/* info.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None
-
- Description:
- An abstraction for information maintained on a per-operator and per-
- operand basis in expression trees.
-
- Modifications:
- 30-Aug-90 JCB 2.0
- Extensive rewrite for new cleaner approach.
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "info.h"
-#include "target.h"
-#include "type.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-
-/* Static objects accessed by functions in this module. */
-
-static const char *const ffeinfo_basictype_string_[]
-=
-{
-#define FFEINFO_BASICTYPE(KWD,LNAM,SNAM) SNAM,
-#include "info-b.def"
-#undef FFEINFO_BASICTYPE
-};
-static const char *const ffeinfo_kind_message_[]
-=
-{
-#define FFEINFO_KIND(kwd,msgid,snam) msgid,
-#include "info-k.def"
-#undef FFEINFO_KIND
-};
-static const char *const ffeinfo_kind_string_[]
-=
-{
-#define FFEINFO_KIND(KWD,LNAM,SNAM) SNAM,
-#include "info-k.def"
-#undef FFEINFO_KIND
-};
-static ffeinfoBasictype ffeinfo_combine_[FFEINFO_basictype][FFEINFO_basictype];
-static const char *const ffeinfo_kindtype_string_[]
-=
-{
- "",
- "1",
- "2",
- "3",
- "4",
- "5",
- "6",
- "7",
- "8",
- "*",
-};
-static const char *const ffeinfo_where_string_[]
-=
-{
-#define FFEINFO_WHERE(KWD,LNAM,SNAM) SNAM,
-#include "info-w.def"
-#undef FFEINFO_WHERE
-};
-static ffetype ffeinfo_types_[FFEINFO_basictype][FFEINFO_kindtype];
-
-/* Static functions (internal). */
-
-
-/* Internal macros. */
-\f
-
-/* ffeinfo_basictype_combine -- Combine two basictypes into highest rank type
-
- ffeinfoBasictype i, j, k;
- k = ffeinfo_basictype_combine(i,j);
-
- Returns a type based on "standard" operation between two given types. */
-
-ffeinfoBasictype
-ffeinfo_basictype_combine (ffeinfoBasictype l, ffeinfoBasictype r)
-{
- assert (l < FFEINFO_basictype);
- assert (r < FFEINFO_basictype);
- return ffeinfo_combine_[l][r];
-}
-
-/* ffeinfo_basictype_string -- Return tiny string showing the basictype
-
- ffeinfoBasictype i;
- printf("%s",ffeinfo_basictype_string(dt));
-
- Returns the string based on the basic type. */
-
-const char *
-ffeinfo_basictype_string (ffeinfoBasictype basictype)
-{
- if (basictype >= ARRAY_SIZE (ffeinfo_basictype_string_))
- return "?\?\?";
- return ffeinfo_basictype_string_[basictype];
-}
-
-/* ffeinfo_init_0 -- Initialize
-
- ffeinfo_init_0(); */
-
-void
-ffeinfo_init_0 (void)
-{
- ffeinfoBasictype i;
- ffeinfoBasictype j;
-
- assert (FFEINFO_basictype == ARRAY_SIZE (ffeinfo_basictype_string_));
- assert (FFEINFO_kind == ARRAY_SIZE (ffeinfo_kind_message_));
- assert (FFEINFO_kind == ARRAY_SIZE (ffeinfo_kind_string_));
- assert (FFEINFO_kindtype == ARRAY_SIZE (ffeinfo_kindtype_string_));
- assert (FFEINFO_where == ARRAY_SIZE (ffeinfo_where_string_));
-
- /* Make array that, given two basic types, produces resulting basic type. */
-
- for (i = 0; i < FFEINFO_basictype; ++i)
- for (j = 0; j < FFEINFO_basictype; ++j)
- if ((i == FFEINFO_basictypeANY) || (j == FFEINFO_basictypeANY))
- ffeinfo_combine_[i][j] = FFEINFO_basictypeANY;
- else
- ffeinfo_combine_[i][j] = FFEINFO_basictypeNONE;
-
-#define same(bt) ffeinfo_combine_[bt][bt] = bt
-#define use2(bt1,bt2) ffeinfo_combine_[bt1][bt2] \
- = ffeinfo_combine_[bt2][bt1] = bt2
-
- same (FFEINFO_basictypeINTEGER);
- same (FFEINFO_basictypeLOGICAL);
- same (FFEINFO_basictypeREAL);
- same (FFEINFO_basictypeCOMPLEX);
- same (FFEINFO_basictypeCHARACTER);
- use2 (FFEINFO_basictypeINTEGER, FFEINFO_basictypeREAL);
- use2 (FFEINFO_basictypeINTEGER, FFEINFO_basictypeCOMPLEX);
- use2 (FFEINFO_basictypeREAL, FFEINFO_basictypeCOMPLEX);
-
-#undef same
-#undef use2
-}
-
-/* ffeinfo_kind_message -- Return helpful string showing the kind
-
- ffeinfoKind kind;
- printf("%s",ffeinfo_kind_message(kind));
-
- Returns the string based on the kind. */
-
-const char *
-ffeinfo_kind_message (ffeinfoKind kind)
-{
- if (kind >= ARRAY_SIZE (ffeinfo_kind_message_))
- return "?\?\?";
- return ffeinfo_kind_message_[kind];
-}
-
-/* ffeinfo_kind_string -- Return tiny string showing the kind
-
- ffeinfoKind kind;
- printf("%s",ffeinfo_kind_string(kind));
-
- Returns the string based on the kind. */
-
-const char *
-ffeinfo_kind_string (ffeinfoKind kind)
-{
- if (kind >= ARRAY_SIZE (ffeinfo_kind_string_))
- return "?\?\?";
- return ffeinfo_kind_string_[kind];
-}
-
-ffeinfoKindtype
-ffeinfo_kindtype_max(ffeinfoBasictype bt,
- ffeinfoKindtype k1,
- ffeinfoKindtype k2)
-{
- if ((bt == FFEINFO_basictypeANY)
- || (k1 == FFEINFO_kindtypeANY)
- || (k2 == FFEINFO_kindtypeANY))
- return FFEINFO_kindtypeANY;
-
- if (ffetype_size (ffeinfo_types_[bt][k1])
- > ffetype_size (ffeinfo_types_[bt][k2]))
- return k1;
- return k2;
-}
-
-/* ffeinfo_kindtype_string -- Return tiny string showing the kind type
-
- ffeinfoKindtype kind_type;
- printf("%s",ffeinfo_kindtype_string(kind));
-
- Returns the string based on the kind type. */
-
-const char *
-ffeinfo_kindtype_string (ffeinfoKindtype kind_type)
-{
- if (kind_type >= ARRAY_SIZE (ffeinfo_kindtype_string_))
- return "?\?\?";
- return ffeinfo_kindtype_string_[kind_type];
-}
-
-void
-ffeinfo_set_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
- ffetype type)
-{
- assert (basictype < FFEINFO_basictype);
- assert (kindtype < FFEINFO_kindtype);
- assert (ffeinfo_types_[basictype][kindtype] == NULL);
-
- ffeinfo_types_[basictype][kindtype] = type;
-}
-
-ffetype
-ffeinfo_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype)
-{
- assert (basictype < FFEINFO_basictype);
- assert (kindtype < FFEINFO_kindtype);
-
- return ffeinfo_types_[basictype][kindtype];
-}
-
-/* ffeinfo_where_string -- Return tiny string showing the where
-
- ffeinfoWhere where;
- printf("%s",ffeinfo_where_string(where));
-
- Returns the string based on the where. */
-
-const char *
-ffeinfo_where_string (ffeinfoWhere where)
-{
- if (where >= ARRAY_SIZE (ffeinfo_where_string_))
- return "?\?\?";
- return ffeinfo_where_string_[where];
-}
-
-/* ffeinfo_new -- Return object representing datatype, kind, and where info
-
- ffeinfo i;
- i = ffeinfo_new(FFEINFO_datatypeINTEGER,FFEINFO_kindSCALAR,
- FFEINFO_whereLOCAL);
-
- Returns the string based on the data type. */
-
-#ifndef __GNUC__
-ffeinfo
-ffeinfo_new (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
- ffeinfoRank rank, ffeinfoKind kind, ffeinfoWhere where,
- ffetargetCharacterSize size)
-{
- ffeinfo i;
-
- i.basictype = basictype;
- i.kindtype = kindtype;
- i.rank = rank;
- i.size = size;
- i.kind = kind;
- i.where = where;
- i.size = size;
-
- return i;
-}
-#endif
+++ /dev/null
-/* info.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- info.c
-
- Modifications:
- 30-Aug-90 JCB 2.0
- Extensive rewrite for new cleaner approach.
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_INFO_H
-#define GCC_F_INFO_H
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
-#define FFEINFO_BASICTYPE(KWD,LNAM,SNAM) KWD,
-#include "info-b.def"
-#undef FFEINFO_BASICTYPE
- FFEINFO_basictype
- } ffeinfoBasictype;
-
-typedef enum
- { /* If these kindtypes aren't in size order,
- change _kindtype_max. */
- FFEINFO_kindtypeNONE,
- FFEINFO_kindtypeINTEGER1,
- FFEINFO_kindtypeINTEGER2,
- FFEINFO_kindtypeINTEGER3,
- FFEINFO_kindtypeINTEGER4,
- FFEINFO_kindtypeINTEGER5,
- FFEINFO_kindtypeINTEGER6,
- FFEINFO_kindtypeINTEGER7,
- FFEINFO_kindtypeINTEGER8,
- FFEINFO_kindtypeLOGICAL1 = 1, /* Ok to omit, but ok to overlap. */
- FFEINFO_kindtypeLOGICAL2,
- FFEINFO_kindtypeLOGICAL3,
- FFEINFO_kindtypeLOGICAL4,
- FFEINFO_kindtypeLOGICAL5,
- FFEINFO_kindtypeLOGICAL6,
- FFEINFO_kindtypeLOGICAL7,
- FFEINFO_kindtypeLOGICAL8,
- FFEINFO_kindtypeREAL1 = 1, /* Ok to omit, but ok to overlap. */
- FFEINFO_kindtypeREAL2,
- FFEINFO_kindtypeREAL3,
- FFEINFO_kindtypeREAL4,
- FFEINFO_kindtypeREAL5,
- FFEINFO_kindtypeREAL6,
- FFEINFO_kindtypeREAL7,
- FFEINFO_kindtypeREAL8,
- FFEINFO_kindtypeCHARACTER1 = 1, /* Ok to omit, but ok to overlap. */
- FFEINFO_kindtypeCHARACTER2,
- FFEINFO_kindtypeCHARACTER3,
- FFEINFO_kindtypeCHARACTER4,
- FFEINFO_kindtypeCHARACTER5,
- FFEINFO_kindtypeCHARACTER6,
- FFEINFO_kindtypeCHARACTER7,
- FFEINFO_kindtypeCHARACTER8,
- FFEINFO_kindtypeANY,
- FFEINFO_kindtype
- } ffeinfoKindtype;
-
-typedef enum
- {
-#define FFEINFO_KIND(KWD,LNAM,SNAM) KWD,
-#include "info-k.def"
-#undef FFEINFO_KIND
- FFEINFO_kind
- } ffeinfoKind;
-
-typedef enum
- {
-#define FFEINFO_WHERE(KWD,LNAM,SNAM) KWD,
-#include "info-w.def"
-#undef FFEINFO_WHERE
- FFEINFO_where
- } ffeinfoWhere;
-
-/* Typedefs. */
-
-typedef struct _ffeinfo_ ffeinfo;
-typedef char ffeinfoRank;
-
-/* Include files needed by this one. */
-
-#include "target.h"
-#include "type.h"
-
-/* Structure definitions. */
-
-struct _ffeinfo_
- {
- ffeinfoBasictype basictype;
- ffeinfoKindtype kindtype;
- ffeinfoRank rank;
- ffeinfoKind kind;
- ffeinfoWhere where;
- ffetargetCharacterSize size;
- };
-
-/* Global objects accessed by users of this module. */
-
-
-/* Declare functions with prototypes. */
-
-ffeinfoBasictype ffeinfo_basictype_combine (ffeinfoBasictype l,
- ffeinfoBasictype r);
-const char *ffeinfo_basictype_string (ffeinfoBasictype basictype);
-void ffeinfo_init_0 (void);
-const char *ffeinfo_kind_message (ffeinfoKind kind);
-const char *ffeinfo_kind_string (ffeinfoKind kind);
-ffeinfoKindtype ffeinfo_kindtype_max(ffeinfoBasictype bt,
- ffeinfoKindtype k1,
- ffeinfoKindtype k2);
-const char *ffeinfo_kindtype_string (ffeinfoKindtype kind_type);
-const char *ffeinfo_where_string (ffeinfoWhere where);
-ffeinfo ffeinfo_new (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
- ffeinfoRank rank, ffeinfoKind kind, ffeinfoWhere where,
- ffetargetCharacterSize size);
-void ffeinfo_set_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
- ffetype type);
-ffetype ffeinfo_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype);
-
-/* Define macros. */
-
-#define ffeinfo_basictype(i) (i.basictype)
-#define ffeinfo_init_1()
-#define ffeinfo_init_2()
-#define ffeinfo_init_3()
-#define ffeinfo_init_4()
-#define ffeinfo_kind(i) (i.kind)
-#define ffeinfo_kindtype(i) (i.kindtype)
-#ifdef __GNUC__
-#define ffeinfo_new(bt,kt,r,k,w,sz) \
- ((ffeinfo) {(bt), (kt), (r), (k), (w), (sz)})
-#endif
-#define ffeinfo_new_any() \
- ffeinfo_new (FFEINFO_basictypeANY, FFEINFO_kindtypeANY, 0, \
- FFEINFO_kindANY, FFEINFO_whereANY, \
- FFETARGET_charactersizeNONE)
-#define ffeinfo_new_null() \
- ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, \
- FFEINFO_kindNONE, FFEINFO_whereNONE, \
- FFETARGET_charactersizeNONE)
-#define ffeinfo_rank(i) (i.rank)
-#define ffeinfo_size(i) (i.size)
-#define ffeinfo_terminate_0()
-#define ffeinfo_terminate_1()
-#define ffeinfo_terminate_2()
-#define ffeinfo_terminate_3()
-#define ffeinfo_terminate_4()
-#define ffeinfo_use(i) i
-#define ffeinfo_where(i) (i.where)
-
-#define FFEINFO_kindtypeINTEGERDEFAULT FFEINFO_kindtypeINTEGER1
-#define FFEINFO_kindtypeLOGICALDEFAULT FFEINFO_kindtypeLOGICAL1
-#define FFEINFO_kindtypeREALDEFAULT FFEINFO_kindtypeREAL1
-#define FFEINFO_kindtypeREALDOUBLE FFEINFO_kindtypeREAL2
-#define FFEINFO_kindtypeREALQUAD FFEINFO_kindtypeREAL3
-#define FFEINFO_kindtypeCHARACTERDEFAULT FFEINFO_kindtypeCHARACTER1
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_INFO_H */
+++ /dev/null
-/* intdoc.c
- Copyright (C) 1997, 2000, 2001, 2003
- Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
-
-/* From f/proj.h, which uses #error -- not all C compilers
- support that, and we want *this* program to be compilable
- by pretty much any C compiler. */
-#include "bconfig.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "assert.h"
-
-/* Pull in the intrinsics info, but only the doc parts. */
-#define FFEINTRIN_DOC 1
-#include "intrin.h"
-
-const char *family_name (ffeintrinFamily family);
-static void dumpif (ffeintrinFamily fam);
-static void dumpendif (void);
-static void dumpclearif (void);
-static void dumpem (void);
-static void dumpgen (int menu, const char *name, const char *name_uc,
- ffeintrinGen gen);
-static void dumpspec (int menu, const char *name, const char *name_uc,
- ffeintrinSpec spec);
-static void dumpimp (int menu, const char *name, const char *name_uc, size_t genno, ffeintrinFamily family,
- ffeintrinImp imp, ffeintrinSpec spec);
-static const char *argument_info_ptr (ffeintrinImp imp, int argno);
-static const char *argument_info_string (ffeintrinImp imp, int argno);
-static const char *argument_name_ptr (ffeintrinImp imp, int argno);
-static const char *argument_name_string (ffeintrinImp imp, int argno);
-#if 0
-static const char *elaborate_if_complex (ffeintrinImp imp, int argno);
-static const char *elaborate_if_maybe_complex (ffeintrinImp imp, int argno);
-static const char *elaborate_if_real (ffeintrinImp imp, int argno);
-#endif
-static void print_type_string (const char *c);
-
-int
-main (int argc, char **argv ATTRIBUTE_UNUSED)
-{
- if (argc != 1)
- {
- fprintf (stderr, "\
-Usage: intdoc > intdoc.texi\n\
- Collects and dumps documentation on g77 intrinsics\n\
- to the file named intdoc.texi.\n");
- exit (1);
- }
-
- dumpem ();
- return 0;
-}
-
-struct _ffeintrin_name_
- {
- const char *const name_uc;
- const char *const name_lc;
- const char *const name_ic;
- const ffeintrinGen generic;
- const ffeintrinSpec specific;
- };
-
-struct _ffeintrin_gen_
- {
- const char *const name; /* Name as seen in program. */
- const ffeintrinSpec specs[2];
- };
-
-struct _ffeintrin_spec_
- {
- const char *const name; /* Uppercase name as seen in source code,
- lowercase if no source name, "none" if no
- name at all (NONE case). */
- const bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */
- const ffeintrinFamily family;
- const ffeintrinImp implementation;
- };
-
-struct _ffeintrin_imp_
- {
- const char *const name; /* Name of implementation. */
- const char *const control;
- };
-
-static const struct _ffeintrin_name_ names[] = {
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
- { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-
-static const struct _ffeintrin_gen_ gens[] = {
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
- { NAME, { SPEC1, SPEC2, }, },
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-
-static const struct _ffeintrin_imp_ imps[] = {
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
- { NAME, CONTROL },
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
- { NAME, CONTROL },
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-
-static const struct _ffeintrin_spec_ specs[] = {
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
- { NAME, CALLABLE, FAMILY, IMP, },
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-
-struct cc_pair { const ffeintrinImp imp; const char *const text; };
-
-static const char *descriptions[FFEINTRIN_imp] = { 0 };
-static const struct cc_pair cc_descriptions[] = {
-#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, DESCRIPTION },
-#include "intdoc.h0"
-#undef DEFDOC
-};
-
-static const char *summaries[FFEINTRIN_imp] = { 0 };
-static const struct cc_pair cc_summaries[] = {
-#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, SUMMARY },
-#include "intdoc.h0"
-#undef DEFDOC
-};
-
-const char *
-family_name (ffeintrinFamily family)
-{
- switch (family)
- {
- case FFEINTRIN_familyF77:
- return "familyF77";
-
- case FFEINTRIN_familyASC:
- return "familyASC";
-
- case FFEINTRIN_familyMIL:
- return "familyMIL";
-
- case FFEINTRIN_familyGNU:
- return "familyGNU";
-
- case FFEINTRIN_familyF90:
- return "familyF90";
-
- case FFEINTRIN_familyVXT:
- return "familyVXT";
-
- case FFEINTRIN_familyFVZ:
- return "familyFVZ";
-
- case FFEINTRIN_familyF2C:
- return "familyF2C";
-
- case FFEINTRIN_familyF2U:
- return "familyF2U";
-
- case FFEINTRIN_familyBADU77:
- return "familyBADU77";
-
- default:
- assert ("bad family" == NULL);
- return "??";
- }
-}
-
-static int in_ifset = 0;
-static ffeintrinFamily latest_family = FFEINTRIN_familyNONE;
-
-static void
-dumpif (ffeintrinFamily fam)
-{
- assert (fam != FFEINTRIN_familyNONE);
- if ((in_ifset != 2)
- || (fam != latest_family))
- {
- if (in_ifset == 2)
- printf ("@end ifset\n");
- latest_family = fam;
- printf ("@ifset %s\n", family_name (fam));
- }
- in_ifset = 1;
-}
-
-static void
-dumpendif (void)
-{
- in_ifset = 2;
-}
-
-static void
-dumpclearif (void)
-{
- if ((in_ifset == 2)
- || (latest_family != FFEINTRIN_familyNONE))
- printf ("@end ifset\n");
- latest_family = FFEINTRIN_familyNONE;
- in_ifset = 0;
-}
-
-static void
-dumpem (void)
-{
- int i;
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_descriptions); ++i)
- {
- assert (descriptions[cc_descriptions[i].imp] == NULL);
- descriptions[cc_descriptions[i].imp] = cc_descriptions[i].text;
- }
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_summaries); ++i)
- {
- assert (summaries[cc_summaries[i].imp] == NULL);
- summaries[cc_summaries[i].imp] = cc_summaries[i].text;
- }
-
- printf ("@c This file is automatically derived from intdoc.c, intdoc.in,\n");
- printf ("@c ansify.c, intrin.def, and intrin.h. Edit those files instead.\n");
- printf ("@menu\n");
- for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
- {
- if (names[i].generic != FFEINTRIN_genNONE)
- dumpgen (1, names[i].name_ic, names[i].name_uc,
- names[i].generic);
- if (names[i].specific != FFEINTRIN_specNONE)
- dumpspec (1, names[i].name_ic, names[i].name_uc,
- names[i].specific);
- }
- dumpclearif ();
-
- printf ("@end menu\n\n");
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
- {
- if (names[i].generic != FFEINTRIN_genNONE)
- dumpgen (0, names[i].name_ic, names[i].name_uc,
- names[i].generic);
- if (names[i].specific != FFEINTRIN_specNONE)
- dumpspec (0, names[i].name_ic, names[i].name_uc,
- names[i].specific);
- }
- dumpclearif ();
-}
-
-static void
-dumpgen (int menu, const char *name, const char *name_uc, ffeintrinGen gen)
-{
- size_t i;
- int total = 0;
-
- if (!menu)
- {
- for (i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i)
- {
- if (gens[gen].specs[i] != FFEINTRIN_specNONE)
- ++total;
- }
- }
-
- for (i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i)
- {
- ffeintrinSpec spec;
- size_t j;
-
- if ((spec = gens[gen].specs[i]) == FFEINTRIN_specNONE)
- continue;
-
- dumpif (specs[spec].family);
- dumpimp (menu, name, name_uc, i, specs[spec].family, specs[spec].implementation,
- spec);
- if (!menu && (total > 0))
- {
- if (total == 1)
- {
- printf ("\
-For information on another intrinsic with the same name:\n");
- }
- else
- {
- printf ("\
-For information on other intrinsics with the same name:\n");
- }
- for (j = 0; j < ARRAY_SIZE (gens[gen].specs); ++j)
- {
- if (j == i)
- continue;
- if ((spec = gens[gen].specs[j]) == FFEINTRIN_specNONE)
- continue;
- printf ("@xref{%s Intrinsic (%s)}.\n",
- name, specs[spec].name);
- }
- printf ("\n");
- }
- dumpendif ();
- }
-}
-
-static void
-dumpspec (int menu, const char *name, const char *name_uc, ffeintrinSpec spec)
-{
- dumpif (specs[spec].family);
- dumpimp (menu, name, name_uc, 0, specs[spec].family, specs[spec].implementation,
- FFEINTRIN_specNONE);
- dumpendif ();
-}
-
-static void
-dumpimp (int menu, const char *name, const char *name_uc, size_t genno,
- ffeintrinFamily family, ffeintrinImp imp, ffeintrinSpec spec)
-{
- const char *c;
- bool subr;
- const char *argc;
- const char *argi;
- int colon;
- int argno;
-
- assert ((imp != FFEINTRIN_impNONE) || !genno);
-
- if (menu)
- {
- printf ("* %s Intrinsic",
- name);
- if (spec != FFEINTRIN_specNONE)
- printf (" (%s)", specs[spec].name); /* See XYZZY1 below */
- printf ("::");
-#define INDENT_SUMMARY 24
- if ((imp == FFEINTRIN_impNONE)
- || (summaries[imp] != NULL))
- {
- int spaces = INDENT_SUMMARY - 14 - strlen (name);
- const char *c;
-
- if (spec != FFEINTRIN_specNONE)
- spaces -= (3 + strlen (specs[spec].name)); /* See XYZZY1 above */
- if (spaces < 1)
- spaces = 1;
- while (spaces--)
- fputc (' ', stdout);
-
- if (imp == FFEINTRIN_impNONE)
- {
- printf ("(Reserved for future use.)\n");
- return;
- }
-
- for (c = summaries[imp]; c[0] != '\0'; ++c)
- {
- if (c[0] == '@' && ISDIGIT (c[1]))
- {
- int argno = c[1] - '0';
-
- c += 2;
- while (ISDIGIT (c[0]))
- {
- argno = 10 * argno + (c[0] - '0');
- ++c;
- }
- assert (c[0] == '@');
- if (argno == 0)
- printf ("%s", name);
- else if (argno == 99)
- { /* Yeah, this is a major kludge. */
- printf ("\n");
- spaces = INDENT_SUMMARY + 1;
- while (spaces--)
- fputc (' ', stdout);
- }
- else
- printf ("%s", argument_name_string (imp, argno - 1));
- }
- else
- fputc (c[0], stdout);
- }
- }
- printf ("\n");
- return;
- }
-
- printf ("@node %s Intrinsic", name);
- if (spec != FFEINTRIN_specNONE)
- printf (" (%s)", specs[spec].name);
- printf ("\n@subsubsection %s Intrinsic", name);
- if (spec != FFEINTRIN_specNONE)
- printf (" (%s)", specs[spec].name);
- printf ("\n@cindex %s intrinsic\n@cindex intrinsics, %s\n",
- name, name);
-
- if (imp == FFEINTRIN_impNONE)
- {
- printf ("\n\
-This intrinsic is not yet implemented.\n\
-The name is, however, reserved as an intrinsic.\n\
-Use @samp{EXTERNAL %s} to use this name for an\n\
-external procedure.\n\
-\n\
-",
- name);
- return;
- }
-
- c = imps[imp].control;
- subr = (c[0] == '-');
- colon = (c[2] == ':') ? 2 : 3;
-
- printf ("\n\
-@noindent\n\
-@example\n\
-%s%s(",
- (subr ? "CALL " : ""), name);
-
- fflush (stdout);
-
- for (argno = 0; ; ++argno)
- {
- argc = argument_name_ptr (imp, argno);
- if (argc == NULL)
- break;
- if (argno > 0)
- printf (", ");
- printf ("@var{%s}", argc);
- argi = argument_info_string (imp, argno);
- if ((argi[0] == '*')
- || (argi[0] == 'n')
- || (argi[0] == '+')
- || (argi[0] == 'p'))
- printf ("-1, @var{%s}-2, @dots{}, @var{%s}-n",
- argc, argc);
- }
-
- printf (")\n\
-@end example\n\
-\n\
-");
-
- if (!subr)
- {
- int other_arg;
- const char *arg_string;
- const char *arg_info;
-
- if (ISDIGIT (c[colon + 1]))
- {
- other_arg = c[colon + 1] - '0';
- arg_string = argument_name_string (imp, other_arg);
- arg_info = argument_info_string (imp, other_arg);
- }
- else
- {
- other_arg = -1;
- arg_string = NULL;
- arg_info = NULL;
- }
-
- printf ("\
-@noindent\n\
-%s: ", name);
- print_type_string (c);
- printf (" function");
-
- if ((c[0] == 'R')
- && (c[1] == 'C'))
- {
- assert (other_arg >= 0);
-
- if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+')
- || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p'))
- ++arg_info;
- if ((arg_info[0] == 'F') || (arg_info[0] == 'N'))
- printf (".\n\
-The exact type is @samp{REAL(KIND=1)} when argument @var{%s} is\n\
-any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}.\n\
-When @var{%s} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)},\n\
-this intrinsic is valid only when used as the argument to\n\
-@code{REAL()}, as explained below.\n\n",
- arg_string,
- arg_string);
- else
- printf (".\n\
-This intrinsic is valid when argument @var{%s} is\n\
-@code{COMPLEX(KIND=1)}.\n\
-When @var{%s} is any other @code{COMPLEX} type,\n\
-this intrinsic is valid only when used as the argument to\n\
-@code{REAL()}, as explained below.\n\n",
- arg_string,
- arg_string);
- }
-#if 0
- else if ((c[0] == 'I')
- && (c[1] == '7'))
- printf (", the exact type being wide enough to hold a pointer\n\
-on the target system (typically @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=4)}).\n\n");
-#endif
- else if (c[1] == '=' && ISDIGIT (c[colon + 1]))
- {
- assert (other_arg >= 0);
-
- if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+')
- || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p'))
- ++arg_info;
-
- if (((c[0] == arg_info[0])
- && ((c[0] == 'A') || (c[0] == 'C') || (c[0] == 'I')
- || (c[0] == 'L') || (c[0] == 'R')))
- || ((c[0] == 'R')
- && (arg_info[0] == 'C'))
- || ((c[0] == 'C')
- && (arg_info[0] == 'R')))
- printf (", the @samp{KIND=} value of the type being that of argument @var{%s}.\n\n",
- arg_string);
- else if ((c[0] == 'S')
- && ((arg_info[0] == 'C')
- || (arg_info[0] == 'F')
- || (arg_info[0] == 'N')))
- printf (".\n\
-The exact type depends on that of argument @var{%s}---if @var{%s} is\n\
-@code{COMPLEX}, this function's type is @code{REAL}\n\
-with the same @samp{KIND=} value as the type of @var{%s}.\n\
-Otherwise, this function's type is the same as that of @var{%s}.\n\n",
- arg_string, arg_string, arg_string, arg_string);
- else
- printf (", the exact type being that of argument @var{%s}.\n\n",
- arg_string);
- }
- else if ((c[1] == '=')
- && (c[colon + 1] == '*'))
- printf (", the exact type being the result of cross-promoting the\n\
-types of all the arguments.\n\n");
- else if (c[1] == '=')
- assert ("?0:?:" == NULL);
- else
- printf (".\n\n");
- }
-
- for (argno = 0, argc = &c[colon + 3]; *argc != '\0'; ++argno)
- {
- char optionality = '\0';
- char extra = '\0';
- char basic;
- char kind;
- int length;
- int elements;
-
- printf ("\
-@noindent\n\
-@var{");
- for (; ; ++argc)
- {
- if (argc[0] == '=')
- break;
- printf ("%c", *argc);
- }
- printf ("}: ");
-
- ++argc;
- if ((*argc == '?')
- || (*argc == '!')
- || (*argc == '*')
- || (*argc == '+')
- || (*argc == 'n')
- || (*argc == 'p'))
- optionality = *(argc++);
- basic = *(argc++);
- kind = *(argc++);
- if (*argc == '[')
- {
- length = *++argc - '0';
- if (*++argc != ']')
- length = 10 * length + (*(argc++) - '0');
- ++argc;
- }
- else
- length = -1;
- if (*argc == '(')
- {
- elements = *++argc - '0';
- if (*++argc != ')')
- elements = 10 * elements + (*(argc++) - '0');
- ++argc;
- }
- else if (*argc == '&')
- {
- elements = -1;
- ++argc;
- }
- else
- elements = 0;
- if ((*argc == '&')
- || (*argc == 'i')
- || (*argc == 'w')
- || (*argc == 'x'))
- extra = *(argc++);
- if (*argc == ',')
- ++argc;
-
- switch (basic)
- {
- case '-':
- switch (kind)
- {
- case '*':
- printf ("Any type");
- break;
-
- default:
- assert ("kind arg" == NULL);
- break;
- }
- break;
-
- case 'A':
- assert ((kind == '1') || (kind == '*'));
- printf ("@code{CHARACTER");
- if (length != -1)
- printf ("*%d", length);
- printf ("}");
- break;
-
- case 'C':
- switch (kind)
- {
- case '*':
- printf ("@code{COMPLEX}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{COMPLEX(KIND=%d)}", (kind - '0'));
- break;
-
- case 'A':
- printf ("Same @samp{KIND=} value as for @var{%s}",
- argument_name_string (imp, 0));
- break;
-
- default:
- assert ("Ca" == NULL);
- break;
- }
- break;
-
- case 'I':
- switch (kind)
- {
- case '*':
- printf ("@code{INTEGER}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
- break;
-
- case 'A':
- printf ("@code{INTEGER} with same @samp{KIND=} value as for @var{%s}",
- argument_name_string (imp, 0));
- break;
-
- case 'N':
- printf ("@code{INTEGER} not wider than the default kind");
- break;
-
- default:
- assert ("Ia" == NULL);
- break;
- }
- break;
-
- case 'L':
- switch (kind)
- {
- case '*':
- printf ("@code{LOGICAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
- break;
-
- case 'A':
- printf ("@code{LOGICAL} with same @samp{KIND=} value as for @var{%s}",
- argument_name_string (imp, 0));
- break;
-
- case 'N':
- printf ("@code{LOGICAL} not wider than the default kind");
- break;
-
- default:
- assert ("La" == NULL);
- break;
- }
- break;
-
- case 'R':
- switch (kind)
- {
- case '*':
- printf ("@code{REAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{REAL(KIND=%d)}", (kind - '0'));
- break;
-
- case 'A':
- printf ("@code{REAL} with same @samp{KIND=} value as for @var{%s}",
- argument_name_string (imp, 0));
- break;
-
- default:
- assert ("Ra" == NULL);
- break;
- }
- break;
-
- case 'B':
- switch (kind)
- {
- case '*':
- printf ("@code{INTEGER} or @code{LOGICAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
- (kind - '0'), (kind - '0'));
- break;
-
- case 'A':
- printf ("Same type and @samp{KIND=} value as for @var{%s}",
- argument_name_string (imp, 0));
- break;
-
- case 'N':
- printf ("@code{INTEGER} or @code{LOGICAL} not wider than the default kind");
- break;
-
- default:
- assert ("Ba" == NULL);
- break;
- }
- break;
-
- case 'F':
- switch (kind)
- {
- case '*':
- printf ("@code{REAL} or @code{COMPLEX}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
- (kind - '0'), (kind - '0'));
- break;
-
- case 'A':
- printf ("Same type as @var{%s}",
- argument_name_string (imp, 0));
- break;
-
- default:
- assert ("Fa" == NULL);
- break;
- }
- break;
-
- case 'N':
- switch (kind)
- {
- case '*':
- printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
- (kind - '0'), (kind - '0'), (kind - '0'));
- break;
-
- default:
- assert ("N1" == NULL);
- break;
- }
- break;
-
- case 'S':
- switch (kind)
- {
- case '*':
- printf ("@code{INTEGER} or @code{REAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
- (kind - '0'), (kind - '0'));
- break;
-
- case 'A':
- printf ("@code{INTEGER} or @code{REAL} with same @samp{KIND=} value as for @var{%s}",
- argument_name_string (imp, 0));
- break;
-
- default:
- assert ("Sa" == NULL);
- break;
- }
- break;
-
- case 'g':
- printf ("@samp{*@var{label}}, where @var{label} is the label\n\
-of an executable statement");
- break;
-
- case 's':
- printf ("Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})\n\
-or dummy/global @code{INTEGER(KIND=1)} scalar");
- break;
-
- default:
- assert ("arg type?" == NULL);
- break;
- }
-
- switch (optionality)
- {
- case '\0':
- break;
-
- case '!':
- printf ("; OPTIONAL (must be omitted if @var{%s} is @code{COMPLEX})",
- argument_name_string (imp, argno-1));
- break;
-
- case '?':
- printf ("; OPTIONAL");
- break;
-
- case '*':
- printf ("; OPTIONAL");
- break;
-
- case 'n':
- case '+':
- break;
-
- case 'p':
- printf ("; at least two such arguments must be provided");
- break;
-
- default:
- assert ("optionality!" == NULL);
- break;
- }
-
- switch (elements)
- {
- case -1:
- break;
-
- case 0:
- if ((basic != 'g')
- && (basic != 's'))
- printf ("; scalar");
- break;
-
- default:
- assert (extra != '\0');
- printf ("; DIMENSION(%d)", elements);
- break;
- }
-
- switch (extra)
- {
- case '\0':
- if ((basic != 'g')
- && (basic != 's'))
- printf ("; INTENT(IN)");
- break;
-
- case 'i':
- break;
-
- case '&':
- printf ("; cannot be a constant or expression");
- break;
-
- case 'w':
- printf ("; INTENT(OUT)");
- break;
-
- case 'x':
- printf ("; INTENT(INOUT)");
- break;
- }
-
- printf (".\n\n");
- }
-
- printf ("\
-@noindent\n\
-Intrinsic groups: ");
- switch (family)
- {
- case FFEINTRIN_familyF77:
- printf ("(standard FORTRAN 77).");
- break;
-
- case FFEINTRIN_familyGNU:
- printf ("@code{gnu}.");
- break;
-
- case FFEINTRIN_familyASC:
- printf ("@code{f2c}, @code{f90}.");
- break;
-
- case FFEINTRIN_familyMIL:
- printf ("@code{mil}, @code{f90}, @code{vxt}.");
- break;
-
- case FFEINTRIN_familyF90:
- printf ("@code{f90}.");
- break;
-
- case FFEINTRIN_familyVXT:
- printf ("@code{vxt}.");
- break;
-
- case FFEINTRIN_familyFVZ:
- printf ("@code{f2c}, @code{vxt}.");
- break;
-
- case FFEINTRIN_familyF2C:
- printf ("@code{f2c}.");
- break;
-
- case FFEINTRIN_familyF2U:
- printf ("@code{unix}.");
- break;
-
- case FFEINTRIN_familyBADU77:
- printf ("@code{badu77}.");
- break;
-
- default:
- assert ("bad family" == NULL);
- printf ("@code{???}.");
- break;
- }
- printf ("\n\n");
-
- if (descriptions[imp] != NULL)
- {
- const char *c = descriptions[imp];
-
- printf ("\
-@noindent\n\
-Description:\n\
-\n");
-
- while (c[0] != '\0')
- {
- if (c[0] == '@' && ISDIGIT (c[1]))
- {
- int argno = c[1] - '0';
-
- c += 2;
- while (ISDIGIT (c[0]))
- {
- argno = 10 * argno + (c[0] - '0');
- ++c;
- }
- assert (c[0] == '@');
- if (argno == 0)
- printf ("%s", name_uc);
- else
- printf ("%s", argument_name_string (imp, argno - 1));
- }
- else
- fputc (c[0], stdout);
- ++c;
- }
-
- printf ("\n");
- }
-}
-
-static const char *
-argument_info_ptr (ffeintrinImp imp, int argno)
-{
- const char *c = imps[imp].control;
- static char arginfos[8][32];
- static int argx = 0;
- int i;
-
- if (c[2] == ':')
- c += 5;
- else
- c += 6;
-
- while (argno--)
- {
- while ((c[0] != ',') && (c[0] != '\0'))
- ++c;
- if (c[0] != ',')
- break;
- ++c;
- }
-
- if (c[0] == '\0')
- return NULL;
-
- for (; (c[0] != '=') && (c[0] != '\0'); ++c)
- ;
-
- assert (c[0] == '=');
-
- for (i = 0, ++c; (c[0] != ',') && (c[0] != '\0'); ++c, ++i)
- arginfos[argx][i] = c[0];
-
- arginfos[argx][i] = '\0';
-
- c = &arginfos[argx][0];
- ++argx;
- if (((size_t) argx) >= ARRAY_SIZE (arginfos))
- argx = 0;
-
- return c;
-}
-
-static const char *
-argument_info_string (ffeintrinImp imp, int argno)
-{
- const char *p;
-
- p = argument_info_ptr (imp, argno);
- assert (p != NULL);
- return p;
-}
-
-static const char *
-argument_name_ptr (ffeintrinImp imp, int argno)
-{
- const char *c = imps[imp].control;
- static char argnames[8][32];
- static int argx = 0;
- int i;
-
- if (c[2] == ':')
- c += 5;
- else
- c += 6;
-
- while (argno--)
- {
- while ((c[0] != ',') && (c[0] != '\0'))
- ++c;
- if (c[0] != ',')
- break;
- ++c;
- }
-
- if (c[0] == '\0')
- return NULL;
-
- for (i = 0; (c[0] != '=') && (c[0] != '\0'); ++c, ++i)
- argnames[argx][i] = c[0];
-
- assert (c[0] == '=');
- argnames[argx][i] = '\0';
-
- c = &argnames[argx][0];
- ++argx;
- if (((size_t) argx) >= ARRAY_SIZE (argnames))
- argx = 0;
-
- return c;
-}
-
-static const char *
-argument_name_string (ffeintrinImp imp, int argno)
-{
- const char *p;
-
- p = argument_name_ptr (imp, argno);
- assert (p != NULL);
- return p;
-}
-
-static void
-print_type_string (const char *c)
-{
- char basic = c[0];
- char kind = c[1];
-
- switch (basic)
- {
- case 'A':
- assert ((kind == '1') || (kind == '='));
- if (c[2] == ':')
- printf ("@code{CHARACTER*1}");
- else
- {
- assert (c[2] == '*');
- printf ("@code{CHARACTER*(*)}");
- }
- break;
-
- case 'C':
- switch (kind)
- {
- case '=':
- printf ("@code{COMPLEX}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{COMPLEX(KIND=%d)}", (kind - '0'));
- break;
-
- default:
- assert ("Ca" == NULL);
- break;
- }
- break;
-
- case 'I':
- switch (kind)
- {
- case '=':
- printf ("@code{INTEGER}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
- break;
-
- default:
- assert ("Ia" == NULL);
- break;
- }
- break;
-
- case 'L':
- switch (kind)
- {
- case '=':
- printf ("@code{LOGICAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
- break;
-
- default:
- assert ("La" == NULL);
- break;
- }
- break;
-
- case 'R':
- switch (kind)
- {
- case '=':
- printf ("@code{REAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{REAL(KIND=%d)}", (kind - '0'));
- break;
-
- case 'C':
- printf ("@code{REAL}");
- break;
-
- default:
- assert ("Ra" == NULL);
- break;
- }
- break;
-
- case 'B':
- switch (kind)
- {
- case '=':
- printf ("@code{INTEGER} or @code{LOGICAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
- (kind - '0'), (kind - '0'));
- break;
-
- default:
- assert ("Ba" == NULL);
- break;
- }
- break;
-
- case 'F':
- switch (kind)
- {
- case '=':
- printf ("@code{REAL} or @code{COMPLEX}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
- (kind - '0'), (kind - '0'));
- break;
-
- default:
- assert ("Fa" == NULL);
- break;
- }
- break;
-
- case 'N':
- switch (kind)
- {
- case '=':
- printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
- (kind - '0'), (kind - '0'), (kind - '0'));
- break;
-
- default:
- assert ("N1" == NULL);
- break;
- }
- break;
-
- case 'S':
- switch (kind)
- {
- case '=':
- printf ("@code{INTEGER} or @code{REAL}");
- break;
-
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
- (kind - '0'), (kind - '0'));
- break;
-
- default:
- assert ("Sa" == NULL);
- break;
- }
- break;
-
- default:
- assert ("type?" == NULL);
- break;
- }
-}
+++ /dev/null
-/* Copyright (C) 1997, 1999, 2003 Free Software Foundation, Inc.
- * This is part of the G77 manual.
- * For copying conditions, see the file g77.texi. */
-
-/* This is the file containing the verbage for the
- intrinsics. It consists of a data base built up
- via DEFDOC macros of the form:
-
- DEFDOC (IMP, SUMMARY, DESCRIPTION)
-
- IMP is the implementation keyword used in the intrin module.
- SUMMARY is the short summary to go in the "* Menu:" section
- of the Info document. DESCRIPTION is the longer description
- to go in the documentation itself.
-
- Note that IMP is leveraged across multiple intrinsic names.
-
- To make for more accurate and consistent documentation,
- the translation made by intdoc.c of the text in SUMMARY
- and DESCRIPTION includes the special sequence
-
- @ARGNO@
-
- where ARGNO is a series of digits forming a number that
- is substituted by intdoc.c as follows:
-
- 0 The initial-caps form of the intrinsic name (e.g. Float).
- 1-98 The initial-caps form of the ARGNO'th argument.
- 99 (SUMMARY only) a newline plus the appropriate # of spaces.
-
- Hope this info is enough to encourage people to feel free to
- add documentation to this file!
-
-*/
-
-#define ARCHAIC(upper,mixed) \
- "Archaic form of @code{" #upper "()} that is specific\n\
-to one type for @var{@1@}.\n\
-@xref{" #mixed " Intrinsic}.\n"
-
-#define ARCHAIC_2nd(upper,mixed) \
- "Archaic form of @code{" #upper "()} that is specific\n\
-to one type for @var{@2@}.\n\
-@xref{" #mixed " Intrinsic}.\n"
-
-#define ARCHAIC_2(upper,mixed) \
- "Archaic form of @code{" #upper "()} that is specific\n\
-to one type for @var{@1@} and @var{@2@}.\n\
-@xref{" #mixed " Intrinsic}.\n"
-
-DEFDOC (ABS, "Absolute value.", "\
-Returns the absolute value of @var{@1@}.
-
-If @var{@1@} is type @code{COMPLEX}, the absolute
-value is computed as:
-
-@example
-SQRT(REALPART(@var{@1@})**2+IMAGPART(@var{@1@})**2)
-@end example
-
-@noindent
-Otherwise, it is computed by negating @var{@1@} if
-it is negative, or returning @var{@1@}.
-
-@xref{Sign Intrinsic}, for how to explicitly
-compute the positive or negative form of the absolute
-value of an expression.
-")
-
-DEFDOC (CABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs))
-
-DEFDOC (DABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs))
-
-DEFDOC (IABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs))
-
-DEFDOC (CDABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs))
-
-DEFDOC (ACHAR, "ASCII character from code.", "\
-Returns the ASCII character corresponding to the
-code specified by @var{@1@}.
-
-@xref{IAChar Intrinsic}, for the inverse of this function.
-
-@xref{Char Intrinsic}, for the function corresponding
-to the system's native character set.
-")
-
-DEFDOC (IACHAR, "ASCII code for character.", "\
-Returns the code for the ASCII character in the
-first character position of @var{@1@}.
-
-@xref{AChar Intrinsic}, for the inverse of this function.
-
-@xref{IChar Intrinsic}, for the function corresponding
-to the system's native character set.
-")
-
-DEFDOC (CHAR, "Character from code.", "\
-Returns the character corresponding to the
-code specified by @var{@1@}, using the system's
-native character set.
-
-Because the system's native character set is used,
-the correspondence between character and their codes
-is not necessarily the same between GNU Fortran
-implementations.
-
-Note that no intrinsic exists to convert a numerical
-value to a printable character string.
-For example, there is no intrinsic that, given
-an @code{INTEGER} or @code{REAL} argument with the
-value @samp{154}, returns the @code{CHARACTER}
-result @samp{'154'}.
-
-Instead, you can use internal-file I/O to do this kind
-of conversion.
-For example:
-
-@smallexample
-INTEGER VALUE
-CHARACTER*10 STRING
-VALUE = 154
-WRITE (STRING, '(I10)'), VALUE
-PRINT *, STRING
-END
-@end smallexample
-
-The above program, when run, prints:
-
-@smallexample
- 154
-@end smallexample
-
-@xref{IChar Intrinsic}, for the inverse of the @code{@0@} function.
-
-@xref{AChar Intrinsic}, for the function corresponding
-to the ASCII character set.
-")
-
-DEFDOC (ICHAR, "Code for character.", "\
-Returns the code for the character in the
-first character position of @var{@1@}.
-
-Because the system's native character set is used,
-the correspondence between character and their codes
-is not necessarily the same between GNU Fortran
-implementations.
-
-Note that no intrinsic exists to convert a printable
-character string to a numerical value.
-For example, there is no intrinsic that, given
-the @code{CHARACTER} value @samp{'154'}, returns an
-@code{INTEGER} or @code{REAL} value with the value @samp{154}.
-
-Instead, you can use internal-file I/O to do this kind
-of conversion.
-For example:
-
-@smallexample
-INTEGER VALUE
-CHARACTER*10 STRING
-STRING = '154'
-READ (STRING, '(I10)'), VALUE
-PRINT *, VALUE
-END
-@end smallexample
-
-The above program, when run, prints:
-
-@smallexample
- 154
-@end smallexample
-
-@xref{Char Intrinsic}, for the inverse of the @code{@0@} function.
-
-@xref{IAChar Intrinsic}, for the function corresponding
-to the ASCII character set.
-")
-
-DEFDOC (ACOS, "Arc cosine.", "\
-Returns the arc-cosine (inverse cosine) of @var{@1@}
-in radians.
-
-@xref{Cos Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (DACOS, "Arc cosine (archaic).", ARCHAIC (ACOS, ACos))
-
-DEFDOC (AIMAG, "Convert/extract imaginary part of complex.", "\
-Returns the (possibly converted) imaginary part of @var{@1@}.
-
-Use of @code{@0@()} with an argument of a type
-other than @code{COMPLEX(KIND=1)} is restricted to the following case:
-
-@example
-REAL(AIMAG(@1@))
-@end example
-
-@noindent
-This expression converts the imaginary part of @1@ to
-@code{REAL(KIND=1)}.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-")
-
-DEFDOC (DIMAG, "Convert/extract imaginary part of complex (archaic).", ARCHAIC (AIMAG, AImag))
-
-DEFDOC (AINT, "Truncate to whole number.", "\
-Returns @var{@1@} with the fractional portion of its
-magnitude truncated and its sign preserved.
-(Also called ``truncation towards zero''.)
-
-@xref{ANInt Intrinsic}, for how to round to nearest
-whole number.
-
-@xref{Int Intrinsic}, for how to truncate and then convert
-number to @code{INTEGER}.
-")
-
-DEFDOC (DINT, "Truncate to whole number (archaic).", ARCHAIC (AINT, AInt))
-
-DEFDOC (INT, "Convert to @code{INTEGER} value truncated@99@to whole number.", "\
-Returns @var{@1@} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=1)}.
-
-If @var{@1@} is type @code{COMPLEX}, its real part is
-truncated and converted, and its imaginary part is disregarded.
-
-@xref{NInt Intrinsic}, for how to convert, rounded to nearest
-whole number.
-
-@xref{AInt Intrinsic}, for how to truncate to whole number
-without converting.
-")
-
-DEFDOC (IDINT, "Convert to @code{INTEGER} value truncated@99@to whole number (archaic).", ARCHAIC (INT, Int))
-
-DEFDOC (ANINT, "Round to nearest whole number.", "\
-Returns @var{@1@} with the fractional portion of its
-magnitude eliminated by rounding to the nearest whole
-number and with its sign preserved.
-
-A fractional portion exactly equal to
-@samp{.5} is rounded to the whole number that
-is larger in magnitude.
-(Also called ``Fortran round''.)
-
-@xref{AInt Intrinsic}, for how to truncate to
-whole number.
-
-@xref{NInt Intrinsic}, for how to round and then convert
-number to @code{INTEGER}.
-")
-
-DEFDOC (DNINT, "Round to nearest whole number (archaic).", ARCHAIC (ANINT, ANInt))
-
-DEFDOC (NINT, "Convert to @code{INTEGER} value rounded@99@to nearest whole number.", "\
-Returns @var{@1@} with the fractional portion of its
-magnitude eliminated by rounding to the nearest whole
-number and with its sign preserved, converted
-to type @code{INTEGER(KIND=1)}.
-
-If @var{@1@} is type @code{COMPLEX}, its real part is
-rounded and converted.
-
-A fractional portion exactly equal to
-@samp{.5} is rounded to the whole number that
-is larger in magnitude.
-(Also called ``Fortran round''.)
-
-@xref{Int Intrinsic}, for how to convert, truncate to
-whole number.
-
-@xref{ANInt Intrinsic}, for how to round to nearest whole number
-without converting.
-")
-
-DEFDOC (IDNINT, "Convert to @code{INTEGER} value rounded@99@to nearest whole number (archaic).", ARCHAIC (NINT, NInt))
-
-DEFDOC (LOG, "Natural logarithm.", "\
-Returns the natural logarithm of @var{@1@}, which must
-be greater than zero or, if type @code{COMPLEX}, must not
-be zero.
-
-@xref{Exp Intrinsic}, for the inverse of this function.
-
-@xref{Log10 Intrinsic}, for the `common' (base-10) logarithm function.
-")
-
-DEFDOC (ALOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log))
-
-DEFDOC (CLOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log))
-
-DEFDOC (DLOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log))
-
-DEFDOC (CDLOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log))
-
-DEFDOC (LOG10, "Common logarithm.", "\
-Returns the common logarithm (base 10) of @var{@1@}, which must
-be greater than zero.
-
-The inverse of this function is @samp{10. ** LOG10(@var{@1@})}.
-
-@xref{Log Intrinsic}, for the natural logarithm function.
-")
-
-DEFDOC (ALOG10, "Common logarithm (archaic).", ARCHAIC (LOG10, Log10))
-
-DEFDOC (DLOG10, "Common logarithm (archaic).", ARCHAIC (LOG10, Log10))
-
-DEFDOC (MAX, "Maximum value.", "\
-Returns the argument with the largest value.
-
-@xref{Min Intrinsic}, for the opposite function.
-")
-
-DEFDOC (AMAX0, "Maximum value (archaic).", "\
-Archaic form of @code{MAX()} that is specific
-to one type for @var{@1@} and a different return type.
-@xref{Max Intrinsic}.
-")
-
-DEFDOC (AMAX1, "Maximum value (archaic).", ARCHAIC (MAX, Max))
-
-DEFDOC (DMAX1, "Maximum value (archaic).", ARCHAIC (MAX, Max))
-
-DEFDOC (MAX0, "Maximum value (archaic).", ARCHAIC (MAX, Max))
-
-DEFDOC (MAX1, "Maximum value (archaic).", "\
-Archaic form of @code{MAX()} that is specific
-to one type for @var{@1@} and a different return type.
-@xref{Max Intrinsic}.
-")
-
-DEFDOC (MIN, "Minimum value.", "\
-Returns the argument with the smallest value.
-
-@xref{Max Intrinsic}, for the opposite function.
-")
-
-DEFDOC (AMIN0, "Minimum value (archaic).", "\
-Archaic form of @code{MIN()} that is specific
-to one type for @var{@1@} and a different return type.
-@xref{Min Intrinsic}.
-")
-
-DEFDOC (AMIN1, "Minimum value (archaic).", ARCHAIC (MIN, Min))
-
-DEFDOC (DMIN1, "Minimum value (archaic).", ARCHAIC (MIN, Min))
-
-DEFDOC (MIN0, "Minimum value (archaic).", ARCHAIC (MIN, Min))
-
-DEFDOC (MIN1, "Minimum value (archaic).", "\
-Archaic form of @code{MIN()} that is specific
-to one type for @var{@1@} and a different return type.
-@xref{Min Intrinsic}.
-")
-
-DEFDOC (MOD, "Remainder.", "\
-Returns remainder calculated as:
-
-@smallexample
-@var{@1@} - (INT(@var{@1@} / @var{@2@}) * @var{@2@})
-@end smallexample
-
-@var{@2@} must not be zero.
-")
-
-DEFDOC (AMOD, "Remainder (archaic).", ARCHAIC (MOD, Mod))
-
-DEFDOC (DMOD, "Remainder (archaic).", ARCHAIC (MOD, Mod))
-
-DEFDOC (AND, "Boolean AND.", "\
-Returns value resulting from boolean AND of
-pair of bits in each of @var{@1@} and @var{@2@}.
-")
-
-DEFDOC (IAND, "Boolean AND.", "\
-Returns value resulting from boolean AND of
-pair of bits in each of @var{@1@} and @var{@2@}.
-")
-
-DEFDOC (OR, "Boolean OR.", "\
-Returns value resulting from boolean OR of
-pair of bits in each of @var{@1@} and @var{@2@}.
-")
-
-DEFDOC (IOR, "Boolean OR.", "\
-Returns value resulting from boolean OR of
-pair of bits in each of @var{@1@} and @var{@2@}.
-")
-
-DEFDOC (XOR, "Boolean XOR.", "\
-Returns value resulting from boolean exclusive-OR of
-pair of bits in each of @var{@1@} and @var{@2@}.
-")
-
-DEFDOC (IEOR, "Boolean XOR.", "\
-Returns value resulting from boolean exclusive-OR of
-pair of bits in each of @var{@1@} and @var{@2@}.
-")
-
-DEFDOC (NOT, "Boolean NOT.", "\
-Returns value resulting from boolean NOT of each bit
-in @var{@1@}.
-")
-
-DEFDOC (ASIN, "Arc sine.", "\
-Returns the arc-sine (inverse sine) of @var{@1@}
-in radians.
-
-@xref{Sin Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (DASIN, "Arc sine (archaic).", ARCHAIC (ASIN, ASin))
-
-DEFDOC (ATAN, "Arc tangent.", "\
-Returns the arc-tangent (inverse tangent) of @var{@1@}
-in radians.
-
-@xref{Tan Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (DATAN, "Arc tangent (archaic).", ARCHAIC (ATAN, ATan))
-
-DEFDOC (ATAN2, "Arc tangent.", "\
-Returns the arc-tangent (inverse tangent) of the complex
-number (@var{@1@}, @var{@2@}) in radians.
-
-@xref{Tan Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (DATAN2, "Arc tangent (archaic).", ARCHAIC_2 (ATAN2, ATan2))
-
-DEFDOC (BIT_SIZE, "Number of bits in argument's type.", "\
-Returns the number of bits (integer precision plus sign bit)
-represented by the type for @var{@1@}.
-
-@xref{BTest Intrinsic}, for how to test the value of a
-bit in a variable or array.
-
-@xref{IBSet Intrinsic}, for how to set a bit in a variable to 1.
-
-@xref{IBClr Intrinsic}, for how to set a bit in a variable to 0.
-
-")
-
-DEFDOC (BTEST, "Test bit.", "\
-Returns @code{.TRUE.} if bit @var{@2@} in @var{@1@} is
-1, @code{.FALSE.} otherwise.
-
-(Bit 0 is the low-order (rightmost) bit, adding the value
-@ifinfo
-2**0,
-@end ifinfo
-@iftex
-@tex
-$2^0$,
-@end tex
-@end iftex
-or 1,
-to the number if set to 1;
-bit 1 is the next-higher-order bit, adding
-@ifinfo
-2**1,
-@end ifinfo
-@iftex
-@tex
-$2^1$,
-@end tex
-@end iftex
-or 2;
-bit 2 adds
-@ifinfo
-2**2,
-@end ifinfo
-@iftex
-@tex
-$2^2$,
-@end tex
-@end iftex
-or 4; and so on.)
-
-@xref{Bit_Size Intrinsic}, for how to obtain the number of bits
-in a type.
-The leftmost bit of @var{@1@} is @samp{BIT_SIZE(@var{@1@}-1)}.
-")
-
-DEFDOC (CMPLX, "Construct @code{COMPLEX(KIND=1)} value.", "\
-If @var{@1@} is not type @code{COMPLEX},
-constructs a value of type @code{COMPLEX(KIND=1)} from the
-real and imaginary values specified by @var{@1@} and
-@var{@2@}, respectively.
-If @var{@2@} is omitted, @samp{0.} is assumed.
-
-If @var{@1@} is type @code{COMPLEX},
-converts it to type @code{COMPLEX(KIND=1)}.
-
-@xref{Complex Intrinsic}, for information on easily constructing
-a @code{COMPLEX} value of arbitrary precision from @code{REAL}
-arguments.
-")
-
-DEFDOC (DCMPLX, "Construct @code{COMPLEX(KIND=2)} value.", "\
-If @var{@1@} is not type @code{COMPLEX},
-constructs a value of type @code{COMPLEX(KIND=2)} from the
-real and imaginary values specified by @var{@1@} and
-@var{@2@}, respectively.
-If @var{@2@} is omitted, @samp{0D0} is assumed.
-
-If @var{@1@} is type @code{COMPLEX},
-converts it to type @code{COMPLEX(KIND=2)}.
-
-Although this intrinsic is not standard Fortran,
-it is a popular extension offered by many compilers
-that support @code{DOUBLE COMPLEX}, since it offers
-the easiest way to convert to @code{DOUBLE COMPLEX}
-without using Fortran 90 features (such as the @samp{KIND=}
-argument to the @code{CMPLX()} intrinsic).
-
-(@samp{CMPLX(0D0, 0D0)} returns a single-precision
-@code{COMPLEX} result, as required by standard FORTRAN 77.
-That's why so many compilers provide @code{DCMPLX()}, since
-@samp{DCMPLX(0D0, 0D0)} returns a @code{DOUBLE COMPLEX}
-result.
-Still, @code{DCMPLX()} converts even @code{REAL*16} arguments
-to their @code{REAL*8} equivalents in most dialects of
-Fortran, so neither it nor @code{CMPLX()} allow easy
-construction of arbitrary-precision values without
-potentially forcing a conversion involving extending or
-reducing precision.
-GNU Fortran provides such an intrinsic, called @code{COMPLEX()}.)
-
-@xref{Complex Intrinsic}, for information on easily constructing
-a @code{COMPLEX} value of arbitrary precision from @code{REAL}
-arguments.
-")
-
-DEFDOC (CONJG, "Complex conjugate.", "\
-Returns the complex conjugate:
-
-@example
-COMPLEX(REALPART(@var{@1@}), -IMAGPART(@var{@1@}))
-@end example
-")
-
-DEFDOC (DCONJG, "Complex conjugate (archaic).", ARCHAIC (CONJG, Conjg))
-
-DEFDOC (COS, "Cosine.", "\
-Returns the cosine of @var{@1@}, an angle measured
-in radians.
-
-@xref{ACos Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (CCOS, "Cosine (archaic).", ARCHAIC (COS, Cos))
-
-DEFDOC (DCOS, "Cosine (archaic).", ARCHAIC (COS, Cos))
-
-DEFDOC (CDCOS, "Cosine (archaic).", ARCHAIC (COS, Cos))
-
-DEFDOC (COSH, "Hyperbolic cosine.", "\
-Returns the hyperbolic cosine of @var{@1@}.
-")
-
-DEFDOC (DCOSH, "Hyperbolic cosine (archaic).", ARCHAIC (COSH, CosH))
-
-DEFDOC (SQRT, "Square root.", "\
-Returns the square root of @var{@1@}, which must
-not be negative.
-
-To calculate and represent the square root of a negative
-number, complex arithmetic must be used.
-For example, @samp{SQRT(COMPLEX(@var{@1@}))}.
-
-The inverse of this function is @samp{SQRT(@var{@1@}) * SQRT(@var{@1@})}.
-")
-
-DEFDOC (CSQRT, "Square root (archaic).", ARCHAIC (SQRT, SqRt))
-
-DEFDOC (DSQRT, "Square root (archaic).", ARCHAIC (SQRT, SqRt))
-
-DEFDOC (CDSQRT, "Square root (archaic).", ARCHAIC (SQRT, SqRt))
-
-DEFDOC (DBLE, "Convert to double precision.", "\
-Returns @var{@1@} converted to double precision
-(@code{REAL(KIND=2)}).
-If @var{@1@} is @code{COMPLEX}, the real part of
-@var{@1@} is used for the conversion
-and the imaginary part disregarded.
-
-@xref{Sngl Intrinsic}, for the function that converts
-to single precision.
-
-@xref{Int Intrinsic}, for the function that converts
-to @code{INTEGER}.
-
-@xref{Complex Intrinsic}, for the function that converts
-to @code{COMPLEX}.
-")
-
-DEFDOC (DIM, "Difference magnitude (non-negative subtract).", "\
-Returns @samp{@var{@1@}-@var{@2@}} if @var{@1@} is greater than
-@var{@2@}; otherwise returns zero.
-")
-
-DEFDOC (DDIM, "Difference magnitude (archaic).", ARCHAIC_2 (DIM, DiM))
-DEFDOC (IDIM, "Difference magnitude (archaic).", ARCHAIC_2 (DIM, DiM))
-
-DEFDOC (DPROD, "Double-precision product.", "\
-Returns @samp{DBLE(@var{@1@})*DBLE(@var{@2@})}.
-")
-
-DEFDOC (EXP, "Exponential.", "\
-Returns @samp{@var{e}**@var{@1@}}, where
-@var{e} is approximately 2.7182818.
-
-@xref{Log Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (CEXP, "Exponential (archaic).", ARCHAIC (EXP, Exp))
-
-DEFDOC (DEXP, "Exponential (archaic).", ARCHAIC (EXP, Exp))
-
-DEFDOC (CDEXP, "Exponential (archaic).", ARCHAIC (EXP, Exp))
-
-DEFDOC (FLOAT, "Conversion (archaic).", ARCHAIC (REAL, Real))
-DEFDOC (DFLOAT, "Conversion (archaic).", ARCHAIC (REAL, Real))
-
-DEFDOC (IFIX, "Conversion (archaic).", ARCHAIC (INT, Int))
-
-DEFDOC (LONG, "Conversion to @code{INTEGER(KIND=1)} (archaic).", "\
-Archaic form of @code{INT()} that is specific
-to one type for @var{@1@}.
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-")
-
-DEFDOC (SHORT, "Convert to @code{INTEGER(KIND=6)} value@99@truncated to whole number.", "\
-Returns @var{@1@} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=6)}.
-
-If @var{@1@} is type @code{COMPLEX}, its real part
-is truncated and converted, and its imaginary part is disregarded.
-
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-")
-
-DEFDOC (INT2, "Convert to @code{INTEGER(KIND=6)} value@99@truncated to whole number.", "\
-Returns @var{@1@} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=6)}.
-
-If @var{@1@} is type @code{COMPLEX}, its real part
-is truncated and converted, and its imaginary part is disregarded.
-
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-")
-
-DEFDOC (INT8, "Convert to @code{INTEGER(KIND=2)} value@99@truncated to whole number.", "\
-Returns @var{@1@} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=2)}.
-
-If @var{@1@} is type @code{COMPLEX}, its real part
-is truncated and converted, and its imaginary part is disregarded.
-
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-")
-
-DEFDOC (LEN, "Length of character entity.", "\
-Returns the length of @var{@1@}.
-
-If @var{@1@} is an array, the length of an element
-of @var{@1@} is returned.
-
-Note that @var{@1@} need not be defined when this
-intrinsic is invoked, since only the length, not
-the content, of @var{@1@} is needed.
-
-@xref{Bit_Size Intrinsic}, for the function that determines
-the size of its argument in bits.
-")
-
-DEFDOC (TAN, "Tangent.", "\
-Returns the tangent of @var{@1@}, an angle measured
-in radians.
-
-@xref{ATan Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (DTAN, "Tangent (archaic).", ARCHAIC (TAN, Tan))
-
-DEFDOC (TANH, "Hyperbolic tangent.", "\
-Returns the hyperbolic tangent of @var{@1@}.
-")
-
-DEFDOC (DTANH, "Hyperbolic tangent (archaic).", ARCHAIC (TANH, TanH))
-
-DEFDOC (SNGL, "Convert (archaic).", ARCHAIC (REAL, Real))
-
-DEFDOC (SIN, "Sine.", "\
-Returns the sine of @var{@1@}, an angle measured
-in radians.
-
-@xref{ASin Intrinsic}, for the inverse of this function.
-")
-
-DEFDOC (CSIN, "Sine (archaic).", ARCHAIC (SIN, Sin))
-
-DEFDOC (DSIN, "Sine (archaic).", ARCHAIC (SIN, Sin))
-
-DEFDOC (CDSIN, "Sine (archaic).", ARCHAIC (SIN, Sin))
-
-DEFDOC (SINH, "Hyperbolic sine.", "\
-Returns the hyperbolic sine of @var{@1@}.
-")
-
-DEFDOC (DSINH, "Hyperbolic sine (archaic).", ARCHAIC (SINH, SinH))
-
-DEFDOC (LSHIFT, "Left-shift bits.", "\
-Returns @var{@1@} shifted to the left
-@var{@2@} bits.
-
-Although similar to the expression
-@samp{@var{@1@}*(2**@var{@2@})}, there
-are important differences.
-For example, the sign of the result is
-not necessarily the same as the sign of
-@var{@1@}.
-
-Currently this intrinsic is defined assuming
-the underlying representation of @var{@1@}
-is as a two's-complement integer.
-It is unclear at this point whether that
-definition will apply when a different
-representation is involved.
-
-@xref{LShift Intrinsic}, for the inverse of this function.
-
-@xref{IShft Intrinsic}, for information
-on a more widely available left-shifting
-intrinsic that is also more precisely defined.
-")
-
-DEFDOC (RSHIFT, "Right-shift bits.", "\
-Returns @var{@1@} shifted to the right
-@var{@2@} bits.
-
-Although similar to the expression
-@samp{@var{@1@}/(2**@var{@2@})}, there
-are important differences.
-For example, the sign of the result is
-undefined.
-
-Currently this intrinsic is defined assuming
-the underlying representation of @var{@1@}
-is as a two's-complement integer.
-It is unclear at this point whether that
-definition will apply when a different
-representation is involved.
-
-@xref{RShift Intrinsic}, for the inverse of this function.
-
-@xref{IShft Intrinsic}, for information
-on a more widely available right-shifting
-intrinsic that is also more precisely defined.
-")
-
-DEFDOC (LGE, "Lexically greater than or equal.", "\
-Returns @samp{.TRUE.} if @samp{@var{@1@}.GE.@var{@2@}},
-@samp{.FALSE.} otherwise.
-@var{@1@} and @var{@2@} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{@1@} and @var{@2@} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-The lexical comparison intrinsics @code{LGe}, @code{LGt},
-@code{LLe}, and @code{LLt} differ from the corresponding
-intrinsic operators @code{.GE.}, @code{.GT.},
-@code{.LE.}, @code{.LT.}.
-Because the ASCII collating sequence is assumed,
-the following expressions always return @samp{.TRUE.}:
-
-@smallexample
-LGE ('0', ' ')
-LGE ('A', '0')
-LGE ('a', 'A')
-@end smallexample
-
-The following related expressions do @emph{not} always
-return @samp{.TRUE.}, as they are not necessarily evaluated
-assuming the arguments use ASCII encoding:
-
-@smallexample
-'0' .GE. ' '
-'A' .GE. '0'
-'a' .GE. 'A'
-@end smallexample
-
-The same difference exists
-between @code{LGt} and @code{.GT.};
-between @code{LLe} and @code{.LE.}; and
-between @code{LLt} and @code{.LT.}.
-")
-
-DEFDOC (LGT, "Lexically greater than.", "\
-Returns @samp{.TRUE.} if @samp{@var{@1@}.GT.@var{@2@}},
-@samp{.FALSE.} otherwise.
-@var{@1@} and @var{@2@} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{@1@} and @var{@2@} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-@xref{LGe Intrinsic}, for information on the distinction
-between the @code{@0@} intrinsic and the @code{.GT.}
-operator.
-")
-
-DEFDOC (LLE, "Lexically less than or equal.", "\
-Returns @samp{.TRUE.} if @samp{@var{@1@}.LE.@var{@2@}},
-@samp{.FALSE.} otherwise.
-@var{@1@} and @var{@2@} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{@1@} and @var{@2@} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-@xref{LGe Intrinsic}, for information on the distinction
-between the @code{@0@} intrinsic and the @code{.LE.}
-operator.
-")
-
-DEFDOC (LLT, "Lexically less than.", "\
-Returns @samp{.TRUE.} if @samp{@var{@1@}.LT.@var{@2@}},
-@samp{.FALSE.} otherwise.
-@var{@1@} and @var{@2@} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{@1@} and @var{@2@} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-@xref{LGe Intrinsic}, for information on the distinction
-between the @code{@0@} intrinsic and the @code{.LT.}
-operator.
-")
-
-DEFDOC (SIGN, "Apply sign to magnitude.", "\
-Returns @samp{ABS(@var{@1@})*@var{s}}, where
-@var{s} is +1 if @samp{@var{@2@}.GE.0},
--1 otherwise.
-
-@xref{Abs Intrinsic}, for the function that returns
-the magnitude of a value.
-")
-
-DEFDOC (DSIGN, "Apply sign to magnitude (archaic).", ARCHAIC_2 (SIGN, Sign))
-DEFDOC (ISIGN, "Apply sign to magnitude (archaic).", ARCHAIC_2 (SIGN, Sign))
-
-DEFDOC (REAL, "Convert value to type @code{REAL(KIND=1)}.", "\
-Converts @var{@1@} to @code{REAL(KIND=1)}.
-
-Use of @code{@0@()} with a @code{COMPLEX} argument
-(other than @code{COMPLEX(KIND=1)}) is restricted to the following case:
-
-@example
-REAL(REAL(@1@))
-@end example
-
-@noindent
-This expression converts the real part of @1@ to
-@code{REAL(KIND=1)}.
-
-@xref{RealPart Intrinsic}, for information on a GNU Fortran
-intrinsic that extracts the real part of an arbitrary
-@code{COMPLEX} value.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-")
-
-DEFDOC (DREAL, "Convert value to type @code{REAL(KIND=2)}.", "\
-Converts @var{@1@} to @code{REAL(KIND=2)}.
-
-If @var{@1@} is type @code{COMPLEX}, its real part
-is converted (if necessary) to @code{REAL(KIND=2)},
-and its imaginary part is disregarded.
-
-Although this intrinsic is not standard Fortran,
-it is a popular extension offered by many compilers
-that support @code{DOUBLE COMPLEX}, since it offers
-the easiest way to extract the real part of a @code{DOUBLE COMPLEX}
-value without using the Fortran 90 @code{REAL()} intrinsic
-in a way that produces a return value inconsistent with
-the way many FORTRAN 77 compilers handle @code{REAL()} of
-a @code{DOUBLE COMPLEX} value.
-
-@xref{RealPart Intrinsic}, for information on a GNU Fortran
-intrinsic that avoids these areas of confusion.
-
-@xref{Dble Intrinsic}, for information on the standard FORTRAN 77
-replacement for @code{DREAL()}.
-
-@xref{REAL() and AIMAG() of Complex}, for more information on
-this issue.
-")
-
-DEFDOC (IMAGPART, "Extract imaginary part of complex.", "\
-The imaginary part of @var{@1@} is returned, without conversion.
-
-@emph{Note:} The way to do this in standard Fortran 90
-is @samp{AIMAG(@var{@1@})}.
-However, when, for example, @var{@1@} is @code{DOUBLE COMPLEX},
-@samp{AIMAG(@var{@1@})} means something different for some compilers
-that are not true Fortran 90 compilers but offer some
-extensions standardized by Fortran 90 (such as the
-@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}).
-
-The advantage of @code{@0@()} is that, while not necessarily
-more or less portable than @code{AIMAG()}, it is more likely to
-cause a compiler that doesn't support it to produce a diagnostic
-than generate incorrect code.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-")
-
-DEFDOC (COMPLEX, "Build complex value from real and@99@imaginary parts.", "\
-Returns a @code{COMPLEX} value that has @samp{@1@} and @samp{@2@} as its
-real and imaginary parts, respectively.
-
-If @var{@1@} and @var{@2@} are the same type, and that type is not
-@code{INTEGER}, no data conversion is performed, and the type of
-the resulting value has the same kind value as the types
-of @var{@1@} and @var{@2@}.
-
-If @var{@1@} and @var{@2@} are not the same type, the usual type-promotion
-rules are applied to both, converting either or both to the
-appropriate @code{REAL} type.
-The type of the resulting value has the same kind value as the
-type to which both @var{@1@} and @var{@2@} were converted, in this case.
-
-If @var{@1@} and @var{@2@} are both @code{INTEGER}, they are both converted
-to @code{REAL(KIND=1)}, and the result of the @code{@0@()}
-invocation is type @code{COMPLEX(KIND=1)}.
-
-@emph{Note:} The way to do this in standard Fortran 90
-is too hairy to describe here, but it is important to
-note that @samp{CMPLX(D1,D2)} returns a @code{COMPLEX(KIND=1)}
-result even if @samp{D1} and @samp{D2} are type @code{REAL(KIND=2)}.
-Hence the availability of @code{COMPLEX()} in GNU Fortran.
-")
-
-DEFDOC (LOC, "Address of entity in core.", "\
-The @code{LOC()} intrinsic works the
-same way as the @code{%LOC()} construct.
-@xref{%LOC(),,The @code{%LOC()} Construct}, for
-more information.
-")
-
-DEFDOC (REALPART, "Extract real part of complex.", "\
-The real part of @var{@1@} is returned, without conversion.
-
-@emph{Note:} The way to do this in standard Fortran 90
-is @samp{REAL(@var{@1@})}.
-However, when, for example, @var{@1@} is @code{COMPLEX(KIND=2)},
-@samp{REAL(@var{@1@})} means something different for some compilers
-that are not true Fortran 90 compilers but offer some
-extensions standardized by Fortran 90 (such as the
-@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}).
-
-The advantage of @code{@0@()} is that, while not necessarily
-more or less portable than @code{REAL()}, it is more likely to
-cause a compiler that doesn't support it to produce a diagnostic
-than generate incorrect code.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-")
-
-DEFDOC (GETARG, "Obtain command-line argument.", "\
-Sets @var{@2@} to the @var{@1@}-th command-line argument (or to all
-blanks if there are fewer than @var{@2@} command-line arguments);
-@code{CALL @0@(0, @var{value})} sets @var{value} to the name of the
-program (on systems that support this feature).
-
-@xref{IArgC Intrinsic}, for information on how to get the number
-of arguments.
-")
-
-DEFDOC (ABORT, "Abort the program.", "\
-Prints a message and potentially causes a core dump via @code{abort(3)}.
-")
-
-DEFDOC (EXIT, "Terminate the program.", "\
-Exit the program with status @var{@1@} after closing open Fortran
-I/O units and otherwise behaving as @code{exit(2)}.
-If @var{@1@} is omitted the canonical `success' value
-will be returned to the system.
-")
-
-DEFDOC (IARGC, "Obtain count of command-line arguments.", "\
-Returns the number of command-line arguments.
-
-This count does not include the specification of the program
-name itself.
-")
-
-DEFDOC (CTIME_func, "Convert time to Day Mon dd hh:mm:ss yyyy.", "\
-Converts @var{@1@}, a system time value, such as returned by
-@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995},
-and returns that string as the function value.
-
-@xref{Time8 Intrinsic}.
-")
-
-DEFDOC (CTIME_subr, "Convert time to Day Mon dd hh:mm:ss yyyy.", "\
-Converts @var{@1@}, a system time value, such as returned by
-@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995},
-and returns that string in @var{@2@}.
-
-@xref{Time8 Intrinsic}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-")
-
-DEFDOC (DATE, "Get current date as dd-Mon-yy.", "\
-Returns @var{@1@} in the form @samp{@var{dd}-@var{mmm}-@var{yy}},
-representing the numeric day of the month @var{dd}, a three-character
-abbreviation of the month name @var{mmm} and the last two digits of
-the year @var{yy}, e.g.@: @samp{25-Nov-96}.
-
-@cindex Y2K compliance
-@cindex Year 2000 compliance
-This intrinsic is not recommended, due to the year 2000 approaching.
-Therefore, programs making use of this intrinsic
-might not be Year 2000 (Y2K) compliant.
-@xref{CTime Intrinsic (subroutine)}, for information on obtaining more digits
-for the current (or any) date.
-")
-
-DEFDOC (DTIME_func, "Get elapsed time since last time.", "\
-Initially, return the number of seconds of runtime
-since the start of the process's execution
-as the function value,
-and the user and system components of this in @samp{@var{@1@}(1)}
-and @samp{@var{@1@}(2)} respectively.
-The functions' value is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}.
-
-Subsequent invocations of @samp{@0@()} return values accumulated since the
-previous invocation.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (DTIME_subr, "Get elapsed time since last time.", "\
-Initially, return the number of seconds of runtime
-since the start of the process's execution
-in @var{@2@},
-and the user and system components of this in @samp{@var{@1@}(1)}
-and @samp{@var{@1@}(2)} respectively.
-The value of @var{@2@} is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}.
-
-Subsequent invocations of @samp{@0@()} set values based on accumulations
-since the previous invocation.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-")
-
-DEFDOC (ETIME_func, "Get elapsed time for process.", "\
-Return the number of seconds of runtime
-since the start of the process's execution
-as the function value,
-and the user and system components of this in @samp{@var{@1@}(1)}
-and @samp{@var{@1@}(2)} respectively.
-The functions' value is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-")
-
-DEFDOC (ETIME_subr, "Get elapsed time for process.", "\
-Return the number of seconds of runtime
-since the start of the process's execution
-in @var{@2@},
-and the user and system components of this in @samp{@var{@1@}(1)}
-and @samp{@var{@1@}(2)} respectively.
-The value of @var{@2@} is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-")
-
-DEFDOC (FDATE_func, "Get current time as Day Mon dd hh:mm:ss yyyy.", "\
-Returns the current date (using the same format as @code{CTIME()}).
-
-Equivalent to:
-
-@example
-CTIME(TIME8())
-@end example
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-@xref{CTime Intrinsic (function)}.
-")
-
-DEFDOC (FDATE_subr, "Get current time as Day Mon dd hh:mm:ss yyyy.", "\
-Returns the current date (using the same format as @code{CTIME()})
-in @var{@1@}.
-
-Equivalent to:
-
-@example
-CALL CTIME(@var{@1@}, TIME8())
-@end example
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-@xref{CTime Intrinsic (subroutine)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-")
-
-DEFDOC (GMTIME, "Convert time to GMT time info.", "\
-Given a system time value @var{@1@}, fills @var{@2@} with values
-extracted from it appropriate to the GMT time zone using
-@code{gmtime(3)}.
-
-The array elements are as follows:
-
-@enumerate
-@item
-Seconds after the minute, range 0--59 or 0--61 to allow for leap
-seconds
-
-@item
-Minutes after the hour, range 0--59
-
-@item
-Hours past midnight, range 0--23
-
-@item
-Day of month, range 0--31
-
-@item
-Number of months since January, range 0--12
-
-@item
-Years since 1900
-
-@item
-Number of days since Sunday, range 0--6
-
-@item
-Days since January 1
-
-@item
-Daylight savings indicator: positive if daylight savings is in effect,
-zero if not, and negative if the information isn't available.
-@end enumerate
-")
-
-DEFDOC (LTIME, "Convert time to local time info.", "\
-Given a system time value @var{@1@}, fills @var{@2@} with values
-extracted from it appropriate to the GMT time zone using
-@code{localtime(3)}.
-
-The array elements are as follows:
-
-@enumerate
-@item
-Seconds after the minute, range 0--59 or 0--61 to allow for leap
-seconds
-
-@item
-Minutes after the hour, range 0--59
-
-@item
-Hours past midnight, range 0--23
-
-@item
-Day of month, range 0--31
-
-@item
-Number of months since January, range 0--12
-
-@item
-Years since 1900
-
-@item
-Number of days since Sunday, range 0--6
-
-@item
-Days since January 1
-
-@item
-Daylight savings indicator: positive if daylight savings is in effect,
-zero if not, and negative if the information isn't available.
-@end enumerate
-")
-
-DEFDOC (IDATE_unix, "Get local time info.", "\
-Fills @var{@1@} with the numerical values at the current local time.
-The day (in the range 1--31), month (in the range 1--12),
-and year appear in elements 1, 2, and 3 of @var{@1@}, respectively.
-The year has four significant digits.
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-")
-
-DEFDOC (IDATE_vxt, "Get local time info (VAX/VMS).", "\
-Returns the numerical values of the current local time.
-The month (in the range 1--12) is returned in @var{@1@},
-the day (in the range 1--31) in @var{@2@},
-and the year in @var{@3@} (in the range 0--99).
-
-@cindex Y2K compliance
-@cindex Year 2000 compliance
-@cindex wraparound, Y2K
-@cindex limits, Y2K
-This intrinsic is not recommended, due to the fact that
-its return value for year wraps around century boundaries
-(change from a larger value to a smaller one).
-Therefore, programs making use of this intrinsic, for
-instance, might not be Year 2000 (Y2K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-as of the Year 2000.
-
-@xref{IDate Intrinsic (UNIX)}, for information on obtaining more digits
-for the current date.
-")
-
-DEFDOC (ITIME, "Get local time of day.", "\
-Returns the current local time hour, minutes, and seconds in elements
-1, 2, and 3 of @var{@1@}, respectively.
-")
-
-DEFDOC (MCLOCK, "Get number of clock ticks for process.", "\
-Returns the number of clock ticks since the start of the process.
-Supported on systems with @code{clock(3)} (q.v.).
-
-@cindex wraparound, timings
-@cindex limits, timings
-This intrinsic is not fully portable, such as to systems
-with 32-bit @code{INTEGER} types but supporting times
-wider than 32 bits.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-@xref{MClock8 Intrinsic}, for information on a
-similar intrinsic that might be portable to more
-GNU Fortran implementations, though to fewer
-Fortran compilers.
-
-If the system does not support @code{clock(3)},
--1 is returned.
-")
-
-DEFDOC (MCLOCK8, "Get number of clock ticks for process.", "\
-Returns the number of clock ticks since the start of the process.
-Supported on systems with @code{clock(3)} (q.v.).
-
-@cindex wraparound, timings
-@cindex limits, timings
-@emph{Warning:} this intrinsic does not increase the range
-of the timing values over that returned by @code{clock(3)}.
-On a system with a 32-bit @code{clock(3)},
-@code{@0@} will return a 32-bit value,
-even though converted to an @samp{INTEGER(KIND=2)} value.
-That means overflows of the 32-bit value can still occur.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-No Fortran implementations other than GNU Fortran are
-known to support this intrinsic at the time of this
-writing.
-@xref{MClock Intrinsic}, for information on a
-similar intrinsic that might be portable to more Fortran
-compilers, though to fewer GNU Fortran implementations.
-
-If the system does not support @code{clock(3)},
--1 is returned.
-")
-
-DEFDOC (SECNDS, "Get local time offset since midnight.", "\
-Returns the local time in seconds since midnight minus the value
-@var{@1@}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-This values returned by this intrinsic
-become numerically less than previous values
-(they wrap around) during a single run of the
-compiler program, under normal circumstances
-(such as running through the midnight hour).
-")
-
-DEFDOC (SECOND_func, "Get CPU time for process in seconds.", "\
-Returns the process's runtime in seconds---the same value as the
-UNIX function @code{etime} returns.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-")
-
-DEFDOC (SECOND_subr, "Get CPU time for process@99@in seconds.", "\
-Returns the process's runtime in seconds in @var{@1@}---the same value
-as the UNIX function @code{etime} returns.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-This routine is known from Cray Fortran. @xref{CPU_Time Intrinsic},
-for a standard equivalent.
-")
-
-DEFDOC (SYSTEM_CLOCK, "Get current system clock value.", "\
-Returns in @var{@1@} the current value of the system clock; this is
-the value returned by the UNIX function @code{times(2)}
-in this implementation, but
-isn't in general.
-@var{@2@} is the number of clock ticks per second and
-@var{@3@} is the maximum value this can take, which isn't very useful
-in this implementation since it's just the maximum C @code{unsigned
-int} value.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-")
-
-DEFDOC (CPU_TIME, "Get current CPU time.", "\
-Returns in @var{@1@} the current value of the system time.
-This implementation of the Fortran 95 intrinsic is just an alias for
-@code{second} @xref{Second Intrinsic (subroutine)}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-")
-
-DEFDOC (TIME8, "Get current time as time value.", "\
-Returns the current time encoded as a long integer
-(in the manner of the UNIX function @code{time(3)}).
-This value is suitable for passing to @code{CTIME},
-@code{GMTIME}, and @code{LTIME}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-@emph{Warning:} this intrinsic does not increase the range
-of the timing values over that returned by @code{time(3)}.
-On a system with a 32-bit @code{time(3)},
-@code{@0@} will return a 32-bit value,
-even though converted to an @samp{INTEGER(KIND=2)} value.
-That means overflows of the 32-bit value can still occur.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-No Fortran implementations other than GNU Fortran are
-known to support this intrinsic at the time of this
-writing.
-@xref{Time Intrinsic (UNIX)}, for information on a
-similar intrinsic that might be portable to more Fortran
-compilers, though to fewer GNU Fortran implementations.
-")
-
-DEFDOC (TIME_unix, "Get current time as time value.", "\
-Returns the current time encoded as an integer
-(in the manner of the UNIX function @code{time(3)}).
-This value is suitable for passing to @code{CTIME},
-@code{GMTIME}, and @code{LTIME}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-This intrinsic is not fully portable, such as to systems
-with 32-bit @code{INTEGER} types but supporting times
-wider than 32 bits.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-@xref{Time8 Intrinsic}, for information on a
-similar intrinsic that might be portable to more
-GNU Fortran implementations, though to fewer
-Fortran compilers.
-")
-
-#define BES(num,n,val) "\
-Calculates the Bessel function of the " #num " kind of \
-order " #n " of @var{@" #val "@}.\n\
-See @code{bessel(3m)}, on whose implementation the \
-function depends.\
-"
-
-DEFDOC (BESJ0, "Bessel function.", BES (first, 0, 1))
-DEFDOC (BESJ1, "Bessel function.", BES (first, 1, 1))
-DEFDOC (BESJN, "Bessel function.", BES (first, @var{N}, 2))
-DEFDOC (BESY0, "Bessel function.", BES (second, 0, 1))
-DEFDOC (BESY1, "Bessel function.", BES (second, 1, 1))
-DEFDOC (BESYN, "Bessel function.", BES (second, @var{N}, 2))
-DEFDOC (DBESJ0, "Bessel function (archaic).", ARCHAIC (BESJ0, BesJ0))
-DEFDOC (DBESJ1, "Bessel function (archaic).", ARCHAIC (BESJ1, BesJ1))
-DEFDOC (DBESJN, "Bessel function (archaic).", ARCHAIC_2nd (BESJN, BesJN))
-DEFDOC (DBESY0, "Bessel function (archaic).", ARCHAIC (BESY0, BesY0))
-DEFDOC (DBESY1, "Bessel function (archaic).", ARCHAIC (BESY1, BesY1))
-DEFDOC (DBESYN, "Bessel function (archaic).", ARCHAIC_2nd (BESYN, BesYN))
-
-DEFDOC (ERF, "Error function.", "\
-Returns the error function of @var{@1@}.
-See @code{erf(3m)}, which provides the implementation.
-")
-
-DEFDOC (ERFC, "Complementary error function.", "\
-Returns the complementary error function of @var{@1@}:
-@samp{ERFC(R) = 1 - ERF(R)} (except that the result might be more
-accurate than explicitly evaluating that formulae would give).
-See @code{erfc(3m)}, which provides the implementation.
-")
-
-DEFDOC (DERF, "Error function (archaic).", ARCHAIC (ERF, ErF))
-DEFDOC (DERFC, "Complementary error function (archaic).", ARCHAIC (ERFC, ErFC))
-
-DEFDOC (IRAND, "Random number.", "\
-Returns a uniform quasi-random number up to a system-dependent limit.
-If @var{@1@} is 0, the next number in sequence is returned; if
-@var{@1@} is 1, the generator is restarted by calling the UNIX function
-@samp{srand(0)}; if @var{@1@} has any other value,
-it is used as a new seed with @code{srand()}.
-
-@xref{SRand Intrinsic}.
-
-@emph{Note:} As typically implemented (by the routine of the same
-name in the C library), this random number generator is a very poor
-one, though the BSD and GNU libraries provide a much better
-implementation than the `traditional' one.
-On a different system you almost certainly want to use something better.
-")
-
-DEFDOC (RAND, "Random number.", "\
-Returns a uniform quasi-random number between 0 and 1.
-If @var{@1@} is 0, the next number in sequence is returned; if
-@var{@1@} is 1, the generator is restarted by calling @samp{srand(0)};
-if @var{@1@} has any other value, it is used as a new seed with
-@code{srand}.
-
-@xref{SRand Intrinsic}.
-
-@emph{Note:} As typically implemented (by the routine of the same
-name in the C library), this random number generator is a very poor
-one, though the BSD and GNU libraries provide a much better
-implementation than the `traditional' one.
-On a different system you
-almost certainly want to use something better.
-")
-
-DEFDOC (SRAND, "Random seed.", "\
-Reinitializes the generator with the seed in @var{@1@}.
-@xref{IRand Intrinsic}.
-@xref{Rand Intrinsic}.
-")
-
-DEFDOC (ACCESS, "Check file accessibility.", "\
-Checks file @var{@1@} for accessibility in the mode specified by @var{@2@} and
-returns 0 if the file is accessible in that mode, otherwise an error
-code if the file is inaccessible or @var{@2@} is invalid.
-See @code{access(2)}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-@var{@2@} may be a concatenation of any of the following characters:
-
-@table @samp
-@item r
-Read permission
-
-@item w
-Write permission
-
-@item x
-Execute permission
-
-@item @kbd{SPC}
-Existence
-@end table
-")
-
-DEFDOC (CHDIR_subr, "Change directory.", "\
-Sets the current working directory to be @var{@1@}.
-If the @var{@2@} argument is supplied, it contains 0
-on success or a nonzero error code otherwise upon return.
-See @code{chdir(3)}.
-
-@emph{Caution:} Using this routine during I/O to a unit connected with a
-non-absolute file name can cause subsequent I/O on such a unit to fail
-because the I/O library might reopen files by name.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@2@} argument.
-")
-
-DEFDOC (CHDIR_func, "Change directory.", "\
-Sets the current working directory to be @var{@1@}.
-Returns 0 on success or a nonzero error code.
-See @code{chdir(3)}.
-
-@emph{Caution:} Using this routine during I/O to a unit connected with a
-non-absolute file name can cause subsequent I/O on such a unit to fail
-because the I/O library might reopen files by name.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (CHMOD_func, "Change file modes.", "\
-Changes the access mode of file @var{@1@} according to the
-specification @var{@2@}, which is given in the format of
-@code{chmod(1)}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-Currently, @var{@1@} must not contain the single quote
-character.
-
-Returns 0 on success or a nonzero error code otherwise.
-
-Note that this currently works
-by actually invoking @code{/bin/chmod} (or the @code{chmod} found when
-the library was configured) and so might fail in some circumstances and
-will, anyway, be slow.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (CHMOD_subr, "Change file modes.", "\
-Changes the access mode of file @var{@1@} according to the
-specification @var{@2@}, which is given in the format of
-@code{chmod(1)}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-Currently, @var{@1@} must not contain the single quote
-character.
-
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Note that this currently works
-by actually invoking @code{/bin/chmod} (or the @code{chmod} found when
-the library was configured) and so might fail in some circumstances and
-will, anyway, be slow.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (GETCWD_func, "Get current working directory.", "\
-Places the current working directory in @var{@1@}.
-Returns 0 on
-success, otherwise a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{getcwd(3)}
-or @code{getwd(3)}).
-")
-
-DEFDOC (GETCWD_subr, "Get current working directory.", "\
-Places the current working directory in @var{@1@}.
-If the @var{@2@} argument is supplied, it contains 0
-success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{getcwd(3)}
-or @code{getwd(3)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@2@} argument.
-")
-
-DEFDOC (FSTAT_func, "Get file information.", "\
-Obtains data about the file open on Fortran I/O unit @var{@1@} and
-places them in the array @var{@2@}.
-The values in this array are
-extracted from the @code{stat} structure as returned by
-@code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-Returns 0 on success or a nonzero error code.
-")
-
-DEFDOC (FSTAT_subr, "Get file information.", "\
-Obtains data about the file open on Fortran I/O unit @var{@1@} and
-places them in the array @var{@2@}.
-The values in this array are
-extracted from the @code{stat} structure as returned by
-@code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (LSTAT_func, "Get file information.", "\
-Obtains data about the given file @var{@1@} and places them in the array
-@var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-If @var{@1@} is a symbolic link it returns data on the
-link itself, so the routine is available only on systems that support
-symbolic links.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-Returns 0 on success or a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{lstat(2)}).
-")
-
-DEFDOC (LSTAT_subr, "Get file information.", "\
-Obtains data about the given file @var{@1@} and places them in the array
-@var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-If @var{@1@} is a symbolic link it returns data on the
-link itself, so the routine is available only on systems that support
-symbolic links.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{lstat(2)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (STAT_func, "Get file information.", "\
-Obtains data about the given file @var{@1@} and places them in the array
-@var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-Returns 0 on success or a nonzero error code.
-")
-
-DEFDOC (STAT_subr, "Get file information.", "\
-Obtains data about the given file @var{@1@} and places them in the array
-@var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (LINK_subr, "Make hard link in file system.", "\
-Makes a (hard) link from file @var{@1@} to @var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{@1@} and @var{@2@}---otherwise,
-trailing blanks in @var{@1@} and @var{@2@} are ignored.
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-See @code{link(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (LINK_func, "Make hard link in file system.", "\
-Makes a (hard) link from file @var{@1@} to @var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{@1@} and @var{@2@}---otherwise,
-trailing blanks in @var{@1@} and @var{@2@} are ignored.
-Returns 0 on success or a nonzero error code.
-See @code{link(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (SYMLNK_subr, "Make symbolic link in file system.", "\
-Makes a symbolic link from file @var{@1@} to @var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{@1@} and @var{@2@}---otherwise,
-trailing blanks in @var{@1@} and @var{@2@} are ignored.
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{symlink(2)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (SYMLNK_func, "Make symbolic link in file system.", "\
-Makes a symbolic link from file @var{@1@} to @var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{@1@} and @var{@2@}---otherwise,
-trailing blanks in @var{@1@} and @var{@2@} are ignored.
-Returns 0 on success or a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{symlink(2)}).
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (RENAME_subr, "Rename file.", "\
-Renames the file @var{@1@} to @var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{@1@} and @var{@2@}---otherwise,
-trailing blanks in @var{@1@} and @var{@2@} are ignored.
-See @code{rename(2)}.
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (RENAME_func, "Rename file.", "\
-Renames the file @var{@1@} to @var{@2@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{@1@} and @var{@2@}---otherwise,
-trailing blanks in @var{@1@} and @var{@2@} are ignored.
-See @code{rename(2)}.
-Returns 0 on success or a nonzero error code.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (UMASK_subr, "Set file creation permissions mask.", "\
-Sets the file creation mask to @var{@1@} and returns the old value in
-argument @var{@2@} if it is supplied.
-See @code{umask(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-")
-
-DEFDOC (UMASK_func, "Set file creation permissions mask.", "\
-Sets the file creation mask to @var{@1@} and returns the old value.
-See @code{umask(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (UNLINK_subr, "Unlink file.", "\
-Unlink the file @var{@1@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-If the @var{@2@} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-See @code{unlink(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@2@} argument.
-")
-
-DEFDOC (UNLINK_func, "Unlink file.", "\
-Unlink the file @var{@1@}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-Returns 0 on success or a nonzero error code.
-See @code{unlink(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (GERROR, "Get error message for last error.", "\
-Returns the system error message corresponding to the last system
-error (C @code{errno}).
-")
-
-DEFDOC (IERRNO, "Get error number for last error.", "\
-Returns the last system error number (corresponding to the C
-@code{errno}).
-")
-
-DEFDOC (PERROR, "Print error message for last error.", "\
-Prints (on the C @code{stderr} stream) a newline-terminated error
-message corresponding to the last system error.
-This is prefixed by @var{@1@}, a colon and a space.
-See @code{perror(3)}.
-")
-
-DEFDOC (GETGID, "Get process group id.", "\
-Returns the group id for the current process.
-")
-
-DEFDOC (GETUID, "Get process user id.", "\
-Returns the user id for the current process.
-")
-
-DEFDOC (GETPID, "Get process id.", "\
-Returns the process id for the current process.
-")
-
-DEFDOC (GETENV, "Get environment variable.", "\
-Sets @var{@2@} to the value of environment variable given by the
-value of @var{@1@} (@code{$name} in shell terms) or to blanks if
-@code{$name} has not been set.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{@1@}---otherwise,
-trailing blanks in @var{@1@} are ignored.
-")
-
-DEFDOC (GETLOG, "Get login name.", "\
-Returns the login name for the process in @var{@1@}.
-
-@emph{Caution:} On some systems, the @code{getlogin(3)}
-function, which this intrinsic calls at run time,
-is either not implemented or returns a null pointer.
-In the latter case, this intrinsic returns blanks
-in @var{@1@}.
-")
-
-DEFDOC (HOSTNM_func, "Get host name.", "\
-Fills @var{@1@} with the system's host name returned by
-@code{gethostname(2)}, returning 0 on success or a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{gethostname(2)}).
-
-On some systems (specifically SCO) it might be necessary to link the
-``socket'' library if you call this routine.
-Typically this means adding @samp{-lg2c -lsocket -lm}
-to the @code{g77} command line when linking the program.
-")
-
-DEFDOC (HOSTNM_subr, "Get host name.", "\
-Fills @var{@1@} with the system's host name returned by
-@code{gethostname(2)}.
-If the @var{@2@} argument is supplied, it contains
-0 on success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{gethostname(2)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@2@} argument.
-
-On some systems (specifically SCO) it might be necessary to link the
-``socket'' library if you call this routine.
-Typically this means adding @samp{-lg2c -lsocket -lm}
-to the @code{g77} command line when linking the program.
-")
-
-DEFDOC (FLUSH, "Flush buffered output.", "\
-Flushes Fortran unit(s) currently open for output.
-Without the optional argument, all such units are flushed,
-otherwise just the unit specified by @var{@1@}.
-
-Some non-GNU implementations of Fortran provide this intrinsic
-as a library procedure that might or might not support the
-(optional) @var{@1@} argument.
-")
-
-DEFDOC (FNUM, "Get file descriptor from Fortran unit number.", "\
-Returns the Unix file descriptor number corresponding to the open
-Fortran I/O unit @var{@1@}.
-This could be passed to an interface to C I/O routines.
-")
-
-#define IOWARN "
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-"
-
-DEFDOC (FGET_func, "Read a character from unit 5 stream-wise.", "\
-Reads a single character into @var{@1@} in stream mode from unit 5
-(by-passing normal formatted input) using @code{getc(3)}.
-Returns 0 on
-success, @minus{}1 on end-of-file, and the error code from
-@code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FGET_subr, "Read a character from unit 5 stream-wise.", "\
-Reads a single character into @var{@1@} in stream mode from unit 5
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns in
-@var{@2@} 0 on success, @minus{}1 on end-of-file, and the error code
-from @code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FGETC_func, "Read a character stream-wise.", "\
-Reads a single character into @var{@2@} in stream mode from unit @var{@1@}
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns 0 on
-success, @minus{}1 on end-of-file, and the error code from
-@code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FGETC_subr, "Read a character stream-wise.", "\
-Reads a single character into @var{@2@} in stream mode from unit @var{@1@}
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns in
-@var{@3@} 0 on success, @minus{}1 on end-of-file, and the error code from
-@code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FPUT_func, "Write a character to unit 6 stream-wise.", "\
-Writes the single character @var{@1@} in stream mode to unit 6
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns 0 on
-success, the error code from @code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FPUT_subr, "Write a character to unit 6 stream-wise.", "\
-Writes the single character @var{@1@} in stream mode to unit 6
-(by-passing normal formatted output) using @code{putc(3)}.
-Returns in
-@var{@2@} 0 on success, the error code from @code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FPUTC_func, "Write a character stream-wise.", "\
-Writes the single character @var{@2@} in stream mode to unit @var{@1@}
-(by-passing normal formatted output) using @code{putc(3)}.
-Returns 0 on
-success, the error code from @code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FPUTC_subr, "Write a character stream-wise.", "\
-Writes the single character @var{@1@} in stream mode to unit 6
-(by-passing normal formatted output) using @code{putc(3)}.
-Returns in
-@var{@2@} 0 on success, the error code from @code{ferror(3)} otherwise.
-" IOWARN)
-
-DEFDOC (FSEEK, "Position file (low-level).", "\
-Attempts to move Fortran unit @var{@1@} to the specified
-@var{@2@}: absolute offset if @var{@3@}=0; relative to the
-current offset if @var{@3@}=1; relative to the end of the file if
-@var{@3@}=2.
-It branches to label @var{@4@} if @var{@1@} is
-not open or if the call otherwise fails.
-")
-
-DEFDOC (FTELL_func, "Get file position (low-level).", "\
-Returns the current offset of Fortran unit @var{@1@}
-(or @minus{}1 if @var{@1@} is not open).
-")
-
-DEFDOC (FTELL_subr, "Get file position (low-level).", "\
-Sets @var{@2@} to the current offset of Fortran unit @var{@1@}
-(or to @minus{}1 if @var{@1@} is not open).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-")
-
-DEFDOC (ISATTY, "Is unit connected to a terminal?", "\
-Returns @code{.TRUE.} if and only if the Fortran I/O unit
-specified by @var{@1@} is connected
-to a terminal device.
-See @code{isatty(3)}.
-")
-
-DEFDOC (TTYNAM_func, "Get name of terminal device for unit.", "\
-Returns the name of the terminal device open on logical unit
-@var{@1@} or a blank string if @var{@1@} is not connected to a
-terminal.
-")
-
-DEFDOC (TTYNAM_subr, "Get name of terminal device for unit.", "\
-Sets @var{@2@} to the name of the terminal device open on logical unit
-@var{@1@} or to a blank string if @var{@1@} is not connected to a
-terminal.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-")
-
-DEFDOC (SIGNAL_subr, "Muck with signal handling.", "\
-If @var{@2@} is a an @code{EXTERNAL} routine, arranges for it to be
-invoked with a single integer argument (of system-dependent length)
-when signal @var{@1@} occurs.
-If @var{@2@} is an integer, it can be
-used to turn off handling of signal @var{@1@} or revert to its default
-action.
-See @code{signal(2)}.
-
-Note that @var{@2@} will be called using C conventions,
-so the value of its argument in Fortran terms
-Fortran terms is obtained by applying @code{%LOC()} (or @code{LOC()}) to it.
-
-The value returned by @code{signal(2)} is written to @var{@3@}, if
-that argument is supplied.
-Otherwise the return value is ignored.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-
-@emph{Warning:} Use of the @code{libf2c} run-time library function
-@samp{signal_} directly
-(such as via @samp{EXTERNAL SIGNAL})
-requires use of the @code{%VAL()} construct
-to pass an @code{INTEGER} value
-(such as @samp{SIG_IGN} or @samp{SIG_DFL})
-for the @var{@2@} argument.
-
-However, while @samp{CALL SIGNAL(@var{signum}, %VAL(SIG_IGN))}
-works when @samp{SIGNAL} is treated as an external procedure
-(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine),
-this construct is not valid when @samp{SIGNAL} is recognized
-as the intrinsic of that name.
-
-Therefore, for maximum portability and reliability,
-code such references to the @samp{SIGNAL} facility as follows:
-
-@smallexample
-INTRINSIC SIGNAL
-@dots{}
-CALL SIGNAL(@var{signum}, SIG_IGN)
-@end smallexample
-
-@code{g77} will compile such a call correctly,
-while other compilers will generally either do so as well
-or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic,
-allowing you to take appropriate action.
-")
-
-DEFDOC (SIGNAL_func, "Muck with signal handling.", "\
-If @var{@2@} is a an @code{EXTERNAL} routine, arranges for it to be
-invoked with a single integer argument (of system-dependent length)
-when signal @var{@1@} occurs.
-If @var{@2@} is an integer, it can be
-used to turn off handling of signal @var{@1@} or revert to its default
-action.
-See @code{signal(2)}.
-
-Note that @var{@2@} will be called using C conventions,
-so the value of its argument in Fortran terms
-is obtained by applying @code{%LOC()} (or @code{LOC()}) to it.
-
-The value returned by @code{signal(2)} is returned.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-@emph{Warning:} If the returned value is stored in
-an @code{INTEGER(KIND=1)} (default @code{INTEGER}) argument,
-truncation of the original return value occurs on some systems
-(such as Alphas, which have 64-bit pointers but 32-bit default integers),
-with no warning issued by @code{g77} under normal circumstances.
-
-Therefore, the following code fragment might silently fail on
-some systems:
-
-@smallexample
-INTEGER RTN
-EXTERNAL MYHNDL
-RTN = SIGNAL(@var{signum}, MYHNDL)
-@dots{}
-! Restore original handler:
-RTN = SIGNAL(@var{signum}, RTN)
-@end smallexample
-
-The reason for the failure is that @samp{RTN} might not hold
-all the information on the original handler for the signal,
-thus restoring an invalid handler.
-This bug could manifest itself as a spurious run-time failure
-at an arbitrary point later during the program's execution,
-for example.
-
-@emph{Warning:} Use of the @code{libf2c} run-time library function
-@samp{signal_} directly
-(such as via @samp{EXTERNAL SIGNAL})
-requires use of the @code{%VAL()} construct
-to pass an @code{INTEGER} value
-(such as @samp{SIG_IGN} or @samp{SIG_DFL})
-for the @var{@2@} argument.
-
-However, while @samp{RTN = SIGNAL(@var{signum}, %VAL(SIG_IGN))}
-works when @samp{SIGNAL} is treated as an external procedure
-(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine),
-this construct is not valid when @samp{SIGNAL} is recognized
-as the intrinsic of that name.
-
-Therefore, for maximum portability and reliability,
-code such references to the @samp{SIGNAL} facility as follows:
-
-@smallexample
-INTRINSIC SIGNAL
-@dots{}
-RTN = SIGNAL(@var{signum}, SIG_IGN)
-@end smallexample
-
-@code{g77} will compile such a call correctly,
-while other compilers will generally either do so as well
-or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic,
-allowing you to take appropriate action.
-")
-
-DEFDOC (KILL_func, "Signal a process.", "\
-Sends the signal specified by @var{@2@} to the process @var{@1@}.
-Returns 0 on success or a nonzero error code.
-See @code{kill(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-")
-
-DEFDOC (KILL_subr, "Signal a process.", "\
-Sends the signal specified by @var{@2@} to the process @var{@1@}.
-If the @var{@3@} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-See @code{kill(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@3@} argument.
-")
-
-DEFDOC (LNBLNK, "Get last non-blank character in string.", "\
-Returns the index of the last non-blank character in @var{@1@}.
-@code{LNBLNK} and @code{LEN_TRIM} are equivalent.
-")
-
-DEFDOC (SLEEP, "Sleep for a specified time.", "\
-Causes the process to pause for @var{@1@} seconds.
-See @code{sleep(2)}.
-")
-
-DEFDOC (SYSTEM_subr, "Invoke shell (system) command.", "\
-Passes the command @var{@1@} to a shell (see @code{system(3)}).
-If argument @var{@2@} is present, it contains the value returned by
-@code{system(3)}, presumably 0 if the shell command succeeded.
-Note that which shell is used to invoke the command is system-dependent
-and environment-dependent.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{@2@} argument.
-")
-
-DEFDOC (SYSTEM_func, "Invoke shell (system) command.", "\
-Passes the command @var{@1@} to a shell (see @code{system(3)}).
-Returns the value returned by
-@code{system(3)}, presumably 0 if the shell command succeeded.
-Note that which shell is used to invoke the command is system-dependent
-and environment-dependent.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-However, the function form can be valid in cases where the
-actual side effects performed by the call are unimportant to
-the application.
-
-For example, on a UNIX system, @samp{SAME = SYSTEM('cmp a b')}
-does not perform any side effects likely to be important to the
-program, so the programmer would not care if the actual system
-call (and invocation of @code{cmp}) was optimized away in a situation
-where the return value could be determined otherwise, or was not
-actually needed (@samp{SAME} not actually referenced after the
-sample assignment statement).
-")
-
-DEFDOC (TIME_vxt, "Get the time as a character value.", "\
-Returns in @var{@1@} a character representation of the current time as
-obtained from @code{ctime(3)}.
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-@xref{FDate Intrinsic (subroutine)}, for an equivalent routine.
-")
-
-DEFDOC (IBCLR, "Clear a bit.", "\
-Returns the value of @var{@1@} with bit @var{@2@} cleared (set to
-zero).
-@xref{BTest Intrinsic}, for information on bit positions.
-")
-
-DEFDOC (IBSET, "Set a bit.", "\
-Returns the value of @var{@1@} with bit @var{@2@} set (to one).
-@xref{BTest Intrinsic}, for information on bit positions.
-")
-
-DEFDOC (IBITS, "Extract a bit subfield of a variable.", "\
-Extracts a subfield of length @var{@3@} from @var{@1@}, starting from
-bit position @var{@2@} and extending left for @var{@3@} bits.
-The result is right-justified and the remaining bits are zeroed.
-The value
-of @samp{@var{@2@}+@var{@3@}} must be less than or equal to the value
-@samp{BIT_SIZE(@var{@1@})}.
-@xref{Bit_Size Intrinsic}.
-")
-
-DEFDOC (ISHFT, "Logical bit shift.", "\
-All bits representing @var{@1@} are shifted @var{@2@} places.
-@samp{@var{@2@}.GT.0} indicates a left shift, @samp{@var{@2@}.EQ.0}
-indicates no shift and @samp{@var{@2@}.LT.0} indicates a right shift.
-If the absolute value of the shift count is greater than
-@samp{BIT_SIZE(@var{@1@})}, the result is undefined.
-Bits shifted out from the left end or the right end are lost.
-Zeros are shifted in from the opposite end.
-
-@xref{IShftC Intrinsic}, for the circular-shift equivalent.
-")
-
-DEFDOC (ISHFTC, "Circular bit shift.", "\
-The rightmost @var{@3@} bits of the argument @var{@1@}
-are shifted circularly @var{@2@}
-places, i.e.@: the bits shifted out of one end are shifted into
-the opposite end.
-No bits are lost.
-The unshifted bits of the result are the same as
-the unshifted bits of @var{@1@}.
-The absolute value of the argument @var{@2@}
-must be less than or equal to @var{@3@}.
-The value of @var{@3@} must be greater than or equal to one and less than
-or equal to @samp{BIT_SIZE(@var{@1@})}.
-
-@xref{IShft Intrinsic}, for the logical shift equivalent.
-")
-
-DEFDOC (MVBITS, "Moving a bit field.", "\
-Moves @var{@3@} bits from positions @var{@2@} through
-@samp{@var{@2@}+@var{@3@}-1} of @var{@1@} to positions @var{@5@} through
-@samp{@var{@2@}+@var{@3@}-1} of @var{@4@}. The portion of argument
-@var{@4@} not affected by the movement of bits is unchanged. Arguments
-@var{@1@} and @var{@4@} are permitted to be the same numeric storage
-unit. The values of @samp{@var{@2@}+@var{@3@}} and
-@samp{@var{@5@}+@var{@3@}} must be less than or equal to
-@samp{BIT_SIZE(@var{@1@})}.
-")
-
-DEFDOC (INDEX, "Locate a CHARACTER substring.", "\
-Returns the position of the start of the first occurrence of string
-@var{@2@} as a substring in @var{@1@}, counting from one.
-If @var{@2@} doesn't occur in @var{@1@}, zero is returned.
-")
-
-DEFDOC (ALARM, "Execute a routine after a given delay.", "\
-Causes external subroutine @var{@2@} to be executed after a delay of
-@var{@1@} seconds by using @code{alarm(1)} to set up a signal and
-@code{signal(2)} to catch it.
-If @var{@3@} is supplied, it will be
-returned with the number of seconds remaining until any previously
-scheduled alarm was due to be delivered, or zero if there was no
-previously scheduled alarm.
-@xref{Signal Intrinsic (subroutine)}.
-")
-
-DEFDOC (DATE_AND_TIME, "Get the current date and time.", "\
-Returns:
-@table @var
-@item @1@
-The date in the form @var{ccyymmdd}: century, year, month and day;
-@item @2@
-The time in the form @samp{@var{hhmmss.ss}}: hours, minutes, seconds
-and milliseconds;
-@item @3@
-The difference between local time and UTC (GMT) in the form @var{Shhmm}:
-sign, hours and minutes, e.g.@: @samp{-0500} (winter in New York);
-@item @4@
-The year, month of the year, day of the month, time difference in
-minutes from UTC, hour of the day, minutes of the hour, seconds
-of the minute, and milliseconds
-of the second in successive values of the array.
-@end table
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-On systems where a millisecond timer isn't available, the millisecond
-value is returned as zero.
-")
+++ /dev/null
-@c This file is automatically derived from intdoc.c, intdoc.in,
-@c ansify.c, intrin.def, and intrin.h. Edit those files instead.
-@menu
-@ifset familyF2U
-* Abort Intrinsic:: Abort the program.
-@end ifset
-@ifset familyF77
-* Abs Intrinsic:: Absolute value.
-@end ifset
-@ifset familyF2U
-* Access Intrinsic:: Check file accessibility.
-@end ifset
-@ifset familyASC
-* AChar Intrinsic:: ASCII character from code.
-@end ifset
-@ifset familyF77
-* ACos Intrinsic:: Arc cosine.
-@end ifset
-@ifset familyVXT
-* ACosD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF90
-* AdjustL Intrinsic:: (Reserved for future use.)
-* AdjustR Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* AImag Intrinsic:: Convert/extract imaginary part of complex.
-@end ifset
-@ifset familyVXT
-* AIMax0 Intrinsic:: (Reserved for future use.)
-* AIMin0 Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* AInt Intrinsic:: Truncate to whole number.
-@end ifset
-@ifset familyVXT
-* AJMax0 Intrinsic:: (Reserved for future use.)
-* AJMin0 Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* Alarm Intrinsic:: Execute a routine after a given delay.
-@end ifset
-@ifset familyF90
-* All Intrinsic:: (Reserved for future use.)
-* Allocated Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* ALog Intrinsic:: Natural logarithm (archaic).
-* ALog10 Intrinsic:: Common logarithm (archaic).
-* AMax0 Intrinsic:: Maximum value (archaic).
-* AMax1 Intrinsic:: Maximum value (archaic).
-* AMin0 Intrinsic:: Minimum value (archaic).
-* AMin1 Intrinsic:: Minimum value (archaic).
-* AMod Intrinsic:: Remainder (archaic).
-@end ifset
-@ifset familyF2C
-* And Intrinsic:: Boolean AND.
-@end ifset
-@ifset familyF77
-* ANInt Intrinsic:: Round to nearest whole number.
-@end ifset
-@ifset familyF90
-* Any Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* ASin Intrinsic:: Arc sine.
-@end ifset
-@ifset familyVXT
-* ASinD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF90
-* Associated Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* ATan Intrinsic:: Arc tangent.
-* ATan2 Intrinsic:: Arc tangent.
-@end ifset
-@ifset familyVXT
-* ATan2D Intrinsic:: (Reserved for future use.)
-* ATanD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* BesJ0 Intrinsic:: Bessel function.
-* BesJ1 Intrinsic:: Bessel function.
-* BesJN Intrinsic:: Bessel function.
-* BesY0 Intrinsic:: Bessel function.
-* BesY1 Intrinsic:: Bessel function.
-* BesYN Intrinsic:: Bessel function.
-@end ifset
-@ifset familyVXT
-* BITest Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF90
-* Bit_Size Intrinsic:: Number of bits in argument's type.
-@end ifset
-@ifset familyVXT
-* BJTest Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyMIL
-* BTest Intrinsic:: Test bit.
-@end ifset
-@ifset familyF77
-* CAbs Intrinsic:: Absolute value (archaic).
-* CCos Intrinsic:: Cosine (archaic).
-@end ifset
-@ifset familyFVZ
-* CDAbs Intrinsic:: Absolute value (archaic).
-* CDCos Intrinsic:: Cosine (archaic).
-* CDExp Intrinsic:: Exponential (archaic).
-* CDLog Intrinsic:: Natural logarithm (archaic).
-* CDSin Intrinsic:: Sine (archaic).
-* CDSqRt Intrinsic:: Square root (archaic).
-@end ifset
-@ifset familyF90
-* Ceiling Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* CExp Intrinsic:: Exponential (archaic).
-* Char Intrinsic:: Character from code.
-@end ifset
-@ifset familyF2U
-* ChDir Intrinsic (subroutine):: Change directory.
-@end ifset
-@ifset familyBADU77
-* ChDir Intrinsic (function):: Change directory.
-@end ifset
-@ifset familyF2U
-* ChMod Intrinsic (subroutine):: Change file modes.
-@end ifset
-@ifset familyBADU77
-* ChMod Intrinsic (function):: Change file modes.
-@end ifset
-@ifset familyF77
-* CLog Intrinsic:: Natural logarithm (archaic).
-* Cmplx Intrinsic:: Construct @code{COMPLEX(KIND=1)} value.
-@end ifset
-@ifset familyGNU
-* Complex Intrinsic:: Build complex value from real and
- imaginary parts.
-@end ifset
-@ifset familyF77
-* Conjg Intrinsic:: Complex conjugate.
-* Cos Intrinsic:: Cosine.
-@end ifset
-@ifset familyVXT
-* CosD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* CosH Intrinsic:: Hyperbolic cosine.
-@end ifset
-@ifset familyF90
-* Count Intrinsic:: (Reserved for future use.)
-* CPU_Time Intrinsic:: Get current CPU time.
-* CShift Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* CSin Intrinsic:: Sine (archaic).
-* CSqRt Intrinsic:: Square root (archaic).
-@end ifset
-@ifset familyF2U
-* CTime Intrinsic (subroutine):: Convert time to Day Mon dd hh:mm:ss yyyy.
-* CTime Intrinsic (function):: Convert time to Day Mon dd hh:mm:ss yyyy.
-@end ifset
-@ifset familyF77
-* DAbs Intrinsic:: Absolute value (archaic).
-* DACos Intrinsic:: Arc cosine (archaic).
-@end ifset
-@ifset familyVXT
-* DACosD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* DASin Intrinsic:: Arc sine (archaic).
-@end ifset
-@ifset familyVXT
-* DASinD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* DATan Intrinsic:: Arc tangent (archaic).
-* DATan2 Intrinsic:: Arc tangent (archaic).
-@end ifset
-@ifset familyVXT
-* DATan2D Intrinsic:: (Reserved for future use.)
-* DATanD Intrinsic:: (Reserved for future use.)
-* Date Intrinsic:: Get current date as dd-Mon-yy.
-@end ifset
-@ifset familyF90
-* Date_and_Time Intrinsic:: Get the current date and time.
-@end ifset
-@ifset familyF2U
-* DbesJ0 Intrinsic:: Bessel function (archaic).
-* DbesJ1 Intrinsic:: Bessel function (archaic).
-* DbesJN Intrinsic:: Bessel function (archaic).
-* DbesY0 Intrinsic:: Bessel function (archaic).
-* DbesY1 Intrinsic:: Bessel function (archaic).
-* DbesYN Intrinsic:: Bessel function (archaic).
-@end ifset
-@ifset familyF77
-* Dble Intrinsic:: Convert to double precision.
-@end ifset
-@ifset familyVXT
-* DbleQ Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyFVZ
-* DCmplx Intrinsic:: Construct @code{COMPLEX(KIND=2)} value.
-* DConjg Intrinsic:: Complex conjugate (archaic).
-@end ifset
-@ifset familyF77
-* DCos Intrinsic:: Cosine (archaic).
-@end ifset
-@ifset familyVXT
-* DCosD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* DCosH Intrinsic:: Hyperbolic cosine (archaic).
-* DDiM Intrinsic:: Difference magnitude (archaic).
-@end ifset
-@ifset familyF2U
-* DErF Intrinsic:: Error function (archaic).
-* DErFC Intrinsic:: Complementary error function (archaic).
-@end ifset
-@ifset familyF77
-* DExp Intrinsic:: Exponential (archaic).
-@end ifset
-@ifset familyFVZ
-* DFloat Intrinsic:: Conversion (archaic).
-@end ifset
-@ifset familyVXT
-* DFlotI Intrinsic:: (Reserved for future use.)
-* DFlotJ Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF90
-* Digits Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* DiM Intrinsic:: Difference magnitude (non-negative subtract).
-@end ifset
-@ifset familyFVZ
-* DImag Intrinsic:: Convert/extract imaginary part of complex (archaic).
-@end ifset
-@ifset familyF77
-* DInt Intrinsic:: Truncate to whole number (archaic).
-* DLog Intrinsic:: Natural logarithm (archaic).
-* DLog10 Intrinsic:: Common logarithm (archaic).
-* DMax1 Intrinsic:: Maximum value (archaic).
-* DMin1 Intrinsic:: Minimum value (archaic).
-* DMod Intrinsic:: Remainder (archaic).
-* DNInt Intrinsic:: Round to nearest whole number (archaic).
-@end ifset
-@ifset familyF90
-* Dot_Product Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* DProd Intrinsic:: Double-precision product.
-@end ifset
-@ifset familyVXT
-* DReal Intrinsic:: Convert value to type @code{REAL(KIND=2)}.
-@end ifset
-@ifset familyF77
-* DSign Intrinsic:: Apply sign to magnitude (archaic).
-* DSin Intrinsic:: Sine (archaic).
-@end ifset
-@ifset familyVXT
-* DSinD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* DSinH Intrinsic:: Hyperbolic sine (archaic).
-* DSqRt Intrinsic:: Square root (archaic).
-* DTan Intrinsic:: Tangent (archaic).
-@end ifset
-@ifset familyVXT
-* DTanD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* DTanH Intrinsic:: Hyperbolic tangent (archaic).
-@end ifset
-@ifset familyF2U
-* DTime Intrinsic (subroutine):: Get elapsed time since last time.
-@end ifset
-@ifset familyBADU77
-* DTime Intrinsic (function):: Get elapsed time since last time.
-@end ifset
-@ifset familyF90
-* EOShift Intrinsic:: (Reserved for future use.)
-* Epsilon Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* ErF Intrinsic:: Error function.
-* ErFC Intrinsic:: Complementary error function.
-* ETime Intrinsic (subroutine):: Get elapsed time for process.
-* ETime Intrinsic (function):: Get elapsed time for process.
-* Exit Intrinsic:: Terminate the program.
-@end ifset
-@ifset familyF77
-* Exp Intrinsic:: Exponential.
-@end ifset
-@ifset familyF90
-* Exponent Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* FDate Intrinsic (subroutine):: Get current time as Day Mon dd hh:mm:ss yyyy.
-* FDate Intrinsic (function):: Get current time as Day Mon dd hh:mm:ss yyyy.
-* FGet Intrinsic (subroutine):: Read a character from unit 5 stream-wise.
-@end ifset
-@ifset familyBADU77
-* FGet Intrinsic (function):: Read a character from unit 5 stream-wise.
-@end ifset
-@ifset familyF2U
-* FGetC Intrinsic (subroutine):: Read a character stream-wise.
-@end ifset
-@ifset familyBADU77
-* FGetC Intrinsic (function):: Read a character stream-wise.
-@end ifset
-@ifset familyF77
-* Float Intrinsic:: Conversion (archaic).
-@end ifset
-@ifset familyVXT
-* FloatI Intrinsic:: (Reserved for future use.)
-* FloatJ Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF90
-* Floor Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* Flush Intrinsic:: Flush buffered output.
-* FNum Intrinsic:: Get file descriptor from Fortran unit number.
-* FPut Intrinsic (subroutine):: Write a character to unit 6 stream-wise.
-@end ifset
-@ifset familyBADU77
-* FPut Intrinsic (function):: Write a character to unit 6 stream-wise.
-@end ifset
-@ifset familyF2U
-* FPutC Intrinsic (subroutine):: Write a character stream-wise.
-@end ifset
-@ifset familyBADU77
-* FPutC Intrinsic (function):: Write a character stream-wise.
-@end ifset
-@ifset familyF90
-* Fraction Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* FSeek Intrinsic:: Position file (low-level).
-* FStat Intrinsic (subroutine):: Get file information.
-* FStat Intrinsic (function):: Get file information.
-* FTell Intrinsic (subroutine):: Get file position (low-level).
-* FTell Intrinsic (function):: Get file position (low-level).
-* GError Intrinsic:: Get error message for last error.
-* GetArg Intrinsic:: Obtain command-line argument.
-* GetCWD Intrinsic (subroutine):: Get current working directory.
-* GetCWD Intrinsic (function):: Get current working directory.
-* GetEnv Intrinsic:: Get environment variable.
-* GetGId Intrinsic:: Get process group id.
-* GetLog Intrinsic:: Get login name.
-* GetPId Intrinsic:: Get process id.
-* GetUId Intrinsic:: Get process user id.
-* GMTime Intrinsic:: Convert time to GMT time info.
-* HostNm Intrinsic (subroutine):: Get host name.
-* HostNm Intrinsic (function):: Get host name.
-@end ifset
-@ifset familyF90
-* Huge Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* IAbs Intrinsic:: Absolute value (archaic).
-@end ifset
-@ifset familyASC
-* IAChar Intrinsic:: ASCII code for character.
-@end ifset
-@ifset familyMIL
-* IAnd Intrinsic:: Boolean AND.
-@end ifset
-@ifset familyF2U
-* IArgC Intrinsic:: Obtain count of command-line arguments.
-@end ifset
-@ifset familyMIL
-* IBClr Intrinsic:: Clear a bit.
-* IBits Intrinsic:: Extract a bit subfield of a variable.
-* IBSet Intrinsic:: Set a bit.
-@end ifset
-@ifset familyF77
-* IChar Intrinsic:: Code for character.
-@end ifset
-@ifset familyF2U
-* IDate Intrinsic (UNIX):: Get local time info.
-@end ifset
-@ifset familyVXT
-* IDate Intrinsic (VXT):: Get local time info (VAX/VMS).
-@end ifset
-@ifset familyF77
-* IDiM Intrinsic:: Difference magnitude (archaic).
-* IDInt Intrinsic:: Convert to @code{INTEGER} value truncated
- to whole number (archaic).
-* IDNInt Intrinsic:: Convert to @code{INTEGER} value rounded
- to nearest whole number (archaic).
-@end ifset
-@ifset familyMIL
-* IEOr Intrinsic:: Boolean XOR.
-@end ifset
-@ifset familyF2U
-* IErrNo Intrinsic:: Get error number for last error.
-@end ifset
-@ifset familyF77
-* IFix Intrinsic:: Conversion (archaic).
-@end ifset
-@ifset familyVXT
-* IIAbs Intrinsic:: (Reserved for future use.)
-* IIAnd Intrinsic:: (Reserved for future use.)
-* IIBClr Intrinsic:: (Reserved for future use.)
-* IIBits Intrinsic:: (Reserved for future use.)
-* IIBSet Intrinsic:: (Reserved for future use.)
-* IIDiM Intrinsic:: (Reserved for future use.)
-* IIDInt Intrinsic:: (Reserved for future use.)
-* IIDNnt Intrinsic:: (Reserved for future use.)
-* IIEOr Intrinsic:: (Reserved for future use.)
-* IIFix Intrinsic:: (Reserved for future use.)
-* IInt Intrinsic:: (Reserved for future use.)
-* IIOr Intrinsic:: (Reserved for future use.)
-* IIQint Intrinsic:: (Reserved for future use.)
-* IIQNnt Intrinsic:: (Reserved for future use.)
-* IIShftC Intrinsic:: (Reserved for future use.)
-* IISign Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2C
-* Imag Intrinsic:: Extract imaginary part of complex.
-@end ifset
-@ifset familyGNU
-* ImagPart Intrinsic:: Extract imaginary part of complex.
-@end ifset
-@ifset familyVXT
-* IMax0 Intrinsic:: (Reserved for future use.)
-* IMax1 Intrinsic:: (Reserved for future use.)
-* IMin0 Intrinsic:: (Reserved for future use.)
-* IMin1 Intrinsic:: (Reserved for future use.)
-* IMod Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* Index Intrinsic:: Locate a CHARACTER substring.
-@end ifset
-@ifset familyVXT
-* INInt Intrinsic:: (Reserved for future use.)
-* INot Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* Int Intrinsic:: Convert to @code{INTEGER} value truncated
- to whole number.
-@end ifset
-@ifset familyGNU
-* Int2 Intrinsic:: Convert to @code{INTEGER(KIND=6)} value
- truncated to whole number.
-* Int8 Intrinsic:: Convert to @code{INTEGER(KIND=2)} value
- truncated to whole number.
-@end ifset
-@ifset familyMIL
-* IOr Intrinsic:: Boolean OR.
-@end ifset
-@ifset familyF2U
-* IRand Intrinsic:: Random number.
-* IsaTty Intrinsic:: Is unit connected to a terminal?
-@end ifset
-@ifset familyMIL
-* IShft Intrinsic:: Logical bit shift.
-* IShftC Intrinsic:: Circular bit shift.
-@end ifset
-@ifset familyF77
-* ISign Intrinsic:: Apply sign to magnitude (archaic).
-@end ifset
-@ifset familyF2U
-* ITime Intrinsic:: Get local time of day.
-@end ifset
-@ifset familyVXT
-* IZExt Intrinsic:: (Reserved for future use.)
-* JIAbs Intrinsic:: (Reserved for future use.)
-* JIAnd Intrinsic:: (Reserved for future use.)
-* JIBClr Intrinsic:: (Reserved for future use.)
-* JIBits Intrinsic:: (Reserved for future use.)
-* JIBSet Intrinsic:: (Reserved for future use.)
-* JIDiM Intrinsic:: (Reserved for future use.)
-* JIDInt Intrinsic:: (Reserved for future use.)
-* JIDNnt Intrinsic:: (Reserved for future use.)
-* JIEOr Intrinsic:: (Reserved for future use.)
-* JIFix Intrinsic:: (Reserved for future use.)
-* JInt Intrinsic:: (Reserved for future use.)
-* JIOr Intrinsic:: (Reserved for future use.)
-* JIQint Intrinsic:: (Reserved for future use.)
-* JIQNnt Intrinsic:: (Reserved for future use.)
-* JIShft Intrinsic:: (Reserved for future use.)
-* JIShftC Intrinsic:: (Reserved for future use.)
-* JISign Intrinsic:: (Reserved for future use.)
-* JMax0 Intrinsic:: (Reserved for future use.)
-* JMax1 Intrinsic:: (Reserved for future use.)
-* JMin0 Intrinsic:: (Reserved for future use.)
-* JMin1 Intrinsic:: (Reserved for future use.)
-* JMod Intrinsic:: (Reserved for future use.)
-* JNInt Intrinsic:: (Reserved for future use.)
-* JNot Intrinsic:: (Reserved for future use.)
-* JZExt Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* Kill Intrinsic (subroutine):: Signal a process.
-@end ifset
-@ifset familyBADU77
-* Kill Intrinsic (function):: Signal a process.
-@end ifset
-@ifset familyF90
-* Kind Intrinsic:: (Reserved for future use.)
-* LBound Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* Len Intrinsic:: Length of character entity.
-@end ifset
-@ifset familyF90
-* Len_Trim Intrinsic:: Get last non-blank character in string.
-@end ifset
-@ifset familyF77
-* LGe Intrinsic:: Lexically greater than or equal.
-* LGt Intrinsic:: Lexically greater than.
-@end ifset
-@ifset familyF2U
-* Link Intrinsic (subroutine):: Make hard link in file system.
-@end ifset
-@ifset familyBADU77
-* Link Intrinsic (function):: Make hard link in file system.
-@end ifset
-@ifset familyF77
-* LLe Intrinsic:: Lexically less than or equal.
-* LLt Intrinsic:: Lexically less than.
-@end ifset
-@ifset familyF2U
-* LnBlnk Intrinsic:: Get last non-blank character in string.
-* Loc Intrinsic:: Address of entity in core.
-@end ifset
-@ifset familyF77
-* Log Intrinsic:: Natural logarithm.
-* Log10 Intrinsic:: Common logarithm.
-@end ifset
-@ifset familyF90
-* Logical Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* Long Intrinsic:: Conversion to @code{INTEGER(KIND=1)} (archaic).
-@end ifset
-@ifset familyF2C
-* LShift Intrinsic:: Left-shift bits.
-@end ifset
-@ifset familyF2U
-* LStat Intrinsic (subroutine):: Get file information.
-* LStat Intrinsic (function):: Get file information.
-* LTime Intrinsic:: Convert time to local time info.
-@end ifset
-@ifset familyF90
-* MatMul Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* Max Intrinsic:: Maximum value.
-* Max0 Intrinsic:: Maximum value (archaic).
-* Max1 Intrinsic:: Maximum value (archaic).
-@end ifset
-@ifset familyF90
-* MaxExponent Intrinsic:: (Reserved for future use.)
-* MaxLoc Intrinsic:: (Reserved for future use.)
-* MaxVal Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* MClock Intrinsic:: Get number of clock ticks for process.
-* MClock8 Intrinsic:: Get number of clock ticks for process.
-@end ifset
-@ifset familyF90
-* Merge Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* Min Intrinsic:: Minimum value.
-* Min0 Intrinsic:: Minimum value (archaic).
-* Min1 Intrinsic:: Minimum value (archaic).
-@end ifset
-@ifset familyF90
-* MinExponent Intrinsic:: (Reserved for future use.)
-* MinLoc Intrinsic:: (Reserved for future use.)
-* MinVal Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* Mod Intrinsic:: Remainder.
-@end ifset
-@ifset familyF90
-* Modulo Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyMIL
-* MvBits Intrinsic:: Moving a bit field.
-@end ifset
-@ifset familyF90
-* Nearest Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* NInt Intrinsic:: Convert to @code{INTEGER} value rounded
- to nearest whole number.
-@end ifset
-@ifset familyMIL
-* Not Intrinsic:: Boolean NOT.
-@end ifset
-@ifset familyF2C
-* Or Intrinsic:: Boolean OR.
-@end ifset
-@ifset familyF90
-* Pack Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* PError Intrinsic:: Print error message for last error.
-@end ifset
-@ifset familyF90
-* Precision Intrinsic:: (Reserved for future use.)
-* Present Intrinsic:: (Reserved for future use.)
-* Product Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyVXT
-* QAbs Intrinsic:: (Reserved for future use.)
-* QACos Intrinsic:: (Reserved for future use.)
-* QACosD Intrinsic:: (Reserved for future use.)
-* QASin Intrinsic:: (Reserved for future use.)
-* QASinD Intrinsic:: (Reserved for future use.)
-* QATan Intrinsic:: (Reserved for future use.)
-* QATan2 Intrinsic:: (Reserved for future use.)
-* QATan2D Intrinsic:: (Reserved for future use.)
-* QATanD Intrinsic:: (Reserved for future use.)
-* QCos Intrinsic:: (Reserved for future use.)
-* QCosD Intrinsic:: (Reserved for future use.)
-* QCosH Intrinsic:: (Reserved for future use.)
-* QDiM Intrinsic:: (Reserved for future use.)
-* QExp Intrinsic:: (Reserved for future use.)
-* QExt Intrinsic:: (Reserved for future use.)
-* QExtD Intrinsic:: (Reserved for future use.)
-* QFloat Intrinsic:: (Reserved for future use.)
-* QInt Intrinsic:: (Reserved for future use.)
-* QLog Intrinsic:: (Reserved for future use.)
-* QLog10 Intrinsic:: (Reserved for future use.)
-* QMax1 Intrinsic:: (Reserved for future use.)
-* QMin1 Intrinsic:: (Reserved for future use.)
-* QMod Intrinsic:: (Reserved for future use.)
-* QNInt Intrinsic:: (Reserved for future use.)
-* QSin Intrinsic:: (Reserved for future use.)
-* QSinD Intrinsic:: (Reserved for future use.)
-* QSinH Intrinsic:: (Reserved for future use.)
-* QSqRt Intrinsic:: (Reserved for future use.)
-* QTan Intrinsic:: (Reserved for future use.)
-* QTanD Intrinsic:: (Reserved for future use.)
-* QTanH Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF90
-* Radix Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* Rand Intrinsic:: Random number.
-@end ifset
-@ifset familyF90
-* Random_Number Intrinsic:: (Reserved for future use.)
-* Random_Seed Intrinsic:: (Reserved for future use.)
-* Range Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* Real Intrinsic:: Convert value to type @code{REAL(KIND=1)}.
-@end ifset
-@ifset familyGNU
-* RealPart Intrinsic:: Extract real part of complex.
-@end ifset
-@ifset familyF2U
-* Rename Intrinsic (subroutine):: Rename file.
-@end ifset
-@ifset familyBADU77
-* Rename Intrinsic (function):: Rename file.
-@end ifset
-@ifset familyF90
-* Repeat Intrinsic:: (Reserved for future use.)
-* Reshape Intrinsic:: (Reserved for future use.)
-* RRSpacing Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2C
-* RShift Intrinsic:: Right-shift bits.
-@end ifset
-@ifset familyF90
-* Scale Intrinsic:: (Reserved for future use.)
-* Scan Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyVXT
-* Secnds Intrinsic:: Get local time offset since midnight.
-@end ifset
-@ifset familyF2U
-* Second Intrinsic (function):: Get CPU time for process in seconds.
-* Second Intrinsic (subroutine):: Get CPU time for process
- in seconds.
-@end ifset
-@ifset familyF90
-* Selected_Int_Kind Intrinsic:: (Reserved for future use.)
-* Selected_Real_Kind Intrinsic:: (Reserved for future use.)
-* Set_Exponent Intrinsic:: (Reserved for future use.)
-* Shape Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* Short Intrinsic:: Convert to @code{INTEGER(KIND=6)} value
- truncated to whole number.
-@end ifset
-@ifset familyF77
-* Sign Intrinsic:: Apply sign to magnitude.
-@end ifset
-@ifset familyF2U
-* Signal Intrinsic (subroutine):: Muck with signal handling.
-@end ifset
-@ifset familyBADU77
-* Signal Intrinsic (function):: Muck with signal handling.
-@end ifset
-@ifset familyF77
-* Sin Intrinsic:: Sine.
-@end ifset
-@ifset familyVXT
-* SinD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* SinH Intrinsic:: Hyperbolic sine.
-@end ifset
-@ifset familyF2U
-* Sleep Intrinsic:: Sleep for a specified time.
-@end ifset
-@ifset familyF77
-* Sngl Intrinsic:: Convert (archaic).
-@end ifset
-@ifset familyVXT
-* SnglQ Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF90
-* Spacing Intrinsic:: (Reserved for future use.)
-* Spread Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* SqRt Intrinsic:: Square root.
-@end ifset
-@ifset familyF2U
-* SRand Intrinsic:: Random seed.
-* Stat Intrinsic (subroutine):: Get file information.
-* Stat Intrinsic (function):: Get file information.
-@end ifset
-@ifset familyF90
-* Sum Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* SymLnk Intrinsic (subroutine):: Make symbolic link in file system.
-@end ifset
-@ifset familyBADU77
-* SymLnk Intrinsic (function):: Make symbolic link in file system.
-@end ifset
-@ifset familyF2U
-* System Intrinsic (subroutine):: Invoke shell (system) command.
-@end ifset
-@ifset familyBADU77
-* System Intrinsic (function):: Invoke shell (system) command.
-@end ifset
-@ifset familyF90
-* System_Clock Intrinsic:: Get current system clock value.
-@end ifset
-@ifset familyF77
-* Tan Intrinsic:: Tangent.
-@end ifset
-@ifset familyVXT
-* TanD Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF77
-* TanH Intrinsic:: Hyperbolic tangent.
-@end ifset
-@ifset familyF2U
-* Time Intrinsic (UNIX):: Get current time as time value.
-@end ifset
-@ifset familyVXT
-* Time Intrinsic (VXT):: Get the time as a character value.
-@end ifset
-@ifset familyF2U
-* Time8 Intrinsic:: Get current time as time value.
-@end ifset
-@ifset familyF90
-* Tiny Intrinsic:: (Reserved for future use.)
-* Transfer Intrinsic:: (Reserved for future use.)
-* Transpose Intrinsic:: (Reserved for future use.)
-* Trim Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* TtyNam Intrinsic (subroutine):: Get name of terminal device for unit.
-* TtyNam Intrinsic (function):: Get name of terminal device for unit.
-@end ifset
-@ifset familyF90
-* UBound Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2U
-* UMask Intrinsic (subroutine):: Set file creation permissions mask.
-@end ifset
-@ifset familyBADU77
-* UMask Intrinsic (function):: Set file creation permissions mask.
-@end ifset
-@ifset familyF2U
-* Unlink Intrinsic (subroutine):: Unlink file.
-@end ifset
-@ifset familyBADU77
-* Unlink Intrinsic (function):: Unlink file.
-@end ifset
-@ifset familyF90
-* Unpack Intrinsic:: (Reserved for future use.)
-* Verify Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2C
-* XOr Intrinsic:: Boolean XOR.
-* ZAbs Intrinsic:: Absolute value (archaic).
-* ZCos Intrinsic:: Cosine (archaic).
-* ZExp Intrinsic:: Exponential (archaic).
-@end ifset
-@ifset familyVXT
-* ZExt Intrinsic:: (Reserved for future use.)
-@end ifset
-@ifset familyF2C
-* ZLog Intrinsic:: Natural logarithm (archaic).
-* ZSin Intrinsic:: Sine (archaic).
-* ZSqRt Intrinsic:: Square root (archaic).
-@end ifset
-@end menu
-
-@ifset familyF2U
-@node Abort Intrinsic
-@subsubsection Abort Intrinsic
-@cindex Abort intrinsic
-@cindex intrinsics, Abort
-
-@noindent
-@example
-CALL Abort()
-@end example
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Prints a message and potentially causes a core dump via @code{abort(3)}.
-
-@end ifset
-@ifset familyF77
-@node Abs Intrinsic
-@subsubsection Abs Intrinsic
-@cindex Abs intrinsic
-@cindex intrinsics, Abs
-
-@noindent
-@example
-Abs(@var{A})
-@end example
-
-@noindent
-Abs: @code{INTEGER} or @code{REAL} function.
-The exact type depends on that of argument @var{A}---if @var{A} is
-@code{COMPLEX}, this function's type is @code{REAL}
-with the same @samp{KIND=} value as the type of @var{A}.
-Otherwise, this function's type is the same as that of @var{A}.
-
-@noindent
-@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the absolute value of @var{A}.
-
-If @var{A} is type @code{COMPLEX}, the absolute
-value is computed as:
-
-@example
-SQRT(REALPART(@var{A})**2+IMAGPART(@var{A})**2)
-@end example
-
-@noindent
-Otherwise, it is computed by negating @var{A} if
-it is negative, or returning @var{A}.
-
-@xref{Sign Intrinsic}, for how to explicitly
-compute the positive or negative form of the absolute
-value of an expression.
-
-@end ifset
-@ifset familyF2U
-@node Access Intrinsic
-@subsubsection Access Intrinsic
-@cindex Access intrinsic
-@cindex intrinsics, Access
-
-@noindent
-@example
-Access(@var{Name}, @var{Mode})
-@end example
-
-@noindent
-Access: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Mode}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Checks file @var{Name} for accessibility in the mode specified by @var{Mode} and
-returns 0 if the file is accessible in that mode, otherwise an error
-code if the file is inaccessible or @var{Mode} is invalid.
-See @code{access(2)}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{Name}---otherwise,
-trailing blanks in @var{Name} are ignored.
-@var{Mode} may be a concatenation of any of the following characters:
-
-@table @samp
-@item r
-Read permission
-
-@item w
-Write permission
-
-@item x
-Execute permission
-
-@item @kbd{SPC}
-Existence
-@end table
-
-@end ifset
-@ifset familyASC
-@node AChar Intrinsic
-@subsubsection AChar Intrinsic
-@cindex AChar intrinsic
-@cindex intrinsics, AChar
-
-@noindent
-@example
-AChar(@var{I})
-@end example
-
-@noindent
-AChar: @code{CHARACTER*1} function.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{f90}.
-
-@noindent
-Description:
-
-Returns the ASCII character corresponding to the
-code specified by @var{I}.
-
-@xref{IAChar Intrinsic}, for the inverse of this function.
-
-@xref{Char Intrinsic}, for the function corresponding
-to the system's native character set.
-
-@end ifset
-@ifset familyF77
-@node ACos Intrinsic
-@subsubsection ACos Intrinsic
-@cindex ACos intrinsic
-@cindex intrinsics, ACos
-
-@noindent
-@example
-ACos(@var{X})
-@end example
-
-@noindent
-ACos: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the arc-cosine (inverse cosine) of @var{X}
-in radians.
-
-@xref{Cos Intrinsic}, for the inverse of this function.
-
-@end ifset
-@ifset familyVXT
-@node ACosD Intrinsic
-@subsubsection ACosD Intrinsic
-@cindex ACosD intrinsic
-@cindex intrinsics, ACosD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL ACosD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF90
-@node AdjustL Intrinsic
-@subsubsection AdjustL Intrinsic
-@cindex AdjustL intrinsic
-@cindex intrinsics, AdjustL
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL AdjustL} to use this name for an
-external procedure.
-
-@node AdjustR Intrinsic
-@subsubsection AdjustR Intrinsic
-@cindex AdjustR intrinsic
-@cindex intrinsics, AdjustR
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL AdjustR} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node AImag Intrinsic
-@subsubsection AImag Intrinsic
-@cindex AImag intrinsic
-@cindex intrinsics, AImag
-
-@noindent
-@example
-AImag(@var{Z})
-@end example
-
-@noindent
-AImag: @code{REAL} function.
-This intrinsic is valid when argument @var{Z} is
-@code{COMPLEX(KIND=1)}.
-When @var{Z} is any other @code{COMPLEX} type,
-this intrinsic is valid only when used as the argument to
-@code{REAL()}, as explained below.
-
-@noindent
-@var{Z}: @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the (possibly converted) imaginary part of @var{Z}.
-
-Use of @code{AIMAG()} with an argument of a type
-other than @code{COMPLEX(KIND=1)} is restricted to the following case:
-
-@example
-REAL(AIMAG(Z))
-@end example
-
-@noindent
-This expression converts the imaginary part of Z to
-@code{REAL(KIND=1)}.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-
-@end ifset
-@ifset familyVXT
-@node AIMax0 Intrinsic
-@subsubsection AIMax0 Intrinsic
-@cindex AIMax0 intrinsic
-@cindex intrinsics, AIMax0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL AIMax0} to use this name for an
-external procedure.
-
-@node AIMin0 Intrinsic
-@subsubsection AIMin0 Intrinsic
-@cindex AIMin0 intrinsic
-@cindex intrinsics, AIMin0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL AIMin0} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node AInt Intrinsic
-@subsubsection AInt Intrinsic
-@cindex AInt intrinsic
-@cindex intrinsics, AInt
-
-@noindent
-@example
-AInt(@var{A})
-@end example
-
-@noindent
-AInt: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{A}.
-
-@noindent
-@var{A}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @var{A} with the fractional portion of its
-magnitude truncated and its sign preserved.
-(Also called ``truncation towards zero''.)
-
-@xref{ANInt Intrinsic}, for how to round to nearest
-whole number.
-
-@xref{Int Intrinsic}, for how to truncate and then convert
-number to @code{INTEGER}.
-
-@end ifset
-@ifset familyVXT
-@node AJMax0 Intrinsic
-@subsubsection AJMax0 Intrinsic
-@cindex AJMax0 intrinsic
-@cindex intrinsics, AJMax0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL AJMax0} to use this name for an
-external procedure.
-
-@node AJMin0 Intrinsic
-@subsubsection AJMin0 Intrinsic
-@cindex AJMin0 intrinsic
-@cindex intrinsics, AJMin0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL AJMin0} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node Alarm Intrinsic
-@subsubsection Alarm Intrinsic
-@cindex Alarm intrinsic
-@cindex intrinsics, Alarm
-
-@noindent
-@example
-CALL Alarm(@var{Seconds}, @var{Handler}, @var{Status})
-@end example
-
-@noindent
-@var{Seconds}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Handler}: Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})
-or dummy/global @code{INTEGER(KIND=1)} scalar.
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Causes external subroutine @var{Handler} to be executed after a delay of
-@var{Seconds} seconds by using @code{alarm(1)} to set up a signal and
-@code{signal(2)} to catch it.
-If @var{Status} is supplied, it will be
-returned with the number of seconds remaining until any previously
-scheduled alarm was due to be delivered, or zero if there was no
-previously scheduled alarm.
-@xref{Signal Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node All Intrinsic
-@subsubsection All Intrinsic
-@cindex All intrinsic
-@cindex intrinsics, All
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL All} to use this name for an
-external procedure.
-
-@node Allocated Intrinsic
-@subsubsection Allocated Intrinsic
-@cindex Allocated intrinsic
-@cindex intrinsics, Allocated
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Allocated} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node ALog Intrinsic
-@subsubsection ALog Intrinsic
-@cindex ALog intrinsic
-@cindex intrinsics, ALog
-
-@noindent
-@example
-ALog(@var{X})
-@end example
-
-@noindent
-ALog: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{LOG()} that is specific
-to one type for @var{X}.
-@xref{Log Intrinsic}.
-
-@node ALog10 Intrinsic
-@subsubsection ALog10 Intrinsic
-@cindex ALog10 intrinsic
-@cindex intrinsics, ALog10
-
-@noindent
-@example
-ALog10(@var{X})
-@end example
-
-@noindent
-ALog10: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{LOG10()} that is specific
-to one type for @var{X}.
-@xref{Log10 Intrinsic}.
-
-@node AMax0 Intrinsic
-@subsubsection AMax0 Intrinsic
-@cindex AMax0 intrinsic
-@cindex intrinsics, AMax0
-
-@noindent
-@example
-AMax0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-AMax0: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MAX()} that is specific
-to one type for @var{A} and a different return type.
-@xref{Max Intrinsic}.
-
-@node AMax1 Intrinsic
-@subsubsection AMax1 Intrinsic
-@cindex AMax1 intrinsic
-@cindex intrinsics, AMax1
-
-@noindent
-@example
-AMax1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-AMax1: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MAX()} that is specific
-to one type for @var{A}.
-@xref{Max Intrinsic}.
-
-@node AMin0 Intrinsic
-@subsubsection AMin0 Intrinsic
-@cindex AMin0 intrinsic
-@cindex intrinsics, AMin0
-
-@noindent
-@example
-AMin0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-AMin0: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MIN()} that is specific
-to one type for @var{A} and a different return type.
-@xref{Min Intrinsic}.
-
-@node AMin1 Intrinsic
-@subsubsection AMin1 Intrinsic
-@cindex AMin1 intrinsic
-@cindex intrinsics, AMin1
-
-@noindent
-@example
-AMin1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-AMin1: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MIN()} that is specific
-to one type for @var{A}.
-@xref{Min Intrinsic}.
-
-@node AMod Intrinsic
-@subsubsection AMod Intrinsic
-@cindex AMod intrinsic
-@cindex intrinsics, AMod
-
-@noindent
-@example
-AMod(@var{A}, @var{P})
-@end example
-
-@noindent
-AMod: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-@var{P}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MOD()} that is specific
-to one type for @var{A}.
-@xref{Mod Intrinsic}.
-
-@end ifset
-@ifset familyF2C
-@node And Intrinsic
-@subsubsection And Intrinsic
-@cindex And intrinsic
-@cindex intrinsics, And
-
-@noindent
-@example
-And(@var{I}, @var{J})
-@end example
-
-@noindent
-And: @code{INTEGER} or @code{LOGICAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{I}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN).
-
-@noindent
-@var{J}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Returns value resulting from boolean AND of
-pair of bits in each of @var{I} and @var{J}.
-
-@end ifset
-@ifset familyF77
-@node ANInt Intrinsic
-@subsubsection ANInt Intrinsic
-@cindex ANInt intrinsic
-@cindex intrinsics, ANInt
-
-@noindent
-@example
-ANInt(@var{A})
-@end example
-
-@noindent
-ANInt: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{A}.
-
-@noindent
-@var{A}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @var{A} with the fractional portion of its
-magnitude eliminated by rounding to the nearest whole
-number and with its sign preserved.
-
-A fractional portion exactly equal to
-@samp{.5} is rounded to the whole number that
-is larger in magnitude.
-(Also called ``Fortran round''.)
-
-@xref{AInt Intrinsic}, for how to truncate to
-whole number.
-
-@xref{NInt Intrinsic}, for how to round and then convert
-number to @code{INTEGER}.
-
-@end ifset
-@ifset familyF90
-@node Any Intrinsic
-@subsubsection Any Intrinsic
-@cindex Any intrinsic
-@cindex intrinsics, Any
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Any} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node ASin Intrinsic
-@subsubsection ASin Intrinsic
-@cindex ASin intrinsic
-@cindex intrinsics, ASin
-
-@noindent
-@example
-ASin(@var{X})
-@end example
-
-@noindent
-ASin: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the arc-sine (inverse sine) of @var{X}
-in radians.
-
-@xref{Sin Intrinsic}, for the inverse of this function.
-
-@end ifset
-@ifset familyVXT
-@node ASinD Intrinsic
-@subsubsection ASinD Intrinsic
-@cindex ASinD intrinsic
-@cindex intrinsics, ASinD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL ASinD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF90
-@node Associated Intrinsic
-@subsubsection Associated Intrinsic
-@cindex Associated intrinsic
-@cindex intrinsics, Associated
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Associated} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node ATan Intrinsic
-@subsubsection ATan Intrinsic
-@cindex ATan intrinsic
-@cindex intrinsics, ATan
-
-@noindent
-@example
-ATan(@var{X})
-@end example
-
-@noindent
-ATan: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the arc-tangent (inverse tangent) of @var{X}
-in radians.
-
-@xref{Tan Intrinsic}, for the inverse of this function.
-
-@node ATan2 Intrinsic
-@subsubsection ATan2 Intrinsic
-@cindex ATan2 intrinsic
-@cindex intrinsics, ATan2
-
-@noindent
-@example
-ATan2(@var{Y}, @var{X})
-@end example
-
-@noindent
-ATan2: @code{REAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{Y}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the arc-tangent (inverse tangent) of the complex
-number (@var{Y}, @var{X}) in radians.
-
-@xref{Tan Intrinsic}, for the inverse of this function.
-
-@end ifset
-@ifset familyVXT
-@node ATan2D Intrinsic
-@subsubsection ATan2D Intrinsic
-@cindex ATan2D intrinsic
-@cindex intrinsics, ATan2D
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL ATan2D} to use this name for an
-external procedure.
-
-@node ATanD Intrinsic
-@subsubsection ATanD Intrinsic
-@cindex ATanD intrinsic
-@cindex intrinsics, ATanD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL ATanD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node BesJ0 Intrinsic
-@subsubsection BesJ0 Intrinsic
-@cindex BesJ0 intrinsic
-@cindex intrinsics, BesJ0
-
-@noindent
-@example
-BesJ0(@var{X})
-@end example
-
-@noindent
-BesJ0: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Calculates the Bessel function of the first kind of order 0 of @var{X}.
-See @code{bessel(3m)}, on whose implementation the function depends.
-@node BesJ1 Intrinsic
-@subsubsection BesJ1 Intrinsic
-@cindex BesJ1 intrinsic
-@cindex intrinsics, BesJ1
-
-@noindent
-@example
-BesJ1(@var{X})
-@end example
-
-@noindent
-BesJ1: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Calculates the Bessel function of the first kind of order 1 of @var{X}.
-See @code{bessel(3m)}, on whose implementation the function depends.
-@node BesJN Intrinsic
-@subsubsection BesJN Intrinsic
-@cindex BesJN intrinsic
-@cindex intrinsics, BesJN
-
-@noindent
-@example
-BesJN(@var{N}, @var{X})
-@end example
-
-@noindent
-BesJN: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{N}: @code{INTEGER} not wider than the default kind; scalar; INTENT(IN).
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Calculates the Bessel function of the first kind of order @var{N} of @var{X}.
-See @code{bessel(3m)}, on whose implementation the function depends.
-@node BesY0 Intrinsic
-@subsubsection BesY0 Intrinsic
-@cindex BesY0 intrinsic
-@cindex intrinsics, BesY0
-
-@noindent
-@example
-BesY0(@var{X})
-@end example
-
-@noindent
-BesY0: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Calculates the Bessel function of the second kind of order 0 of @var{X}.
-See @code{bessel(3m)}, on whose implementation the function depends.
-@node BesY1 Intrinsic
-@subsubsection BesY1 Intrinsic
-@cindex BesY1 intrinsic
-@cindex intrinsics, BesY1
-
-@noindent
-@example
-BesY1(@var{X})
-@end example
-
-@noindent
-BesY1: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Calculates the Bessel function of the second kind of order 1 of @var{X}.
-See @code{bessel(3m)}, on whose implementation the function depends.
-@node BesYN Intrinsic
-@subsubsection BesYN Intrinsic
-@cindex BesYN intrinsic
-@cindex intrinsics, BesYN
-
-@noindent
-@example
-BesYN(@var{N}, @var{X})
-@end example
-
-@noindent
-BesYN: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{N}: @code{INTEGER} not wider than the default kind; scalar; INTENT(IN).
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Calculates the Bessel function of the second kind of order @var{N} of @var{X}.
-See @code{bessel(3m)}, on whose implementation the function depends.
-@end ifset
-@ifset familyVXT
-@node BITest Intrinsic
-@subsubsection BITest Intrinsic
-@cindex BITest intrinsic
-@cindex intrinsics, BITest
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL BITest} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF90
-@node Bit_Size Intrinsic
-@subsubsection Bit_Size Intrinsic
-@cindex Bit_Size intrinsic
-@cindex intrinsics, Bit_Size
-
-@noindent
-@example
-Bit_Size(@var{I})
-@end example
-
-@noindent
-Bit_Size: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar.
-
-@noindent
-Intrinsic groups: @code{f90}.
-
-@noindent
-Description:
-
-Returns the number of bits (integer precision plus sign bit)
-represented by the type for @var{I}.
-
-@xref{BTest Intrinsic}, for how to test the value of a
-bit in a variable or array.
-
-@xref{IBSet Intrinsic}, for how to set a bit in a variable to 1.
-
-@xref{IBClr Intrinsic}, for how to set a bit in a variable to 0.
-
-
-@end ifset
-@ifset familyVXT
-@node BJTest Intrinsic
-@subsubsection BJTest Intrinsic
-@cindex BJTest intrinsic
-@cindex intrinsics, BJTest
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL BJTest} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyMIL
-@node BTest Intrinsic
-@subsubsection BTest Intrinsic
-@cindex BTest intrinsic
-@cindex intrinsics, BTest
-
-@noindent
-@example
-BTest(@var{I}, @var{Pos})
-@end example
-
-@noindent
-BTest: @code{LOGICAL(KIND=1)} function.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Pos}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Returns @code{.TRUE.} if bit @var{Pos} in @var{I} is
-1, @code{.FALSE.} otherwise.
-
-(Bit 0 is the low-order (rightmost) bit, adding the value
-@ifinfo
-2**0,
-@end ifinfo
-@iftex
-@tex
-$2^0$,
-@end tex
-@end iftex
-or 1,
-to the number if set to 1;
-bit 1 is the next-higher-order bit, adding
-@ifinfo
-2**1,
-@end ifinfo
-@iftex
-@tex
-$2^1$,
-@end tex
-@end iftex
-or 2;
-bit 2 adds
-@ifinfo
-2**2,
-@end ifinfo
-@iftex
-@tex
-$2^2$,
-@end tex
-@end iftex
-or 4; and so on.)
-
-@xref{Bit_Size Intrinsic}, for how to obtain the number of bits
-in a type.
-The leftmost bit of @var{I} is @samp{BIT_SIZE(@var{I}-1)}.
-
-@end ifset
-@ifset familyF77
-@node CAbs Intrinsic
-@subsubsection CAbs Intrinsic
-@cindex CAbs intrinsic
-@cindex intrinsics, CAbs
-
-@noindent
-@example
-CAbs(@var{A})
-@end example
-
-@noindent
-CAbs: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ABS()} that is specific
-to one type for @var{A}.
-@xref{Abs Intrinsic}.
-
-@node CCos Intrinsic
-@subsubsection CCos Intrinsic
-@cindex CCos intrinsic
-@cindex intrinsics, CCos
-
-@noindent
-@example
-CCos(@var{X})
-@end example
-
-@noindent
-CCos: @code{COMPLEX(KIND=1)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{COS()} that is specific
-to one type for @var{X}.
-@xref{Cos Intrinsic}.
-
-@end ifset
-@ifset familyFVZ
-@node CDAbs Intrinsic
-@subsubsection CDAbs Intrinsic
-@cindex CDAbs intrinsic
-@cindex intrinsics, CDAbs
-
-@noindent
-@example
-CDAbs(@var{A})
-@end example
-
-@noindent
-CDAbs: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{ABS()} that is specific
-to one type for @var{A}.
-@xref{Abs Intrinsic}.
-
-@node CDCos Intrinsic
-@subsubsection CDCos Intrinsic
-@cindex CDCos intrinsic
-@cindex intrinsics, CDCos
-
-@noindent
-@example
-CDCos(@var{X})
-@end example
-
-@noindent
-CDCos: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{COS()} that is specific
-to one type for @var{X}.
-@xref{Cos Intrinsic}.
-
-@node CDExp Intrinsic
-@subsubsection CDExp Intrinsic
-@cindex CDExp intrinsic
-@cindex intrinsics, CDExp
-
-@noindent
-@example
-CDExp(@var{X})
-@end example
-
-@noindent
-CDExp: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{EXP()} that is specific
-to one type for @var{X}.
-@xref{Exp Intrinsic}.
-
-@node CDLog Intrinsic
-@subsubsection CDLog Intrinsic
-@cindex CDLog intrinsic
-@cindex intrinsics, CDLog
-
-@noindent
-@example
-CDLog(@var{X})
-@end example
-
-@noindent
-CDLog: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{LOG()} that is specific
-to one type for @var{X}.
-@xref{Log Intrinsic}.
-
-@node CDSin Intrinsic
-@subsubsection CDSin Intrinsic
-@cindex CDSin intrinsic
-@cindex intrinsics, CDSin
-
-@noindent
-@example
-CDSin(@var{X})
-@end example
-
-@noindent
-CDSin: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{SIN()} that is specific
-to one type for @var{X}.
-@xref{Sin Intrinsic}.
-
-@node CDSqRt Intrinsic
-@subsubsection CDSqRt Intrinsic
-@cindex CDSqRt intrinsic
-@cindex intrinsics, CDSqRt
-
-@noindent
-@example
-CDSqRt(@var{X})
-@end example
-
-@noindent
-CDSqRt: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{SQRT()} that is specific
-to one type for @var{X}.
-@xref{SqRt Intrinsic}.
-
-@end ifset
-@ifset familyF90
-@node Ceiling Intrinsic
-@subsubsection Ceiling Intrinsic
-@cindex Ceiling intrinsic
-@cindex intrinsics, Ceiling
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Ceiling} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node CExp Intrinsic
-@subsubsection CExp Intrinsic
-@cindex CExp intrinsic
-@cindex intrinsics, CExp
-
-@noindent
-@example
-CExp(@var{X})
-@end example
-
-@noindent
-CExp: @code{COMPLEX(KIND=1)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{EXP()} that is specific
-to one type for @var{X}.
-@xref{Exp Intrinsic}.
-
-@node Char Intrinsic
-@subsubsection Char Intrinsic
-@cindex Char intrinsic
-@cindex intrinsics, Char
-
-@noindent
-@example
-Char(@var{I})
-@end example
-
-@noindent
-Char: @code{CHARACTER*1} function.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the character corresponding to the
-code specified by @var{I}, using the system's
-native character set.
-
-Because the system's native character set is used,
-the correspondence between character and their codes
-is not necessarily the same between GNU Fortran
-implementations.
-
-Note that no intrinsic exists to convert a numerical
-value to a printable character string.
-For example, there is no intrinsic that, given
-an @code{INTEGER} or @code{REAL} argument with the
-value @samp{154}, returns the @code{CHARACTER}
-result @samp{'154'}.
-
-Instead, you can use internal-file I/O to do this kind
-of conversion.
-For example:
-
-@smallexample
-INTEGER VALUE
-CHARACTER*10 STRING
-VALUE = 154
-WRITE (STRING, '(I10)'), VALUE
-PRINT *, STRING
-END
-@end smallexample
-
-The above program, when run, prints:
-
-@smallexample
- 154
-@end smallexample
-
-@xref{IChar Intrinsic}, for the inverse of the @code{CHAR} function.
-
-@xref{AChar Intrinsic}, for the function corresponding
-to the ASCII character set.
-
-@end ifset
-@ifset familyF2U
-@node ChDir Intrinsic (subroutine)
-@subsubsection ChDir Intrinsic (subroutine)
-@cindex ChDir intrinsic
-@cindex intrinsics, ChDir
-
-@noindent
-@example
-CALL ChDir(@var{Dir}, @var{Status})
-@end example
-
-@noindent
-@var{Dir}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Sets the current working directory to be @var{Dir}.
-If the @var{Status} argument is supplied, it contains 0
-on success or a nonzero error code otherwise upon return.
-See @code{chdir(3)}.
-
-@emph{Caution:} Using this routine during I/O to a unit connected with a
-non-absolute file name can cause subsequent I/O on such a unit to fail
-because the I/O library might reopen files by name.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{ChDir Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node ChDir Intrinsic (function)
-@subsubsection ChDir Intrinsic (function)
-@cindex ChDir intrinsic
-@cindex intrinsics, ChDir
-
-@noindent
-@example
-ChDir(@var{Dir})
-@end example
-
-@noindent
-ChDir: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Dir}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Sets the current working directory to be @var{Dir}.
-Returns 0 on success or a nonzero error code.
-See @code{chdir(3)}.
-
-@emph{Caution:} Using this routine during I/O to a unit connected with a
-non-absolute file name can cause subsequent I/O on such a unit to fail
-because the I/O library might reopen files by name.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{ChDir Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF2U
-@node ChMod Intrinsic (subroutine)
-@subsubsection ChMod Intrinsic (subroutine)
-@cindex ChMod intrinsic
-@cindex intrinsics, ChMod
-
-@noindent
-@example
-CALL ChMod(@var{Name}, @var{Mode}, @var{Status})
-@end example
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Mode}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Changes the access mode of file @var{Name} according to the
-specification @var{Mode}, which is given in the format of
-@code{chmod(1)}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{Name}---otherwise,
-trailing blanks in @var{Name} are ignored.
-Currently, @var{Name} must not contain the single quote
-character.
-
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Note that this currently works
-by actually invoking @code{/bin/chmod} (or the @code{chmod} found when
-the library was configured) and so might fail in some circumstances and
-will, anyway, be slow.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{ChMod Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node ChMod Intrinsic (function)
-@subsubsection ChMod Intrinsic (function)
-@cindex ChMod intrinsic
-@cindex intrinsics, ChMod
-
-@noindent
-@example
-ChMod(@var{Name}, @var{Mode})
-@end example
-
-@noindent
-ChMod: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Mode}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Changes the access mode of file @var{Name} according to the
-specification @var{Mode}, which is given in the format of
-@code{chmod(1)}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{Name}---otherwise,
-trailing blanks in @var{Name} are ignored.
-Currently, @var{Name} must not contain the single quote
-character.
-
-Returns 0 on success or a nonzero error code otherwise.
-
-Note that this currently works
-by actually invoking @code{/bin/chmod} (or the @code{chmod} found when
-the library was configured) and so might fail in some circumstances and
-will, anyway, be slow.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{ChMod Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF77
-@node CLog Intrinsic
-@subsubsection CLog Intrinsic
-@cindex CLog intrinsic
-@cindex intrinsics, CLog
-
-@noindent
-@example
-CLog(@var{X})
-@end example
-
-@noindent
-CLog: @code{COMPLEX(KIND=1)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{LOG()} that is specific
-to one type for @var{X}.
-@xref{Log Intrinsic}.
-
-@node Cmplx Intrinsic
-@subsubsection Cmplx Intrinsic
-@cindex Cmplx intrinsic
-@cindex intrinsics, Cmplx
-
-@noindent
-@example
-Cmplx(@var{X}, @var{Y})
-@end example
-
-@noindent
-Cmplx: @code{COMPLEX(KIND=1)} function.
-
-@noindent
-@var{X}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-@var{Y}: @code{INTEGER} or @code{REAL}; OPTIONAL (must be omitted if @var{X} is @code{COMPLEX}); scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-If @var{X} is not type @code{COMPLEX},
-constructs a value of type @code{COMPLEX(KIND=1)} from the
-real and imaginary values specified by @var{X} and
-@var{Y}, respectively.
-If @var{Y} is omitted, @samp{0.} is assumed.
-
-If @var{X} is type @code{COMPLEX},
-converts it to type @code{COMPLEX(KIND=1)}.
-
-@xref{Complex Intrinsic}, for information on easily constructing
-a @code{COMPLEX} value of arbitrary precision from @code{REAL}
-arguments.
-
-@end ifset
-@ifset familyGNU
-@node Complex Intrinsic
-@subsubsection Complex Intrinsic
-@cindex Complex intrinsic
-@cindex intrinsics, Complex
-
-@noindent
-@example
-Complex(@var{Real}, @var{Imag})
-@end example
-
-@noindent
-Complex: @code{COMPLEX} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{Real}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-@var{Imag}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{gnu}.
-
-@noindent
-Description:
-
-Returns a @code{COMPLEX} value that has @samp{Real} and @samp{Imag} as its
-real and imaginary parts, respectively.
-
-If @var{Real} and @var{Imag} are the same type, and that type is not
-@code{INTEGER}, no data conversion is performed, and the type of
-the resulting value has the same kind value as the types
-of @var{Real} and @var{Imag}.
-
-If @var{Real} and @var{Imag} are not the same type, the usual type-promotion
-rules are applied to both, converting either or both to the
-appropriate @code{REAL} type.
-The type of the resulting value has the same kind value as the
-type to which both @var{Real} and @var{Imag} were converted, in this case.
-
-If @var{Real} and @var{Imag} are both @code{INTEGER}, they are both converted
-to @code{REAL(KIND=1)}, and the result of the @code{COMPLEX()}
-invocation is type @code{COMPLEX(KIND=1)}.
-
-@emph{Note:} The way to do this in standard Fortran 90
-is too hairy to describe here, but it is important to
-note that @samp{CMPLX(D1,D2)} returns a @code{COMPLEX(KIND=1)}
-result even if @samp{D1} and @samp{D2} are type @code{REAL(KIND=2)}.
-Hence the availability of @code{COMPLEX()} in GNU Fortran.
-
-@end ifset
-@ifset familyF77
-@node Conjg Intrinsic
-@subsubsection Conjg Intrinsic
-@cindex Conjg intrinsic
-@cindex intrinsics, Conjg
-
-@noindent
-@example
-Conjg(@var{Z})
-@end example
-
-@noindent
-Conjg: @code{COMPLEX} function, the @samp{KIND=} value of the type being that of argument @var{Z}.
-
-@noindent
-@var{Z}: @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the complex conjugate:
-
-@example
-COMPLEX(REALPART(@var{Z}), -IMAGPART(@var{Z}))
-@end example
-
-@node Cos Intrinsic
-@subsubsection Cos Intrinsic
-@cindex Cos intrinsic
-@cindex intrinsics, Cos
-
-@noindent
-@example
-Cos(@var{X})
-@end example
-
-@noindent
-Cos: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the cosine of @var{X}, an angle measured
-in radians.
-
-@xref{ACos Intrinsic}, for the inverse of this function.
-
-@end ifset
-@ifset familyVXT
-@node CosD Intrinsic
-@subsubsection CosD Intrinsic
-@cindex CosD intrinsic
-@cindex intrinsics, CosD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL CosD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node CosH Intrinsic
-@subsubsection CosH Intrinsic
-@cindex CosH intrinsic
-@cindex intrinsics, CosH
-
-@noindent
-@example
-CosH(@var{X})
-@end example
-
-@noindent
-CosH: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the hyperbolic cosine of @var{X}.
-
-@end ifset
-@ifset familyF90
-@node Count Intrinsic
-@subsubsection Count Intrinsic
-@cindex Count intrinsic
-@cindex intrinsics, Count
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Count} to use this name for an
-external procedure.
-
-@node CPU_Time Intrinsic
-@subsubsection CPU_Time Intrinsic
-@cindex CPU_Time intrinsic
-@cindex intrinsics, CPU_Time
-
-@noindent
-@example
-CALL CPU_Time(@var{Seconds})
-@end example
-
-@noindent
-@var{Seconds}: @code{REAL}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{f90}.
-
-@noindent
-Description:
-
-Returns in @var{Seconds} the current value of the system time.
-This implementation of the Fortran 95 intrinsic is just an alias for
-@code{second} @xref{Second Intrinsic (subroutine)}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-@node CShift Intrinsic
-@subsubsection CShift Intrinsic
-@cindex CShift intrinsic
-@cindex intrinsics, CShift
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL CShift} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node CSin Intrinsic
-@subsubsection CSin Intrinsic
-@cindex CSin intrinsic
-@cindex intrinsics, CSin
-
-@noindent
-@example
-CSin(@var{X})
-@end example
-
-@noindent
-CSin: @code{COMPLEX(KIND=1)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{SIN()} that is specific
-to one type for @var{X}.
-@xref{Sin Intrinsic}.
-
-@node CSqRt Intrinsic
-@subsubsection CSqRt Intrinsic
-@cindex CSqRt intrinsic
-@cindex intrinsics, CSqRt
-
-@noindent
-@example
-CSqRt(@var{X})
-@end example
-
-@noindent
-CSqRt: @code{COMPLEX(KIND=1)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{SQRT()} that is specific
-to one type for @var{X}.
-@xref{SqRt Intrinsic}.
-
-@end ifset
-@ifset familyF2U
-@node CTime Intrinsic (subroutine)
-@subsubsection CTime Intrinsic (subroutine)
-@cindex CTime intrinsic
-@cindex intrinsics, CTime
-
-@noindent
-@example
-CALL CTime(@var{STime}, @var{Result})
-@end example
-
-@noindent
-@var{STime}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Result}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Converts @var{STime}, a system time value, such as returned by
-@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995},
-and returns that string in @var{Result}.
-
-@xref{Time8 Intrinsic}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-
-For information on other intrinsics with the same name:
-@xref{CTime Intrinsic (function)}.
-
-@node CTime Intrinsic (function)
-@subsubsection CTime Intrinsic (function)
-@cindex CTime intrinsic
-@cindex intrinsics, CTime
-
-@noindent
-@example
-CTime(@var{STime})
-@end example
-
-@noindent
-CTime: @code{CHARACTER*(*)} function.
-
-@noindent
-@var{STime}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Converts @var{STime}, a system time value, such as returned by
-@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995},
-and returns that string as the function value.
-
-@xref{Time8 Intrinsic}.
-
-For information on other intrinsics with the same name:
-@xref{CTime Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF77
-@node DAbs Intrinsic
-@subsubsection DAbs Intrinsic
-@cindex DAbs intrinsic
-@cindex intrinsics, DAbs
-
-@noindent
-@example
-DAbs(@var{A})
-@end example
-
-@noindent
-DAbs: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ABS()} that is specific
-to one type for @var{A}.
-@xref{Abs Intrinsic}.
-
-@node DACos Intrinsic
-@subsubsection DACos Intrinsic
-@cindex DACos intrinsic
-@cindex intrinsics, DACos
-
-@noindent
-@example
-DACos(@var{X})
-@end example
-
-@noindent
-DACos: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ACOS()} that is specific
-to one type for @var{X}.
-@xref{ACos Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node DACosD Intrinsic
-@subsubsection DACosD Intrinsic
-@cindex DACosD intrinsic
-@cindex intrinsics, DACosD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DACosD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node DASin Intrinsic
-@subsubsection DASin Intrinsic
-@cindex DASin intrinsic
-@cindex intrinsics, DASin
-
-@noindent
-@example
-DASin(@var{X})
-@end example
-
-@noindent
-DASin: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ASIN()} that is specific
-to one type for @var{X}.
-@xref{ASin Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node DASinD Intrinsic
-@subsubsection DASinD Intrinsic
-@cindex DASinD intrinsic
-@cindex intrinsics, DASinD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DASinD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node DATan Intrinsic
-@subsubsection DATan Intrinsic
-@cindex DATan intrinsic
-@cindex intrinsics, DATan
-
-@noindent
-@example
-DATan(@var{X})
-@end example
-
-@noindent
-DATan: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ATAN()} that is specific
-to one type for @var{X}.
-@xref{ATan Intrinsic}.
-
-@node DATan2 Intrinsic
-@subsubsection DATan2 Intrinsic
-@cindex DATan2 intrinsic
-@cindex intrinsics, DATan2
-
-@noindent
-@example
-DATan2(@var{Y}, @var{X})
-@end example
-
-@noindent
-DATan2: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{Y}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ATAN2()} that is specific
-to one type for @var{Y} and @var{X}.
-@xref{ATan2 Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node DATan2D Intrinsic
-@subsubsection DATan2D Intrinsic
-@cindex DATan2D intrinsic
-@cindex intrinsics, DATan2D
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DATan2D} to use this name for an
-external procedure.
-
-@node DATanD Intrinsic
-@subsubsection DATanD Intrinsic
-@cindex DATanD intrinsic
-@cindex intrinsics, DATanD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DATanD} to use this name for an
-external procedure.
-
-@node Date Intrinsic
-@subsubsection Date Intrinsic
-@cindex Date intrinsic
-@cindex intrinsics, Date
-
-@noindent
-@example
-CALL Date(@var{Date})
-@end example
-
-@noindent
-@var{Date}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{vxt}.
-
-@noindent
-Description:
-
-Returns @var{Date} in the form @samp{@var{dd}-@var{mmm}-@var{yy}},
-representing the numeric day of the month @var{dd}, a three-character
-abbreviation of the month name @var{mmm} and the last two digits of
-the year @var{yy}, e.g.@: @samp{25-Nov-96}.
-
-@cindex Y2K compliance
-@cindex Year 2000 compliance
-This intrinsic is not recommended, due to the year 2000 approaching.
-Therefore, programs making use of this intrinsic
-might not be Year 2000 (Y2K) compliant.
-@xref{CTime Intrinsic (subroutine)}, for information on obtaining more digits
-for the current (or any) date.
-
-@end ifset
-@ifset familyF90
-@node Date_and_Time Intrinsic
-@subsubsection Date_and_Time Intrinsic
-@cindex Date_and_Time intrinsic
-@cindex intrinsics, Date_and_Time
-
-@noindent
-@example
-CALL Date_and_Time(@var{Date}, @var{Time}, @var{Zone}, @var{Values})
-@end example
-
-@noindent
-@var{Date}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-@var{Time}: @code{CHARACTER}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-@var{Zone}: @code{CHARACTER}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-@var{Values}: @code{INTEGER(KIND=1)}; OPTIONAL; DIMENSION(8); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{f90}.
-
-@noindent
-Description:
-
-Returns:
-@table @var
-@item Date
-The date in the form @var{ccyymmdd}: century, year, month and day;
-@item Time
-The time in the form @samp{@var{hhmmss.ss}}: hours, minutes, seconds
-and milliseconds;
-@item Zone
-The difference between local time and UTC (GMT) in the form @var{Shhmm}:
-sign, hours and minutes, e.g.@: @samp{-0500} (winter in New York);
-@item Values
-The year, month of the year, day of the month, time difference in
-minutes from UTC, hour of the day, minutes of the hour, seconds
-of the minute, and milliseconds
-of the second in successive values of the array.
-@end table
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-On systems where a millisecond timer isn't available, the millisecond
-value is returned as zero.
-
-@end ifset
-@ifset familyF2U
-@node DbesJ0 Intrinsic
-@subsubsection DbesJ0 Intrinsic
-@cindex DbesJ0 intrinsic
-@cindex intrinsics, DbesJ0
-
-@noindent
-@example
-DbesJ0(@var{X})
-@end example
-
-@noindent
-DbesJ0: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{BESJ0()} that is specific
-to one type for @var{X}.
-@xref{BesJ0 Intrinsic}.
-
-@node DbesJ1 Intrinsic
-@subsubsection DbesJ1 Intrinsic
-@cindex DbesJ1 intrinsic
-@cindex intrinsics, DbesJ1
-
-@noindent
-@example
-DbesJ1(@var{X})
-@end example
-
-@noindent
-DbesJ1: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{BESJ1()} that is specific
-to one type for @var{X}.
-@xref{BesJ1 Intrinsic}.
-
-@node DbesJN Intrinsic
-@subsubsection DbesJN Intrinsic
-@cindex DbesJN intrinsic
-@cindex intrinsics, DbesJN
-
-@noindent
-@example
-DbesJN(@var{N}, @var{X})
-@end example
-
-@noindent
-DbesJN: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{N}: @code{INTEGER} not wider than the default kind; scalar; INTENT(IN).
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{BESJN()} that is specific
-to one type for @var{X}.
-@xref{BesJN Intrinsic}.
-
-@node DbesY0 Intrinsic
-@subsubsection DbesY0 Intrinsic
-@cindex DbesY0 intrinsic
-@cindex intrinsics, DbesY0
-
-@noindent
-@example
-DbesY0(@var{X})
-@end example
-
-@noindent
-DbesY0: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{BESY0()} that is specific
-to one type for @var{X}.
-@xref{BesY0 Intrinsic}.
-
-@node DbesY1 Intrinsic
-@subsubsection DbesY1 Intrinsic
-@cindex DbesY1 intrinsic
-@cindex intrinsics, DbesY1
-
-@noindent
-@example
-DbesY1(@var{X})
-@end example
-
-@noindent
-DbesY1: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{BESY1()} that is specific
-to one type for @var{X}.
-@xref{BesY1 Intrinsic}.
-
-@node DbesYN Intrinsic
-@subsubsection DbesYN Intrinsic
-@cindex DbesYN intrinsic
-@cindex intrinsics, DbesYN
-
-@noindent
-@example
-DbesYN(@var{N}, @var{X})
-@end example
-
-@noindent
-DbesYN: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{N}: @code{INTEGER} not wider than the default kind; scalar; INTENT(IN).
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{BESYN()} that is specific
-to one type for @var{X}.
-@xref{BesYN Intrinsic}.
-
-@end ifset
-@ifset familyF77
-@node Dble Intrinsic
-@subsubsection Dble Intrinsic
-@cindex Dble intrinsic
-@cindex intrinsics, Dble
-
-@noindent
-@example
-Dble(@var{A})
-@end example
-
-@noindent
-Dble: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @var{A} converted to double precision
-(@code{REAL(KIND=2)}).
-If @var{A} is @code{COMPLEX}, the real part of
-@var{A} is used for the conversion
-and the imaginary part disregarded.
-
-@xref{Sngl Intrinsic}, for the function that converts
-to single precision.
-
-@xref{Int Intrinsic}, for the function that converts
-to @code{INTEGER}.
-
-@xref{Complex Intrinsic}, for the function that converts
-to @code{COMPLEX}.
-
-@end ifset
-@ifset familyVXT
-@node DbleQ Intrinsic
-@subsubsection DbleQ Intrinsic
-@cindex DbleQ intrinsic
-@cindex intrinsics, DbleQ
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DbleQ} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyFVZ
-@node DCmplx Intrinsic
-@subsubsection DCmplx Intrinsic
-@cindex DCmplx intrinsic
-@cindex intrinsics, DCmplx
-
-@noindent
-@example
-DCmplx(@var{X}, @var{Y})
-@end example
-
-@noindent
-DCmplx: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-@var{Y}: @code{INTEGER} or @code{REAL}; OPTIONAL (must be omitted if @var{X} is @code{COMPLEX}); scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-If @var{X} is not type @code{COMPLEX},
-constructs a value of type @code{COMPLEX(KIND=2)} from the
-real and imaginary values specified by @var{X} and
-@var{Y}, respectively.
-If @var{Y} is omitted, @samp{0D0} is assumed.
-
-If @var{X} is type @code{COMPLEX},
-converts it to type @code{COMPLEX(KIND=2)}.
-
-Although this intrinsic is not standard Fortran,
-it is a popular extension offered by many compilers
-that support @code{DOUBLE COMPLEX}, since it offers
-the easiest way to convert to @code{DOUBLE COMPLEX}
-without using Fortran 90 features (such as the @samp{KIND=}
-argument to the @code{CMPLX()} intrinsic).
-
-(@samp{CMPLX(0D0, 0D0)} returns a single-precision
-@code{COMPLEX} result, as required by standard FORTRAN 77.
-That's why so many compilers provide @code{DCMPLX()}, since
-@samp{DCMPLX(0D0, 0D0)} returns a @code{DOUBLE COMPLEX}
-result.
-Still, @code{DCMPLX()} converts even @code{REAL*16} arguments
-to their @code{REAL*8} equivalents in most dialects of
-Fortran, so neither it nor @code{CMPLX()} allow easy
-construction of arbitrary-precision values without
-potentially forcing a conversion involving extending or
-reducing precision.
-GNU Fortran provides such an intrinsic, called @code{COMPLEX()}.)
-
-@xref{Complex Intrinsic}, for information on easily constructing
-a @code{COMPLEX} value of arbitrary precision from @code{REAL}
-arguments.
-
-@node DConjg Intrinsic
-@subsubsection DConjg Intrinsic
-@cindex DConjg intrinsic
-@cindex intrinsics, DConjg
-
-@noindent
-@example
-DConjg(@var{Z})
-@end example
-
-@noindent
-DConjg: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{Z}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{CONJG()} that is specific
-to one type for @var{Z}.
-@xref{Conjg Intrinsic}.
-
-@end ifset
-@ifset familyF77
-@node DCos Intrinsic
-@subsubsection DCos Intrinsic
-@cindex DCos intrinsic
-@cindex intrinsics, DCos
-
-@noindent
-@example
-DCos(@var{X})
-@end example
-
-@noindent
-DCos: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{COS()} that is specific
-to one type for @var{X}.
-@xref{Cos Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node DCosD Intrinsic
-@subsubsection DCosD Intrinsic
-@cindex DCosD intrinsic
-@cindex intrinsics, DCosD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DCosD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node DCosH Intrinsic
-@subsubsection DCosH Intrinsic
-@cindex DCosH intrinsic
-@cindex intrinsics, DCosH
-
-@noindent
-@example
-DCosH(@var{X})
-@end example
-
-@noindent
-DCosH: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{COSH()} that is specific
-to one type for @var{X}.
-@xref{CosH Intrinsic}.
-
-@node DDiM Intrinsic
-@subsubsection DDiM Intrinsic
-@cindex DDiM intrinsic
-@cindex intrinsics, DDiM
-
-@noindent
-@example
-DDiM(@var{X}, @var{Y})
-@end example
-
-@noindent
-DDiM: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-@var{Y}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{DIM()} that is specific
-to one type for @var{X} and @var{Y}.
-@xref{DiM Intrinsic}.
-
-@end ifset
-@ifset familyF2U
-@node DErF Intrinsic
-@subsubsection DErF Intrinsic
-@cindex DErF intrinsic
-@cindex intrinsics, DErF
-
-@noindent
-@example
-DErF(@var{X})
-@end example
-
-@noindent
-DErF: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{ERF()} that is specific
-to one type for @var{X}.
-@xref{ErF Intrinsic}.
-
-@node DErFC Intrinsic
-@subsubsection DErFC Intrinsic
-@cindex DErFC intrinsic
-@cindex intrinsics, DErFC
-
-@noindent
-@example
-DErFC(@var{X})
-@end example
-
-@noindent
-DErFC: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{ERFC()} that is specific
-to one type for @var{X}.
-@xref{ErFC Intrinsic}.
-
-@end ifset
-@ifset familyF77
-@node DExp Intrinsic
-@subsubsection DExp Intrinsic
-@cindex DExp intrinsic
-@cindex intrinsics, DExp
-
-@noindent
-@example
-DExp(@var{X})
-@end example
-
-@noindent
-DExp: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{EXP()} that is specific
-to one type for @var{X}.
-@xref{Exp Intrinsic}.
-
-@end ifset
-@ifset familyFVZ
-@node DFloat Intrinsic
-@subsubsection DFloat Intrinsic
-@cindex DFloat intrinsic
-@cindex intrinsics, DFloat
-
-@noindent
-@example
-DFloat(@var{A})
-@end example
-
-@noindent
-DFloat: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{REAL()} that is specific
-to one type for @var{A}.
-@xref{Real Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node DFlotI Intrinsic
-@subsubsection DFlotI Intrinsic
-@cindex DFlotI intrinsic
-@cindex intrinsics, DFlotI
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DFlotI} to use this name for an
-external procedure.
-
-@node DFlotJ Intrinsic
-@subsubsection DFlotJ Intrinsic
-@cindex DFlotJ intrinsic
-@cindex intrinsics, DFlotJ
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DFlotJ} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF90
-@node Digits Intrinsic
-@subsubsection Digits Intrinsic
-@cindex Digits intrinsic
-@cindex intrinsics, Digits
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Digits} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node DiM Intrinsic
-@subsubsection DiM Intrinsic
-@cindex DiM intrinsic
-@cindex intrinsics, DiM
-
-@noindent
-@example
-DiM(@var{X}, @var{Y})
-@end example
-
-@noindent
-DiM: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{X}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-@var{Y}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{@var{X}-@var{Y}} if @var{X} is greater than
-@var{Y}; otherwise returns zero.
-
-@end ifset
-@ifset familyFVZ
-@node DImag Intrinsic
-@subsubsection DImag Intrinsic
-@cindex DImag intrinsic
-@cindex intrinsics, DImag
-
-@noindent
-@example
-DImag(@var{Z})
-@end example
-
-@noindent
-DImag: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{Z}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{vxt}.
-
-@noindent
-Description:
-
-Archaic form of @code{AIMAG()} that is specific
-to one type for @var{Z}.
-@xref{AImag Intrinsic}.
-
-@end ifset
-@ifset familyF77
-@node DInt Intrinsic
-@subsubsection DInt Intrinsic
-@cindex DInt intrinsic
-@cindex intrinsics, DInt
-
-@noindent
-@example
-DInt(@var{A})
-@end example
-
-@noindent
-DInt: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{AINT()} that is specific
-to one type for @var{A}.
-@xref{AInt Intrinsic}.
-
-@node DLog Intrinsic
-@subsubsection DLog Intrinsic
-@cindex DLog intrinsic
-@cindex intrinsics, DLog
-
-@noindent
-@example
-DLog(@var{X})
-@end example
-
-@noindent
-DLog: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{LOG()} that is specific
-to one type for @var{X}.
-@xref{Log Intrinsic}.
-
-@node DLog10 Intrinsic
-@subsubsection DLog10 Intrinsic
-@cindex DLog10 intrinsic
-@cindex intrinsics, DLog10
-
-@noindent
-@example
-DLog10(@var{X})
-@end example
-
-@noindent
-DLog10: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{LOG10()} that is specific
-to one type for @var{X}.
-@xref{Log10 Intrinsic}.
-
-@node DMax1 Intrinsic
-@subsubsection DMax1 Intrinsic
-@cindex DMax1 intrinsic
-@cindex intrinsics, DMax1
-
-@noindent
-@example
-DMax1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-DMax1: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MAX()} that is specific
-to one type for @var{A}.
-@xref{Max Intrinsic}.
-
-@node DMin1 Intrinsic
-@subsubsection DMin1 Intrinsic
-@cindex DMin1 intrinsic
-@cindex intrinsics, DMin1
-
-@noindent
-@example
-DMin1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-DMin1: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MIN()} that is specific
-to one type for @var{A}.
-@xref{Min Intrinsic}.
-
-@node DMod Intrinsic
-@subsubsection DMod Intrinsic
-@cindex DMod intrinsic
-@cindex intrinsics, DMod
-
-@noindent
-@example
-DMod(@var{A}, @var{P})
-@end example
-
-@noindent
-DMod: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-@var{P}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MOD()} that is specific
-to one type for @var{A}.
-@xref{Mod Intrinsic}.
-
-@node DNInt Intrinsic
-@subsubsection DNInt Intrinsic
-@cindex DNInt intrinsic
-@cindex intrinsics, DNInt
-
-@noindent
-@example
-DNInt(@var{A})
-@end example
-
-@noindent
-DNInt: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ANINT()} that is specific
-to one type for @var{A}.
-@xref{ANInt Intrinsic}.
-
-@end ifset
-@ifset familyF90
-@node Dot_Product Intrinsic
-@subsubsection Dot_Product Intrinsic
-@cindex Dot_Product intrinsic
-@cindex intrinsics, Dot_Product
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Dot_Product} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node DProd Intrinsic
-@subsubsection DProd Intrinsic
-@cindex DProd intrinsic
-@cindex intrinsics, DProd
-
-@noindent
-@example
-DProd(@var{X}, @var{Y})
-@end example
-
-@noindent
-DProd: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-@var{Y}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{DBLE(@var{X})*DBLE(@var{Y})}.
-
-@end ifset
-@ifset familyVXT
-@node DReal Intrinsic
-@subsubsection DReal Intrinsic
-@cindex DReal intrinsic
-@cindex intrinsics, DReal
-
-@noindent
-@example
-DReal(@var{A})
-@end example
-
-@noindent
-DReal: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{vxt}.
-
-@noindent
-Description:
-
-Converts @var{A} to @code{REAL(KIND=2)}.
-
-If @var{A} is type @code{COMPLEX}, its real part
-is converted (if necessary) to @code{REAL(KIND=2)},
-and its imaginary part is disregarded.
-
-Although this intrinsic is not standard Fortran,
-it is a popular extension offered by many compilers
-that support @code{DOUBLE COMPLEX}, since it offers
-the easiest way to extract the real part of a @code{DOUBLE COMPLEX}
-value without using the Fortran 90 @code{REAL()} intrinsic
-in a way that produces a return value inconsistent with
-the way many FORTRAN 77 compilers handle @code{REAL()} of
-a @code{DOUBLE COMPLEX} value.
-
-@xref{RealPart Intrinsic}, for information on a GNU Fortran
-intrinsic that avoids these areas of confusion.
-
-@xref{Dble Intrinsic}, for information on the standard FORTRAN 77
-replacement for @code{DREAL()}.
-
-@xref{REAL() and AIMAG() of Complex}, for more information on
-this issue.
-
-@end ifset
-@ifset familyF77
-@node DSign Intrinsic
-@subsubsection DSign Intrinsic
-@cindex DSign intrinsic
-@cindex intrinsics, DSign
-
-@noindent
-@example
-DSign(@var{A}, @var{B})
-@end example
-
-@noindent
-DSign: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-@var{B}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{SIGN()} that is specific
-to one type for @var{A} and @var{B}.
-@xref{Sign Intrinsic}.
-
-@node DSin Intrinsic
-@subsubsection DSin Intrinsic
-@cindex DSin intrinsic
-@cindex intrinsics, DSin
-
-@noindent
-@example
-DSin(@var{X})
-@end example
-
-@noindent
-DSin: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{SIN()} that is specific
-to one type for @var{X}.
-@xref{Sin Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node DSinD Intrinsic
-@subsubsection DSinD Intrinsic
-@cindex DSinD intrinsic
-@cindex intrinsics, DSinD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DSinD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node DSinH Intrinsic
-@subsubsection DSinH Intrinsic
-@cindex DSinH intrinsic
-@cindex intrinsics, DSinH
-
-@noindent
-@example
-DSinH(@var{X})
-@end example
-
-@noindent
-DSinH: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{SINH()} that is specific
-to one type for @var{X}.
-@xref{SinH Intrinsic}.
-
-@node DSqRt Intrinsic
-@subsubsection DSqRt Intrinsic
-@cindex DSqRt intrinsic
-@cindex intrinsics, DSqRt
-
-@noindent
-@example
-DSqRt(@var{X})
-@end example
-
-@noindent
-DSqRt: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{SQRT()} that is specific
-to one type for @var{X}.
-@xref{SqRt Intrinsic}.
-
-@node DTan Intrinsic
-@subsubsection DTan Intrinsic
-@cindex DTan intrinsic
-@cindex intrinsics, DTan
-
-@noindent
-@example
-DTan(@var{X})
-@end example
-
-@noindent
-DTan: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{TAN()} that is specific
-to one type for @var{X}.
-@xref{Tan Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node DTanD Intrinsic
-@subsubsection DTanD Intrinsic
-@cindex DTanD intrinsic
-@cindex intrinsics, DTanD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL DTanD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node DTanH Intrinsic
-@subsubsection DTanH Intrinsic
-@cindex DTanH intrinsic
-@cindex intrinsics, DTanH
-
-@noindent
-@example
-DTanH(@var{X})
-@end example
-
-@noindent
-DTanH: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{TANH()} that is specific
-to one type for @var{X}.
-@xref{TanH Intrinsic}.
-
-@end ifset
-@ifset familyF2U
-@node DTime Intrinsic (subroutine)
-@subsubsection DTime Intrinsic (subroutine)
-@cindex DTime intrinsic
-@cindex intrinsics, DTime
-
-@noindent
-@example
-CALL DTime(@var{TArray}, @var{Result})
-@end example
-
-@noindent
-@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT).
-
-@noindent
-@var{Result}: @code{REAL(KIND=1)}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Initially, return the number of seconds of runtime
-since the start of the process's execution
-in @var{Result},
-and the user and system components of this in @samp{@var{TArray}(1)}
-and @samp{@var{TArray}(2)} respectively.
-The value of @var{Result} is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}.
-
-Subsequent invocations of @samp{DTIME()} set values based on accumulations
-since the previous invocation.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-
-For information on other intrinsics with the same name:
-@xref{DTime Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node DTime Intrinsic (function)
-@subsubsection DTime Intrinsic (function)
-@cindex DTime intrinsic
-@cindex intrinsics, DTime
-
-@noindent
-@example
-DTime(@var{TArray})
-@end example
-
-@noindent
-DTime: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Initially, return the number of seconds of runtime
-since the start of the process's execution
-as the function value,
-and the user and system components of this in @samp{@var{TArray}(1)}
-and @samp{@var{TArray}(2)} respectively.
-The functions' value is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}.
-
-Subsequent invocations of @samp{DTIME()} return values accumulated since the
-previous invocation.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{DTime Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node EOShift Intrinsic
-@subsubsection EOShift Intrinsic
-@cindex EOShift intrinsic
-@cindex intrinsics, EOShift
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL EOShift} to use this name for an
-external procedure.
-
-@node Epsilon Intrinsic
-@subsubsection Epsilon Intrinsic
-@cindex Epsilon intrinsic
-@cindex intrinsics, Epsilon
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Epsilon} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node ErF Intrinsic
-@subsubsection ErF Intrinsic
-@cindex ErF intrinsic
-@cindex intrinsics, ErF
-
-@noindent
-@example
-ErF(@var{X})
-@end example
-
-@noindent
-ErF: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the error function of @var{X}.
-See @code{erf(3m)}, which provides the implementation.
-
-@node ErFC Intrinsic
-@subsubsection ErFC Intrinsic
-@cindex ErFC intrinsic
-@cindex intrinsics, ErFC
-
-@noindent
-@example
-ErFC(@var{X})
-@end example
-
-@noindent
-ErFC: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the complementary error function of @var{X}:
-@samp{ERFC(R) = 1 - ERF(R)} (except that the result might be more
-accurate than explicitly evaluating that formulae would give).
-See @code{erfc(3m)}, which provides the implementation.
-
-@node ETime Intrinsic (subroutine)
-@subsubsection ETime Intrinsic (subroutine)
-@cindex ETime intrinsic
-@cindex intrinsics, ETime
-
-@noindent
-@example
-CALL ETime(@var{TArray}, @var{Result})
-@end example
-
-@noindent
-@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT).
-
-@noindent
-@var{Result}: @code{REAL(KIND=1)}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Return the number of seconds of runtime
-since the start of the process's execution
-in @var{Result},
-and the user and system components of this in @samp{@var{TArray}(1)}
-and @samp{@var{TArray}(2)} respectively.
-The value of @var{Result} is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-
-For information on other intrinsics with the same name:
-@xref{ETime Intrinsic (function)}.
-
-@node ETime Intrinsic (function)
-@subsubsection ETime Intrinsic (function)
-@cindex ETime intrinsic
-@cindex intrinsics, ETime
-
-@noindent
-@example
-ETime(@var{TArray})
-@end example
-
-@noindent
-ETime: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Return the number of seconds of runtime
-since the start of the process's execution
-as the function value,
-and the user and system components of this in @samp{@var{TArray}(1)}
-and @samp{@var{TArray}(2)} respectively.
-The functions' value is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-For information on other intrinsics with the same name:
-@xref{ETime Intrinsic (subroutine)}.
-
-@node Exit Intrinsic
-@subsubsection Exit Intrinsic
-@cindex Exit intrinsic
-@cindex intrinsics, Exit
-
-@noindent
-@example
-CALL Exit(@var{Status})
-@end example
-
-@noindent
-@var{Status}: @code{INTEGER} not wider than the default kind; OPTIONAL; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Exit the program with status @var{Status} after closing open Fortran
-I/O units and otherwise behaving as @code{exit(2)}.
-If @var{Status} is omitted the canonical `success' value
-will be returned to the system.
-
-@end ifset
-@ifset familyF77
-@node Exp Intrinsic
-@subsubsection Exp Intrinsic
-@cindex Exp intrinsic
-@cindex intrinsics, Exp
-
-@noindent
-@example
-Exp(@var{X})
-@end example
-
-@noindent
-Exp: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{@var{e}**@var{X}}, where
-@var{e} is approximately 2.7182818.
-
-@xref{Log Intrinsic}, for the inverse of this function.
-
-@end ifset
-@ifset familyF90
-@node Exponent Intrinsic
-@subsubsection Exponent Intrinsic
-@cindex Exponent intrinsic
-@cindex intrinsics, Exponent
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Exponent} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node FDate Intrinsic (subroutine)
-@subsubsection FDate Intrinsic (subroutine)
-@cindex FDate intrinsic
-@cindex intrinsics, FDate
-
-@noindent
-@example
-CALL FDate(@var{Date})
-@end example
-
-@noindent
-@var{Date}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the current date (using the same format as @code{CTIME()})
-in @var{Date}.
-
-Equivalent to:
-
-@example
-CALL CTIME(@var{Date}, TIME8())
-@end example
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-@xref{CTime Intrinsic (subroutine)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-
-For information on other intrinsics with the same name:
-@xref{FDate Intrinsic (function)}.
-
-@node FDate Intrinsic (function)
-@subsubsection FDate Intrinsic (function)
-@cindex FDate intrinsic
-@cindex intrinsics, FDate
-
-@noindent
-@example
-FDate()
-@end example
-
-@noindent
-FDate: @code{CHARACTER*(*)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the current date (using the same format as @code{CTIME()}).
-
-Equivalent to:
-
-@example
-CTIME(TIME8())
-@end example
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-@xref{CTime Intrinsic (function)}.
-
-For information on other intrinsics with the same name:
-@xref{FDate Intrinsic (subroutine)}.
-
-@node FGet Intrinsic (subroutine)
-@subsubsection FGet Intrinsic (subroutine)
-@cindex FGet intrinsic
-@cindex intrinsics, FGet
-
-@noindent
-@example
-CALL FGet(@var{C}, @var{Status})
-@end example
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Reads a single character into @var{C} in stream mode from unit 5
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns in
-@var{Status} 0 on success, @minus{}1 on end-of-file, and the error code
-from @code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FGet Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node FGet Intrinsic (function)
-@subsubsection FGet Intrinsic (function)
-@cindex FGet intrinsic
-@cindex intrinsics, FGet
-
-@noindent
-@example
-FGet(@var{C})
-@end example
-
-@noindent
-FGet: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Reads a single character into @var{C} in stream mode from unit 5
-(by-passing normal formatted input) using @code{getc(3)}.
-Returns 0 on
-success, @minus{}1 on end-of-file, and the error code from
-@code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FGet Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF2U
-@node FGetC Intrinsic (subroutine)
-@subsubsection FGetC Intrinsic (subroutine)
-@cindex FGetC intrinsic
-@cindex intrinsics, FGetC
-
-@noindent
-@example
-CALL FGetC(@var{Unit}, @var{C}, @var{Status})
-@end example
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Reads a single character into @var{C} in stream mode from unit @var{Unit}
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns in
-@var{Status} 0 on success, @minus{}1 on end-of-file, and the error code from
-@code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FGetC Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node FGetC Intrinsic (function)
-@subsubsection FGetC Intrinsic (function)
-@cindex FGetC intrinsic
-@cindex intrinsics, FGetC
-
-@noindent
-@example
-FGetC(@var{Unit}, @var{C})
-@end example
-
-@noindent
-FGetC: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Reads a single character into @var{C} in stream mode from unit @var{Unit}
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns 0 on
-success, @minus{}1 on end-of-file, and the error code from
-@code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FGetC Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF77
-@node Float Intrinsic
-@subsubsection Float Intrinsic
-@cindex Float intrinsic
-@cindex intrinsics, Float
-
-@noindent
-@example
-Float(@var{A})
-@end example
-
-@noindent
-Float: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{REAL()} that is specific
-to one type for @var{A}.
-@xref{Real Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node FloatI Intrinsic
-@subsubsection FloatI Intrinsic
-@cindex FloatI intrinsic
-@cindex intrinsics, FloatI
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL FloatI} to use this name for an
-external procedure.
-
-@node FloatJ Intrinsic
-@subsubsection FloatJ Intrinsic
-@cindex FloatJ intrinsic
-@cindex intrinsics, FloatJ
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL FloatJ} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF90
-@node Floor Intrinsic
-@subsubsection Floor Intrinsic
-@cindex Floor intrinsic
-@cindex intrinsics, Floor
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Floor} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node Flush Intrinsic
-@subsubsection Flush Intrinsic
-@cindex Flush intrinsic
-@cindex intrinsics, Flush
-
-@noindent
-@example
-CALL Flush(@var{Unit})
-@end example
-
-@noindent
-@var{Unit}: @code{INTEGER}; OPTIONAL; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Flushes Fortran unit(s) currently open for output.
-Without the optional argument, all such units are flushed,
-otherwise just the unit specified by @var{Unit}.
-
-Some non-GNU implementations of Fortran provide this intrinsic
-as a library procedure that might or might not support the
-(optional) @var{Unit} argument.
-
-@node FNum Intrinsic
-@subsubsection FNum Intrinsic
-@cindex FNum intrinsic
-@cindex intrinsics, FNum
-
-@noindent
-@example
-FNum(@var{Unit})
-@end example
-
-@noindent
-FNum: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the Unix file descriptor number corresponding to the open
-Fortran I/O unit @var{Unit}.
-This could be passed to an interface to C I/O routines.
-
-@node FPut Intrinsic (subroutine)
-@subsubsection FPut Intrinsic (subroutine)
-@cindex FPut intrinsic
-@cindex intrinsics, FPut
-
-@noindent
-@example
-CALL FPut(@var{C}, @var{Status})
-@end example
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Writes the single character @var{C} in stream mode to unit 6
-(by-passing normal formatted output) using @code{putc(3)}.
-Returns in
-@var{Status} 0 on success, the error code from @code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FPut Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node FPut Intrinsic (function)
-@subsubsection FPut Intrinsic (function)
-@cindex FPut intrinsic
-@cindex intrinsics, FPut
-
-@noindent
-@example
-FPut(@var{C})
-@end example
-
-@noindent
-FPut: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Writes the single character @var{C} in stream mode to unit 6
-(by-passing normal formatted output) using @code{getc(3)}.
-Returns 0 on
-success, the error code from @code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FPut Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF2U
-@node FPutC Intrinsic (subroutine)
-@subsubsection FPutC Intrinsic (subroutine)
-@cindex FPutC intrinsic
-@cindex intrinsics, FPutC
-
-@noindent
-@example
-CALL FPutC(@var{Unit}, @var{C}, @var{Status})
-@end example
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Writes the single character @var{Unit} in stream mode to unit 6
-(by-passing normal formatted output) using @code{putc(3)}.
-Returns in
-@var{C} 0 on success, the error code from @code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FPutC Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node FPutC Intrinsic (function)
-@subsubsection FPutC Intrinsic (function)
-@cindex FPutC intrinsic
-@cindex intrinsics, FPutC
-
-@noindent
-@example
-FPutC(@var{Unit}, @var{C})
-@end example
-
-@noindent
-FPutC: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Writes the single character @var{C} in stream mode to unit @var{Unit}
-(by-passing normal formatted output) using @code{putc(3)}.
-Returns 0 on
-success, the error code from @code{ferror(3)} otherwise.
-
-Stream I/O should not be mixed with normal record-oriented (formatted or
-unformatted) I/O on the same unit; the results are unpredictable.
-
-For information on other intrinsics with the same name:
-@xref{FPutC Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node Fraction Intrinsic
-@subsubsection Fraction Intrinsic
-@cindex Fraction intrinsic
-@cindex intrinsics, Fraction
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Fraction} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node FSeek Intrinsic
-@subsubsection FSeek Intrinsic
-@cindex FSeek intrinsic
-@cindex intrinsics, FSeek
-
-@noindent
-@example
-CALL FSeek(@var{Unit}, @var{Offset}, @var{Whence}, @var{ErrLab})
-@end example
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Offset}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Whence}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{ErrLab}: @samp{*@var{label}}, where @var{label} is the label
-of an executable statement; OPTIONAL.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Attempts to move Fortran unit @var{Unit} to the specified
-@var{Offset}: absolute offset if @var{Whence}=0; relative to the
-current offset if @var{Whence}=1; relative to the end of the file if
-@var{Whence}=2.
-It branches to label @var{ErrLab} if @var{Unit} is
-not open or if the call otherwise fails.
-
-@node FStat Intrinsic (subroutine)
-@subsubsection FStat Intrinsic (subroutine)
-@cindex FStat intrinsic
-@cindex intrinsics, FStat
-
-@noindent
-@example
-CALL FStat(@var{Unit}, @var{SArray}, @var{Status})
-@end example
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Obtains data about the file open on Fortran I/O unit @var{Unit} and
-places them in the array @var{SArray}.
-The values in this array are
-extracted from the @code{stat} structure as returned by
-@code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{FStat Intrinsic (function)}.
-
-@node FStat Intrinsic (function)
-@subsubsection FStat Intrinsic (function)
-@cindex FStat intrinsic
-@cindex intrinsics, FStat
-
-@noindent
-@example
-FStat(@var{Unit}, @var{SArray})
-@end example
-
-@noindent
-FStat: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Obtains data about the file open on Fortran I/O unit @var{Unit} and
-places them in the array @var{SArray}.
-The values in this array are
-extracted from the @code{stat} structure as returned by
-@code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-Returns 0 on success or a nonzero error code.
-
-For information on other intrinsics with the same name:
-@xref{FStat Intrinsic (subroutine)}.
-
-@node FTell Intrinsic (subroutine)
-@subsubsection FTell Intrinsic (subroutine)
-@cindex FTell intrinsic
-@cindex intrinsics, FTell
-
-@noindent
-@example
-CALL FTell(@var{Unit}, @var{Offset})
-@end example
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Offset}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Sets @var{Offset} to the current offset of Fortran unit @var{Unit}
-(or to @minus{}1 if @var{Unit} is not open).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-
-For information on other intrinsics with the same name:
-@xref{FTell Intrinsic (function)}.
-
-@node FTell Intrinsic (function)
-@subsubsection FTell Intrinsic (function)
-@cindex FTell intrinsic
-@cindex intrinsics, FTell
-
-@noindent
-@example
-FTell(@var{Unit})
-@end example
-
-@noindent
-FTell: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the current offset of Fortran unit @var{Unit}
-(or @minus{}1 if @var{Unit} is not open).
-
-For information on other intrinsics with the same name:
-@xref{FTell Intrinsic (subroutine)}.
-
-@node GError Intrinsic
-@subsubsection GError Intrinsic
-@cindex GError intrinsic
-@cindex intrinsics, GError
-
-@noindent
-@example
-CALL GError(@var{Message})
-@end example
-
-@noindent
-@var{Message}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the system error message corresponding to the last system
-error (C @code{errno}).
-
-@node GetArg Intrinsic
-@subsubsection GetArg Intrinsic
-@cindex GetArg intrinsic
-@cindex intrinsics, GetArg
-
-@noindent
-@example
-CALL GetArg(@var{Pos}, @var{Value})
-@end example
-
-@noindent
-@var{Pos}: @code{INTEGER} not wider than the default kind; scalar; INTENT(IN).
-
-@noindent
-@var{Value}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Sets @var{Value} to the @var{Pos}-th command-line argument (or to all
-blanks if there are fewer than @var{Value} command-line arguments);
-@code{CALL GETARG(0, @var{value})} sets @var{value} to the name of the
-program (on systems that support this feature).
-
-@xref{IArgC Intrinsic}, for information on how to get the number
-of arguments.
-
-@node GetCWD Intrinsic (subroutine)
-@subsubsection GetCWD Intrinsic (subroutine)
-@cindex GetCWD intrinsic
-@cindex intrinsics, GetCWD
-
-@noindent
-@example
-CALL GetCWD(@var{Name}, @var{Status})
-@end example
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Places the current working directory in @var{Name}.
-If the @var{Status} argument is supplied, it contains 0
-success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{getcwd(3)}
-or @code{getwd(3)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{GetCWD Intrinsic (function)}.
-
-@node GetCWD Intrinsic (function)
-@subsubsection GetCWD Intrinsic (function)
-@cindex GetCWD intrinsic
-@cindex intrinsics, GetCWD
-
-@noindent
-@example
-GetCWD(@var{Name})
-@end example
-
-@noindent
-GetCWD: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Places the current working directory in @var{Name}.
-Returns 0 on
-success, otherwise a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{getcwd(3)}
-or @code{getwd(3)}).
-
-For information on other intrinsics with the same name:
-@xref{GetCWD Intrinsic (subroutine)}.
-
-@node GetEnv Intrinsic
-@subsubsection GetEnv Intrinsic
-@cindex GetEnv intrinsic
-@cindex intrinsics, GetEnv
-
-@noindent
-@example
-CALL GetEnv(@var{Name}, @var{Value})
-@end example
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Value}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Sets @var{Value} to the value of environment variable given by the
-value of @var{Name} (@code{$name} in shell terms) or to blanks if
-@code{$name} has not been set.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{Name}---otherwise,
-trailing blanks in @var{Name} are ignored.
-
-@node GetGId Intrinsic
-@subsubsection GetGId Intrinsic
-@cindex GetGId intrinsic
-@cindex intrinsics, GetGId
-
-@noindent
-@example
-GetGId()
-@end example
-
-@noindent
-GetGId: @code{INTEGER(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the group id for the current process.
-
-@node GetLog Intrinsic
-@subsubsection GetLog Intrinsic
-@cindex GetLog intrinsic
-@cindex intrinsics, GetLog
-
-@noindent
-@example
-CALL GetLog(@var{Login})
-@end example
-
-@noindent
-@var{Login}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the login name for the process in @var{Login}.
-
-@emph{Caution:} On some systems, the @code{getlogin(3)}
-function, which this intrinsic calls at run time,
-is either not implemented or returns a null pointer.
-In the latter case, this intrinsic returns blanks
-in @var{Login}.
-
-@node GetPId Intrinsic
-@subsubsection GetPId Intrinsic
-@cindex GetPId intrinsic
-@cindex intrinsics, GetPId
-
-@noindent
-@example
-GetPId()
-@end example
-
-@noindent
-GetPId: @code{INTEGER(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the process id for the current process.
-
-@node GetUId Intrinsic
-@subsubsection GetUId Intrinsic
-@cindex GetUId intrinsic
-@cindex intrinsics, GetUId
-
-@noindent
-@example
-GetUId()
-@end example
-
-@noindent
-GetUId: @code{INTEGER(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the user id for the current process.
-
-@node GMTime Intrinsic
-@subsubsection GMTime Intrinsic
-@cindex GMTime intrinsic
-@cindex intrinsics, GMTime
-
-@noindent
-@example
-CALL GMTime(@var{STime}, @var{TArray})
-@end example
-
-@noindent
-@var{STime}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(9); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Given a system time value @var{STime}, fills @var{TArray} with values
-extracted from it appropriate to the GMT time zone using
-@code{gmtime(3)}.
-
-The array elements are as follows:
-
-@enumerate
-@item
-Seconds after the minute, range 0--59 or 0--61 to allow for leap
-seconds
-
-@item
-Minutes after the hour, range 0--59
-
-@item
-Hours past midnight, range 0--23
-
-@item
-Day of month, range 0--31
-
-@item
-Number of months since January, range 0--12
-
-@item
-Years since 1900
-
-@item
-Number of days since Sunday, range 0--6
-
-@item
-Days since January 1
-
-@item
-Daylight savings indicator: positive if daylight savings is in effect,
-zero if not, and negative if the information isn't available.
-@end enumerate
-
-@node HostNm Intrinsic (subroutine)
-@subsubsection HostNm Intrinsic (subroutine)
-@cindex HostNm intrinsic
-@cindex intrinsics, HostNm
-
-@noindent
-@example
-CALL HostNm(@var{Name}, @var{Status})
-@end example
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Fills @var{Name} with the system's host name returned by
-@code{gethostname(2)}.
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{gethostname(2)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-On some systems (specifically SCO) it might be necessary to link the
-``socket'' library if you call this routine.
-Typically this means adding @samp{-lg2c -lsocket -lm}
-to the @code{g77} command line when linking the program.
-
-For information on other intrinsics with the same name:
-@xref{HostNm Intrinsic (function)}.
-
-@node HostNm Intrinsic (function)
-@subsubsection HostNm Intrinsic (function)
-@cindex HostNm intrinsic
-@cindex intrinsics, HostNm
-
-@noindent
-@example
-HostNm(@var{Name})
-@end example
-
-@noindent
-HostNm: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Fills @var{Name} with the system's host name returned by
-@code{gethostname(2)}, returning 0 on success or a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{gethostname(2)}).
-
-On some systems (specifically SCO) it might be necessary to link the
-``socket'' library if you call this routine.
-Typically this means adding @samp{-lg2c -lsocket -lm}
-to the @code{g77} command line when linking the program.
-
-For information on other intrinsics with the same name:
-@xref{HostNm Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node Huge Intrinsic
-@subsubsection Huge Intrinsic
-@cindex Huge intrinsic
-@cindex intrinsics, Huge
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Huge} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node IAbs Intrinsic
-@subsubsection IAbs Intrinsic
-@cindex IAbs intrinsic
-@cindex intrinsics, IAbs
-
-@noindent
-@example
-IAbs(@var{A})
-@end example
-
-@noindent
-IAbs: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{ABS()} that is specific
-to one type for @var{A}.
-@xref{Abs Intrinsic}.
-
-@end ifset
-@ifset familyASC
-@node IAChar Intrinsic
-@subsubsection IAChar Intrinsic
-@cindex IAChar intrinsic
-@cindex intrinsics, IAChar
-
-@noindent
-@example
-IAChar(@var{C})
-@end example
-
-@noindent
-IAChar: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}, @code{f90}.
-
-@noindent
-Description:
-
-Returns the code for the ASCII character in the
-first character position of @var{C}.
-
-@xref{AChar Intrinsic}, for the inverse of this function.
-
-@xref{IChar Intrinsic}, for the function corresponding
-to the system's native character set.
-
-@end ifset
-@ifset familyMIL
-@node IAnd Intrinsic
-@subsubsection IAnd Intrinsic
-@cindex IAnd intrinsic
-@cindex intrinsics, IAnd
-
-@noindent
-@example
-IAnd(@var{I}, @var{J})
-@end example
-
-@noindent
-IAnd: @code{INTEGER} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{J}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Returns value resulting from boolean AND of
-pair of bits in each of @var{I} and @var{J}.
-
-@end ifset
-@ifset familyF2U
-@node IArgC Intrinsic
-@subsubsection IArgC Intrinsic
-@cindex IArgC intrinsic
-@cindex intrinsics, IArgC
-
-@noindent
-@example
-IArgC()
-@end example
-
-@noindent
-IArgC: @code{INTEGER(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the number of command-line arguments.
-
-This count does not include the specification of the program
-name itself.
-
-@end ifset
-@ifset familyMIL
-@node IBClr Intrinsic
-@subsubsection IBClr Intrinsic
-@cindex IBClr intrinsic
-@cindex intrinsics, IBClr
-
-@noindent
-@example
-IBClr(@var{I}, @var{Pos})
-@end example
-
-@noindent
-IBClr: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Pos}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Returns the value of @var{I} with bit @var{Pos} cleared (set to
-zero).
-@xref{BTest Intrinsic}, for information on bit positions.
-
-@node IBits Intrinsic
-@subsubsection IBits Intrinsic
-@cindex IBits intrinsic
-@cindex intrinsics, IBits
-
-@noindent
-@example
-IBits(@var{I}, @var{Pos}, @var{Len})
-@end example
-
-@noindent
-IBits: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Pos}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Len}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Extracts a subfield of length @var{Len} from @var{I}, starting from
-bit position @var{Pos} and extending left for @var{Len} bits.
-The result is right-justified and the remaining bits are zeroed.
-The value
-of @samp{@var{Pos}+@var{Len}} must be less than or equal to the value
-@samp{BIT_SIZE(@var{I})}.
-@xref{Bit_Size Intrinsic}.
-
-@node IBSet Intrinsic
-@subsubsection IBSet Intrinsic
-@cindex IBSet intrinsic
-@cindex intrinsics, IBSet
-
-@noindent
-@example
-IBSet(@var{I}, @var{Pos})
-@end example
-
-@noindent
-IBSet: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Pos}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Returns the value of @var{I} with bit @var{Pos} set (to one).
-@xref{BTest Intrinsic}, for information on bit positions.
-
-@end ifset
-@ifset familyF77
-@node IChar Intrinsic
-@subsubsection IChar Intrinsic
-@cindex IChar intrinsic
-@cindex intrinsics, IChar
-
-@noindent
-@example
-IChar(@var{C})
-@end example
-
-@noindent
-IChar: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{C}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the code for the character in the
-first character position of @var{C}.
-
-Because the system's native character set is used,
-the correspondence between character and their codes
-is not necessarily the same between GNU Fortran
-implementations.
-
-Note that no intrinsic exists to convert a printable
-character string to a numerical value.
-For example, there is no intrinsic that, given
-the @code{CHARACTER} value @samp{'154'}, returns an
-@code{INTEGER} or @code{REAL} value with the value @samp{154}.
-
-Instead, you can use internal-file I/O to do this kind
-of conversion.
-For example:
-
-@smallexample
-INTEGER VALUE
-CHARACTER*10 STRING
-STRING = '154'
-READ (STRING, '(I10)'), VALUE
-PRINT *, VALUE
-END
-@end smallexample
-
-The above program, when run, prints:
-
-@smallexample
- 154
-@end smallexample
-
-@xref{Char Intrinsic}, for the inverse of the @code{ICHAR} function.
-
-@xref{IAChar Intrinsic}, for the function corresponding
-to the ASCII character set.
-
-@end ifset
-@ifset familyF2U
-@node IDate Intrinsic (UNIX)
-@subsubsection IDate Intrinsic (UNIX)
-@cindex IDate intrinsic
-@cindex intrinsics, IDate
-
-@noindent
-@example
-CALL IDate(@var{TArray})
-@end example
-
-@noindent
-@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(3); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Fills @var{TArray} with the numerical values at the current local time.
-The day (in the range 1--31), month (in the range 1--12),
-and year appear in elements 1, 2, and 3 of @var{TArray}, respectively.
-The year has four significant digits.
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-For information on other intrinsics with the same name:
-@xref{IDate Intrinsic (VXT)}.
-
-@end ifset
-@ifset familyVXT
-@node IDate Intrinsic (VXT)
-@subsubsection IDate Intrinsic (VXT)
-@cindex IDate intrinsic
-@cindex intrinsics, IDate
-
-@noindent
-@example
-CALL IDate(@var{M}, @var{D}, @var{Y})
-@end example
-
-@noindent
-@var{M}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT).
-
-@noindent
-@var{D}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT).
-
-@noindent
-@var{Y}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{vxt}.
-
-@noindent
-Description:
-
-Returns the numerical values of the current local time.
-The month (in the range 1--12) is returned in @var{M},
-the day (in the range 1--31) in @var{D},
-and the year in @var{Y} (in the range 0--99).
-
-@cindex Y2K compliance
-@cindex Year 2000 compliance
-@cindex wraparound, Y2K
-@cindex limits, Y2K
-This intrinsic is not recommended, due to the fact that
-its return value for year wraps around century boundaries
-(change from a larger value to a smaller one).
-Therefore, programs making use of this intrinsic, for
-instance, might not be Year 2000 (Y2K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-as of the Year 2000.
-
-@xref{IDate Intrinsic (UNIX)}, for information on obtaining more digits
-for the current date.
-
-For information on other intrinsics with the same name:
-@xref{IDate Intrinsic (UNIX)}.
-
-@end ifset
-@ifset familyF77
-@node IDiM Intrinsic
-@subsubsection IDiM Intrinsic
-@cindex IDiM intrinsic
-@cindex intrinsics, IDiM
-
-@noindent
-@example
-IDiM(@var{X}, @var{Y})
-@end example
-
-@noindent
-IDiM: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{X}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-@var{Y}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{DIM()} that is specific
-to one type for @var{X} and @var{Y}.
-@xref{DiM Intrinsic}.
-
-@node IDInt Intrinsic
-@subsubsection IDInt Intrinsic
-@cindex IDInt intrinsic
-@cindex intrinsics, IDInt
-
-@noindent
-@example
-IDInt(@var{A})
-@end example
-
-@noindent
-IDInt: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{INT()} that is specific
-to one type for @var{A}.
-@xref{Int Intrinsic}.
-
-@node IDNInt Intrinsic
-@subsubsection IDNInt Intrinsic
-@cindex IDNInt intrinsic
-@cindex intrinsics, IDNInt
-
-@noindent
-@example
-IDNInt(@var{A})
-@end example
-
-@noindent
-IDNInt: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{NINT()} that is specific
-to one type for @var{A}.
-@xref{NInt Intrinsic}.
-
-@end ifset
-@ifset familyMIL
-@node IEOr Intrinsic
-@subsubsection IEOr Intrinsic
-@cindex IEOr intrinsic
-@cindex intrinsics, IEOr
-
-@noindent
-@example
-IEOr(@var{I}, @var{J})
-@end example
-
-@noindent
-IEOr: @code{INTEGER} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{J}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Returns value resulting from boolean exclusive-OR of
-pair of bits in each of @var{I} and @var{J}.
-
-@end ifset
-@ifset familyF2U
-@node IErrNo Intrinsic
-@subsubsection IErrNo Intrinsic
-@cindex IErrNo intrinsic
-@cindex intrinsics, IErrNo
-
-@noindent
-@example
-IErrNo()
-@end example
-
-@noindent
-IErrNo: @code{INTEGER(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the last system error number (corresponding to the C
-@code{errno}).
-
-@end ifset
-@ifset familyF77
-@node IFix Intrinsic
-@subsubsection IFix Intrinsic
-@cindex IFix intrinsic
-@cindex intrinsics, IFix
-
-@noindent
-@example
-IFix(@var{A})
-@end example
-
-@noindent
-IFix: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{INT()} that is specific
-to one type for @var{A}.
-@xref{Int Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node IIAbs Intrinsic
-@subsubsection IIAbs Intrinsic
-@cindex IIAbs intrinsic
-@cindex intrinsics, IIAbs
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIAbs} to use this name for an
-external procedure.
-
-@node IIAnd Intrinsic
-@subsubsection IIAnd Intrinsic
-@cindex IIAnd intrinsic
-@cindex intrinsics, IIAnd
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIAnd} to use this name for an
-external procedure.
-
-@node IIBClr Intrinsic
-@subsubsection IIBClr Intrinsic
-@cindex IIBClr intrinsic
-@cindex intrinsics, IIBClr
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIBClr} to use this name for an
-external procedure.
-
-@node IIBits Intrinsic
-@subsubsection IIBits Intrinsic
-@cindex IIBits intrinsic
-@cindex intrinsics, IIBits
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIBits} to use this name for an
-external procedure.
-
-@node IIBSet Intrinsic
-@subsubsection IIBSet Intrinsic
-@cindex IIBSet intrinsic
-@cindex intrinsics, IIBSet
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIBSet} to use this name for an
-external procedure.
-
-@node IIDiM Intrinsic
-@subsubsection IIDiM Intrinsic
-@cindex IIDiM intrinsic
-@cindex intrinsics, IIDiM
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIDiM} to use this name for an
-external procedure.
-
-@node IIDInt Intrinsic
-@subsubsection IIDInt Intrinsic
-@cindex IIDInt intrinsic
-@cindex intrinsics, IIDInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIDInt} to use this name for an
-external procedure.
-
-@node IIDNnt Intrinsic
-@subsubsection IIDNnt Intrinsic
-@cindex IIDNnt intrinsic
-@cindex intrinsics, IIDNnt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIDNnt} to use this name for an
-external procedure.
-
-@node IIEOr Intrinsic
-@subsubsection IIEOr Intrinsic
-@cindex IIEOr intrinsic
-@cindex intrinsics, IIEOr
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIEOr} to use this name for an
-external procedure.
-
-@node IIFix Intrinsic
-@subsubsection IIFix Intrinsic
-@cindex IIFix intrinsic
-@cindex intrinsics, IIFix
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIFix} to use this name for an
-external procedure.
-
-@node IInt Intrinsic
-@subsubsection IInt Intrinsic
-@cindex IInt intrinsic
-@cindex intrinsics, IInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IInt} to use this name for an
-external procedure.
-
-@node IIOr Intrinsic
-@subsubsection IIOr Intrinsic
-@cindex IIOr intrinsic
-@cindex intrinsics, IIOr
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIOr} to use this name for an
-external procedure.
-
-@node IIQint Intrinsic
-@subsubsection IIQint Intrinsic
-@cindex IIQint intrinsic
-@cindex intrinsics, IIQint
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIQint} to use this name for an
-external procedure.
-
-@node IIQNnt Intrinsic
-@subsubsection IIQNnt Intrinsic
-@cindex IIQNnt intrinsic
-@cindex intrinsics, IIQNnt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIQNnt} to use this name for an
-external procedure.
-
-@node IIShftC Intrinsic
-@subsubsection IIShftC Intrinsic
-@cindex IIShftC intrinsic
-@cindex intrinsics, IIShftC
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IIShftC} to use this name for an
-external procedure.
-
-@node IISign Intrinsic
-@subsubsection IISign Intrinsic
-@cindex IISign intrinsic
-@cindex intrinsics, IISign
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IISign} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2C
-@node Imag Intrinsic
-@subsubsection Imag Intrinsic
-@cindex Imag intrinsic
-@cindex intrinsics, Imag
-
-@noindent
-@example
-Imag(@var{Z})
-@end example
-
-@noindent
-Imag: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{Z}.
-
-@noindent
-@var{Z}: @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-The imaginary part of @var{Z} is returned, without conversion.
-
-@emph{Note:} The way to do this in standard Fortran 90
-is @samp{AIMAG(@var{Z})}.
-However, when, for example, @var{Z} is @code{DOUBLE COMPLEX},
-@samp{AIMAG(@var{Z})} means something different for some compilers
-that are not true Fortran 90 compilers but offer some
-extensions standardized by Fortran 90 (such as the
-@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}).
-
-The advantage of @code{IMAG()} is that, while not necessarily
-more or less portable than @code{AIMAG()}, it is more likely to
-cause a compiler that doesn't support it to produce a diagnostic
-than generate incorrect code.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-
-@end ifset
-@ifset familyGNU
-@node ImagPart Intrinsic
-@subsubsection ImagPart Intrinsic
-@cindex ImagPart intrinsic
-@cindex intrinsics, ImagPart
-
-@noindent
-@example
-ImagPart(@var{Z})
-@end example
-
-@noindent
-ImagPart: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{Z}.
-
-@noindent
-@var{Z}: @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{gnu}.
-
-@noindent
-Description:
-
-The imaginary part of @var{Z} is returned, without conversion.
-
-@emph{Note:} The way to do this in standard Fortran 90
-is @samp{AIMAG(@var{Z})}.
-However, when, for example, @var{Z} is @code{DOUBLE COMPLEX},
-@samp{AIMAG(@var{Z})} means something different for some compilers
-that are not true Fortran 90 compilers but offer some
-extensions standardized by Fortran 90 (such as the
-@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}).
-
-The advantage of @code{IMAGPART()} is that, while not necessarily
-more or less portable than @code{AIMAG()}, it is more likely to
-cause a compiler that doesn't support it to produce a diagnostic
-than generate incorrect code.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-
-@end ifset
-@ifset familyVXT
-@node IMax0 Intrinsic
-@subsubsection IMax0 Intrinsic
-@cindex IMax0 intrinsic
-@cindex intrinsics, IMax0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IMax0} to use this name for an
-external procedure.
-
-@node IMax1 Intrinsic
-@subsubsection IMax1 Intrinsic
-@cindex IMax1 intrinsic
-@cindex intrinsics, IMax1
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IMax1} to use this name for an
-external procedure.
-
-@node IMin0 Intrinsic
-@subsubsection IMin0 Intrinsic
-@cindex IMin0 intrinsic
-@cindex intrinsics, IMin0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IMin0} to use this name for an
-external procedure.
-
-@node IMin1 Intrinsic
-@subsubsection IMin1 Intrinsic
-@cindex IMin1 intrinsic
-@cindex intrinsics, IMin1
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IMin1} to use this name for an
-external procedure.
-
-@node IMod Intrinsic
-@subsubsection IMod Intrinsic
-@cindex IMod intrinsic
-@cindex intrinsics, IMod
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IMod} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node Index Intrinsic
-@subsubsection Index Intrinsic
-@cindex Index intrinsic
-@cindex intrinsics, Index
-
-@noindent
-@example
-Index(@var{String}, @var{Substring})
-@end example
-
-@noindent
-Index: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{String}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Substring}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the position of the start of the first occurrence of string
-@var{Substring} as a substring in @var{String}, counting from one.
-If @var{Substring} doesn't occur in @var{String}, zero is returned.
-
-@end ifset
-@ifset familyVXT
-@node INInt Intrinsic
-@subsubsection INInt Intrinsic
-@cindex INInt intrinsic
-@cindex intrinsics, INInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL INInt} to use this name for an
-external procedure.
-
-@node INot Intrinsic
-@subsubsection INot Intrinsic
-@cindex INot intrinsic
-@cindex intrinsics, INot
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL INot} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node Int Intrinsic
-@subsubsection Int Intrinsic
-@cindex Int intrinsic
-@cindex intrinsics, Int
-
-@noindent
-@example
-Int(@var{A})
-@end example
-
-@noindent
-Int: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @var{A} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=1)}.
-
-If @var{A} is type @code{COMPLEX}, its real part is
-truncated and converted, and its imaginary part is disregarded.
-
-@xref{NInt Intrinsic}, for how to convert, rounded to nearest
-whole number.
-
-@xref{AInt Intrinsic}, for how to truncate to whole number
-without converting.
-
-@end ifset
-@ifset familyGNU
-@node Int2 Intrinsic
-@subsubsection Int2 Intrinsic
-@cindex Int2 intrinsic
-@cindex intrinsics, Int2
-
-@noindent
-@example
-Int2(@var{A})
-@end example
-
-@noindent
-Int2: @code{INTEGER(KIND=6)} function.
-
-@noindent
-@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{gnu}.
-
-@noindent
-Description:
-
-Returns @var{A} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=6)}.
-
-If @var{A} is type @code{COMPLEX}, its real part
-is truncated and converted, and its imaginary part is disregarded.
-
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-
-@node Int8 Intrinsic
-@subsubsection Int8 Intrinsic
-@cindex Int8 intrinsic
-@cindex intrinsics, Int8
-
-@noindent
-@example
-Int8(@var{A})
-@end example
-
-@noindent
-Int8: @code{INTEGER(KIND=2)} function.
-
-@noindent
-@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{gnu}.
-
-@noindent
-Description:
-
-Returns @var{A} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=2)}.
-
-If @var{A} is type @code{COMPLEX}, its real part
-is truncated and converted, and its imaginary part is disregarded.
-
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-
-@end ifset
-@ifset familyMIL
-@node IOr Intrinsic
-@subsubsection IOr Intrinsic
-@cindex IOr intrinsic
-@cindex intrinsics, IOr
-
-@noindent
-@example
-IOr(@var{I}, @var{J})
-@end example
-
-@noindent
-IOr: @code{INTEGER} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{J}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Returns value resulting from boolean OR of
-pair of bits in each of @var{I} and @var{J}.
-
-@end ifset
-@ifset familyF2U
-@node IRand Intrinsic
-@subsubsection IRand Intrinsic
-@cindex IRand intrinsic
-@cindex intrinsics, IRand
-
-@noindent
-@example
-IRand(@var{Flag})
-@end example
-
-@noindent
-IRand: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Flag}: @code{INTEGER}; OPTIONAL; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns a uniform quasi-random number up to a system-dependent limit.
-If @var{Flag} is 0, the next number in sequence is returned; if
-@var{Flag} is 1, the generator is restarted by calling the UNIX function
-@samp{srand(0)}; if @var{Flag} has any other value,
-it is used as a new seed with @code{srand()}.
-
-@xref{SRand Intrinsic}.
-
-@emph{Note:} As typically implemented (by the routine of the same
-name in the C library), this random number generator is a very poor
-one, though the BSD and GNU libraries provide a much better
-implementation than the `traditional' one.
-On a different system you almost certainly want to use something better.
-
-@node IsaTty Intrinsic
-@subsubsection IsaTty Intrinsic
-@cindex IsaTty intrinsic
-@cindex intrinsics, IsaTty
-
-@noindent
-@example
-IsaTty(@var{Unit})
-@end example
-
-@noindent
-IsaTty: @code{LOGICAL(KIND=1)} function.
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns @code{.TRUE.} if and only if the Fortran I/O unit
-specified by @var{Unit} is connected
-to a terminal device.
-See @code{isatty(3)}.
-
-@end ifset
-@ifset familyMIL
-@node IShft Intrinsic
-@subsubsection IShft Intrinsic
-@cindex IShft intrinsic
-@cindex intrinsics, IShft
-
-@noindent
-@example
-IShft(@var{I}, @var{Shift})
-@end example
-
-@noindent
-IShft: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Shift}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-All bits representing @var{I} are shifted @var{Shift} places.
-@samp{@var{Shift}.GT.0} indicates a left shift, @samp{@var{Shift}.EQ.0}
-indicates no shift and @samp{@var{Shift}.LT.0} indicates a right shift.
-If the absolute value of the shift count is greater than
-@samp{BIT_SIZE(@var{I})}, the result is undefined.
-Bits shifted out from the left end or the right end are lost.
-Zeros are shifted in from the opposite end.
-
-@xref{IShftC Intrinsic}, for the circular-shift equivalent.
-
-@node IShftC Intrinsic
-@subsubsection IShftC Intrinsic
-@cindex IShftC intrinsic
-@cindex intrinsics, IShftC
-
-@noindent
-@example
-IShftC(@var{I}, @var{Shift}, @var{Size})
-@end example
-
-@noindent
-IShftC: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Shift}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Size}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-The rightmost @var{Size} bits of the argument @var{I}
-are shifted circularly @var{Shift}
-places, i.e.@: the bits shifted out of one end are shifted into
-the opposite end.
-No bits are lost.
-The unshifted bits of the result are the same as
-the unshifted bits of @var{I}.
-The absolute value of the argument @var{Shift}
-must be less than or equal to @var{Size}.
-The value of @var{Size} must be greater than or equal to one and less than
-or equal to @samp{BIT_SIZE(@var{I})}.
-
-@xref{IShft Intrinsic}, for the logical shift equivalent.
-
-@end ifset
-@ifset familyF77
-@node ISign Intrinsic
-@subsubsection ISign Intrinsic
-@cindex ISign intrinsic
-@cindex intrinsics, ISign
-
-@noindent
-@example
-ISign(@var{A}, @var{B})
-@end example
-
-@noindent
-ISign: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-@var{B}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{SIGN()} that is specific
-to one type for @var{A} and @var{B}.
-@xref{Sign Intrinsic}.
-
-@end ifset
-@ifset familyF2U
-@node ITime Intrinsic
-@subsubsection ITime Intrinsic
-@cindex ITime intrinsic
-@cindex intrinsics, ITime
-
-@noindent
-@example
-CALL ITime(@var{TArray})
-@end example
-
-@noindent
-@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(3); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the current local time hour, minutes, and seconds in elements
-1, 2, and 3 of @var{TArray}, respectively.
-
-@end ifset
-@ifset familyVXT
-@node IZExt Intrinsic
-@subsubsection IZExt Intrinsic
-@cindex IZExt intrinsic
-@cindex intrinsics, IZExt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL IZExt} to use this name for an
-external procedure.
-
-@node JIAbs Intrinsic
-@subsubsection JIAbs Intrinsic
-@cindex JIAbs intrinsic
-@cindex intrinsics, JIAbs
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIAbs} to use this name for an
-external procedure.
-
-@node JIAnd Intrinsic
-@subsubsection JIAnd Intrinsic
-@cindex JIAnd intrinsic
-@cindex intrinsics, JIAnd
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIAnd} to use this name for an
-external procedure.
-
-@node JIBClr Intrinsic
-@subsubsection JIBClr Intrinsic
-@cindex JIBClr intrinsic
-@cindex intrinsics, JIBClr
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIBClr} to use this name for an
-external procedure.
-
-@node JIBits Intrinsic
-@subsubsection JIBits Intrinsic
-@cindex JIBits intrinsic
-@cindex intrinsics, JIBits
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIBits} to use this name for an
-external procedure.
-
-@node JIBSet Intrinsic
-@subsubsection JIBSet Intrinsic
-@cindex JIBSet intrinsic
-@cindex intrinsics, JIBSet
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIBSet} to use this name for an
-external procedure.
-
-@node JIDiM Intrinsic
-@subsubsection JIDiM Intrinsic
-@cindex JIDiM intrinsic
-@cindex intrinsics, JIDiM
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIDiM} to use this name for an
-external procedure.
-
-@node JIDInt Intrinsic
-@subsubsection JIDInt Intrinsic
-@cindex JIDInt intrinsic
-@cindex intrinsics, JIDInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIDInt} to use this name for an
-external procedure.
-
-@node JIDNnt Intrinsic
-@subsubsection JIDNnt Intrinsic
-@cindex JIDNnt intrinsic
-@cindex intrinsics, JIDNnt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIDNnt} to use this name for an
-external procedure.
-
-@node JIEOr Intrinsic
-@subsubsection JIEOr Intrinsic
-@cindex JIEOr intrinsic
-@cindex intrinsics, JIEOr
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIEOr} to use this name for an
-external procedure.
-
-@node JIFix Intrinsic
-@subsubsection JIFix Intrinsic
-@cindex JIFix intrinsic
-@cindex intrinsics, JIFix
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIFix} to use this name for an
-external procedure.
-
-@node JInt Intrinsic
-@subsubsection JInt Intrinsic
-@cindex JInt intrinsic
-@cindex intrinsics, JInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JInt} to use this name for an
-external procedure.
-
-@node JIOr Intrinsic
-@subsubsection JIOr Intrinsic
-@cindex JIOr intrinsic
-@cindex intrinsics, JIOr
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIOr} to use this name for an
-external procedure.
-
-@node JIQint Intrinsic
-@subsubsection JIQint Intrinsic
-@cindex JIQint intrinsic
-@cindex intrinsics, JIQint
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIQint} to use this name for an
-external procedure.
-
-@node JIQNnt Intrinsic
-@subsubsection JIQNnt Intrinsic
-@cindex JIQNnt intrinsic
-@cindex intrinsics, JIQNnt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIQNnt} to use this name for an
-external procedure.
-
-@node JIShft Intrinsic
-@subsubsection JIShft Intrinsic
-@cindex JIShft intrinsic
-@cindex intrinsics, JIShft
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIShft} to use this name for an
-external procedure.
-
-@node JIShftC Intrinsic
-@subsubsection JIShftC Intrinsic
-@cindex JIShftC intrinsic
-@cindex intrinsics, JIShftC
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JIShftC} to use this name for an
-external procedure.
-
-@node JISign Intrinsic
-@subsubsection JISign Intrinsic
-@cindex JISign intrinsic
-@cindex intrinsics, JISign
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JISign} to use this name for an
-external procedure.
-
-@node JMax0 Intrinsic
-@subsubsection JMax0 Intrinsic
-@cindex JMax0 intrinsic
-@cindex intrinsics, JMax0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JMax0} to use this name for an
-external procedure.
-
-@node JMax1 Intrinsic
-@subsubsection JMax1 Intrinsic
-@cindex JMax1 intrinsic
-@cindex intrinsics, JMax1
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JMax1} to use this name for an
-external procedure.
-
-@node JMin0 Intrinsic
-@subsubsection JMin0 Intrinsic
-@cindex JMin0 intrinsic
-@cindex intrinsics, JMin0
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JMin0} to use this name for an
-external procedure.
-
-@node JMin1 Intrinsic
-@subsubsection JMin1 Intrinsic
-@cindex JMin1 intrinsic
-@cindex intrinsics, JMin1
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JMin1} to use this name for an
-external procedure.
-
-@node JMod Intrinsic
-@subsubsection JMod Intrinsic
-@cindex JMod intrinsic
-@cindex intrinsics, JMod
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JMod} to use this name for an
-external procedure.
-
-@node JNInt Intrinsic
-@subsubsection JNInt Intrinsic
-@cindex JNInt intrinsic
-@cindex intrinsics, JNInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JNInt} to use this name for an
-external procedure.
-
-@node JNot Intrinsic
-@subsubsection JNot Intrinsic
-@cindex JNot intrinsic
-@cindex intrinsics, JNot
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JNot} to use this name for an
-external procedure.
-
-@node JZExt Intrinsic
-@subsubsection JZExt Intrinsic
-@cindex JZExt intrinsic
-@cindex intrinsics, JZExt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL JZExt} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node Kill Intrinsic (subroutine)
-@subsubsection Kill Intrinsic (subroutine)
-@cindex Kill intrinsic
-@cindex intrinsics, Kill
-
-@noindent
-@example
-CALL Kill(@var{Pid}, @var{Signal}, @var{Status})
-@end example
-
-@noindent
-@var{Pid}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Signal}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Sends the signal specified by @var{Signal} to the process @var{Pid}.
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-See @code{kill(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{Kill Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node Kill Intrinsic (function)
-@subsubsection Kill Intrinsic (function)
-@cindex Kill intrinsic
-@cindex intrinsics, Kill
-
-@noindent
-@example
-Kill(@var{Pid}, @var{Signal})
-@end example
-
-@noindent
-Kill: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Pid}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Signal}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Sends the signal specified by @var{Signal} to the process @var{Pid}.
-Returns 0 on success or a nonzero error code.
-See @code{kill(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{Kill Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node Kind Intrinsic
-@subsubsection Kind Intrinsic
-@cindex Kind intrinsic
-@cindex intrinsics, Kind
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Kind} to use this name for an
-external procedure.
-
-@node LBound Intrinsic
-@subsubsection LBound Intrinsic
-@cindex LBound intrinsic
-@cindex intrinsics, LBound
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL LBound} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node Len Intrinsic
-@subsubsection Len Intrinsic
-@cindex Len intrinsic
-@cindex intrinsics, Len
-
-@noindent
-@example
-Len(@var{String})
-@end example
-
-@noindent
-Len: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{String}: @code{CHARACTER}; scalar.
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the length of @var{String}.
-
-If @var{String} is an array, the length of an element
-of @var{String} is returned.
-
-Note that @var{String} need not be defined when this
-intrinsic is invoked, since only the length, not
-the content, of @var{String} is needed.
-
-@xref{Bit_Size Intrinsic}, for the function that determines
-the size of its argument in bits.
-
-@end ifset
-@ifset familyF90
-@node Len_Trim Intrinsic
-@subsubsection Len_Trim Intrinsic
-@cindex Len_Trim intrinsic
-@cindex intrinsics, Len_Trim
-
-@noindent
-@example
-Len_Trim(@var{String})
-@end example
-
-@noindent
-Len_Trim: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{String}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f90}.
-
-@noindent
-Description:
-
-Returns the index of the last non-blank character in @var{String}.
-@code{LNBLNK} and @code{LEN_TRIM} are equivalent.
-
-@end ifset
-@ifset familyF77
-@node LGe Intrinsic
-@subsubsection LGe Intrinsic
-@cindex LGe intrinsic
-@cindex intrinsics, LGe
-
-@noindent
-@example
-LGe(@var{String_A}, @var{String_B})
-@end example
-
-@noindent
-LGe: @code{LOGICAL(KIND=1)} function.
-
-@noindent
-@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{.TRUE.} if @samp{@var{String_A}.GE.@var{String_B}},
-@samp{.FALSE.} otherwise.
-@var{String_A} and @var{String_B} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{String_A} and @var{String_B} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-The lexical comparison intrinsics @code{LGe}, @code{LGt},
-@code{LLe}, and @code{LLt} differ from the corresponding
-intrinsic operators @code{.GE.}, @code{.GT.},
-@code{.LE.}, @code{.LT.}.
-Because the ASCII collating sequence is assumed,
-the following expressions always return @samp{.TRUE.}:
-
-@smallexample
-LGE ('0', ' ')
-LGE ('A', '0')
-LGE ('a', 'A')
-@end smallexample
-
-The following related expressions do @emph{not} always
-return @samp{.TRUE.}, as they are not necessarily evaluated
-assuming the arguments use ASCII encoding:
-
-@smallexample
-'0' .GE. ' '
-'A' .GE. '0'
-'a' .GE. 'A'
-@end smallexample
-
-The same difference exists
-between @code{LGt} and @code{.GT.};
-between @code{LLe} and @code{.LE.}; and
-between @code{LLt} and @code{.LT.}.
-
-@node LGt Intrinsic
-@subsubsection LGt Intrinsic
-@cindex LGt intrinsic
-@cindex intrinsics, LGt
-
-@noindent
-@example
-LGt(@var{String_A}, @var{String_B})
-@end example
-
-@noindent
-LGt: @code{LOGICAL(KIND=1)} function.
-
-@noindent
-@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{.TRUE.} if @samp{@var{String_A}.GT.@var{String_B}},
-@samp{.FALSE.} otherwise.
-@var{String_A} and @var{String_B} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{String_A} and @var{String_B} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-@xref{LGe Intrinsic}, for information on the distinction
-between the @code{LGT} intrinsic and the @code{.GT.}
-operator.
-
-@end ifset
-@ifset familyF2U
-@node Link Intrinsic (subroutine)
-@subsubsection Link Intrinsic (subroutine)
-@cindex Link intrinsic
-@cindex intrinsics, Link
-
-@noindent
-@example
-CALL Link(@var{Path1}, @var{Path2}, @var{Status})
-@end example
-
-@noindent
-@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Makes a (hard) link from file @var{Path1} to @var{Path2}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{Path1} and @var{Path2}---otherwise,
-trailing blanks in @var{Path1} and @var{Path2} are ignored.
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-See @code{link(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{Link Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node Link Intrinsic (function)
-@subsubsection Link Intrinsic (function)
-@cindex Link intrinsic
-@cindex intrinsics, Link
-
-@noindent
-@example
-Link(@var{Path1}, @var{Path2})
-@end example
-
-@noindent
-Link: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Makes a (hard) link from file @var{Path1} to @var{Path2}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{Path1} and @var{Path2}---otherwise,
-trailing blanks in @var{Path1} and @var{Path2} are ignored.
-Returns 0 on success or a nonzero error code.
-See @code{link(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{Link Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF77
-@node LLe Intrinsic
-@subsubsection LLe Intrinsic
-@cindex LLe intrinsic
-@cindex intrinsics, LLe
-
-@noindent
-@example
-LLe(@var{String_A}, @var{String_B})
-@end example
-
-@noindent
-LLe: @code{LOGICAL(KIND=1)} function.
-
-@noindent
-@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{.TRUE.} if @samp{@var{String_A}.LE.@var{String_B}},
-@samp{.FALSE.} otherwise.
-@var{String_A} and @var{String_B} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{String_A} and @var{String_B} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-@xref{LGe Intrinsic}, for information on the distinction
-between the @code{LLE} intrinsic and the @code{.LE.}
-operator.
-
-@node LLt Intrinsic
-@subsubsection LLt Intrinsic
-@cindex LLt intrinsic
-@cindex intrinsics, LLt
-
-@noindent
-@example
-LLt(@var{String_A}, @var{String_B})
-@end example
-
-@noindent
-LLt: @code{LOGICAL(KIND=1)} function.
-
-@noindent
-@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{.TRUE.} if @samp{@var{String_A}.LT.@var{String_B}},
-@samp{.FALSE.} otherwise.
-@var{String_A} and @var{String_B} are interpreted as containing
-ASCII character codes.
-If either value contains a character not in the ASCII
-character set, the result is processor dependent.
-
-If the @var{String_A} and @var{String_B} are not the same length,
-the shorter is compared as if spaces were appended to
-it to form a value that has the same length as the longer.
-
-@xref{LGe Intrinsic}, for information on the distinction
-between the @code{LLT} intrinsic and the @code{.LT.}
-operator.
-
-@end ifset
-@ifset familyF2U
-@node LnBlnk Intrinsic
-@subsubsection LnBlnk Intrinsic
-@cindex LnBlnk intrinsic
-@cindex intrinsics, LnBlnk
-
-@noindent
-@example
-LnBlnk(@var{String})
-@end example
-
-@noindent
-LnBlnk: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{String}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the index of the last non-blank character in @var{String}.
-@code{LNBLNK} and @code{LEN_TRIM} are equivalent.
-
-@node Loc Intrinsic
-@subsubsection Loc Intrinsic
-@cindex Loc intrinsic
-@cindex intrinsics, Loc
-
-@noindent
-@example
-Loc(@var{Entity})
-@end example
-
-@noindent
-Loc: @code{INTEGER(KIND=7)} function.
-
-@noindent
-@var{Entity}: Any type; cannot be a constant or expression.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-The @code{LOC()} intrinsic works the
-same way as the @code{%LOC()} construct.
-@xref{%LOC(),,The @code{%LOC()} Construct}, for
-more information.
-
-@end ifset
-@ifset familyF77
-@node Log Intrinsic
-@subsubsection Log Intrinsic
-@cindex Log intrinsic
-@cindex intrinsics, Log
-
-@noindent
-@example
-Log(@var{X})
-@end example
-
-@noindent
-Log: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the natural logarithm of @var{X}, which must
-be greater than zero or, if type @code{COMPLEX}, must not
-be zero.
-
-@xref{Exp Intrinsic}, for the inverse of this function.
-
-@xref{Log10 Intrinsic}, for the `common' (base-10) logarithm function.
-
-@node Log10 Intrinsic
-@subsubsection Log10 Intrinsic
-@cindex Log10 intrinsic
-@cindex intrinsics, Log10
-
-@noindent
-@example
-Log10(@var{X})
-@end example
-
-@noindent
-Log10: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the common logarithm (base 10) of @var{X}, which must
-be greater than zero.
-
-The inverse of this function is @samp{10. ** LOG10(@var{X})}.
-
-@xref{Log Intrinsic}, for the natural logarithm function.
-
-@end ifset
-@ifset familyF90
-@node Logical Intrinsic
-@subsubsection Logical Intrinsic
-@cindex Logical intrinsic
-@cindex intrinsics, Logical
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Logical} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node Long Intrinsic
-@subsubsection Long Intrinsic
-@cindex Long intrinsic
-@cindex intrinsics, Long
-
-@noindent
-@example
-Long(@var{A})
-@end example
-
-@noindent
-Long: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER(KIND=6)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Archaic form of @code{INT()} that is specific
-to one type for @var{A}.
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-
-@end ifset
-@ifset familyF2C
-@node LShift Intrinsic
-@subsubsection LShift Intrinsic
-@cindex LShift intrinsic
-@cindex intrinsics, LShift
-
-@noindent
-@example
-LShift(@var{I}, @var{Shift})
-@end example
-
-@noindent
-LShift: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Shift}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Returns @var{I} shifted to the left
-@var{Shift} bits.
-
-Although similar to the expression
-@samp{@var{I}*(2**@var{Shift})}, there
-are important differences.
-For example, the sign of the result is
-not necessarily the same as the sign of
-@var{I}.
-
-Currently this intrinsic is defined assuming
-the underlying representation of @var{I}
-is as a two's-complement integer.
-It is unclear at this point whether that
-definition will apply when a different
-representation is involved.
-
-@xref{LShift Intrinsic}, for the inverse of this function.
-
-@xref{IShft Intrinsic}, for information
-on a more widely available left-shifting
-intrinsic that is also more precisely defined.
-
-@end ifset
-@ifset familyF2U
-@node LStat Intrinsic (subroutine)
-@subsubsection LStat Intrinsic (subroutine)
-@cindex LStat intrinsic
-@cindex intrinsics, LStat
-
-@noindent
-@example
-CALL LStat(@var{File}, @var{SArray}, @var{Status})
-@end example
-
-@noindent
-@var{File}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Obtains data about the given file @var{File} and places them in the array
-@var{SArray}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{File}---otherwise,
-trailing blanks in @var{File} are ignored.
-If @var{File} is a symbolic link it returns data on the
-link itself, so the routine is available only on systems that support
-symbolic links.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{lstat(2)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{LStat Intrinsic (function)}.
-
-@node LStat Intrinsic (function)
-@subsubsection LStat Intrinsic (function)
-@cindex LStat intrinsic
-@cindex intrinsics, LStat
-
-@noindent
-@example
-LStat(@var{File}, @var{SArray})
-@end example
-
-@noindent
-LStat: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{File}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Obtains data about the given file @var{File} and places them in the array
-@var{SArray}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{File}---otherwise,
-trailing blanks in @var{File} are ignored.
-If @var{File} is a symbolic link it returns data on the
-link itself, so the routine is available only on systems that support
-symbolic links.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-Returns 0 on success or a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{lstat(2)}).
-
-For information on other intrinsics with the same name:
-@xref{LStat Intrinsic (subroutine)}.
-
-@node LTime Intrinsic
-@subsubsection LTime Intrinsic
-@cindex LTime intrinsic
-@cindex intrinsics, LTime
-
-@noindent
-@example
-CALL LTime(@var{STime}, @var{TArray})
-@end example
-
-@noindent
-@var{STime}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(9); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Given a system time value @var{STime}, fills @var{TArray} with values
-extracted from it appropriate to the GMT time zone using
-@code{localtime(3)}.
-
-The array elements are as follows:
-
-@enumerate
-@item
-Seconds after the minute, range 0--59 or 0--61 to allow for leap
-seconds
-
-@item
-Minutes after the hour, range 0--59
-
-@item
-Hours past midnight, range 0--23
-
-@item
-Day of month, range 0--31
-
-@item
-Number of months since January, range 0--12
-
-@item
-Years since 1900
-
-@item
-Number of days since Sunday, range 0--6
-
-@item
-Days since January 1
-
-@item
-Daylight savings indicator: positive if daylight savings is in effect,
-zero if not, and negative if the information isn't available.
-@end enumerate
-
-@end ifset
-@ifset familyF90
-@node MatMul Intrinsic
-@subsubsection MatMul Intrinsic
-@cindex MatMul intrinsic
-@cindex intrinsics, MatMul
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL MatMul} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node Max Intrinsic
-@subsubsection Max Intrinsic
-@cindex Max intrinsic
-@cindex intrinsics, Max
-
-@noindent
-@example
-Max(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-Max: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{A}: @code{INTEGER} or @code{REAL}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the argument with the largest value.
-
-@xref{Min Intrinsic}, for the opposite function.
-
-@node Max0 Intrinsic
-@subsubsection Max0 Intrinsic
-@cindex Max0 intrinsic
-@cindex intrinsics, Max0
-
-@noindent
-@example
-Max0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-Max0: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MAX()} that is specific
-to one type for @var{A}.
-@xref{Max Intrinsic}.
-
-@node Max1 Intrinsic
-@subsubsection Max1 Intrinsic
-@cindex Max1 intrinsic
-@cindex intrinsics, Max1
-
-@noindent
-@example
-Max1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-Max1: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MAX()} that is specific
-to one type for @var{A} and a different return type.
-@xref{Max Intrinsic}.
-
-@end ifset
-@ifset familyF90
-@node MaxExponent Intrinsic
-@subsubsection MaxExponent Intrinsic
-@cindex MaxExponent intrinsic
-@cindex intrinsics, MaxExponent
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL MaxExponent} to use this name for an
-external procedure.
-
-@node MaxLoc Intrinsic
-@subsubsection MaxLoc Intrinsic
-@cindex MaxLoc intrinsic
-@cindex intrinsics, MaxLoc
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL MaxLoc} to use this name for an
-external procedure.
-
-@node MaxVal Intrinsic
-@subsubsection MaxVal Intrinsic
-@cindex MaxVal intrinsic
-@cindex intrinsics, MaxVal
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL MaxVal} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node MClock Intrinsic
-@subsubsection MClock Intrinsic
-@cindex MClock intrinsic
-@cindex intrinsics, MClock
-
-@noindent
-@example
-MClock()
-@end example
-
-@noindent
-MClock: @code{INTEGER(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the number of clock ticks since the start of the process.
-Supported on systems with @code{clock(3)} (q.v.).
-
-@cindex wraparound, timings
-@cindex limits, timings
-This intrinsic is not fully portable, such as to systems
-with 32-bit @code{INTEGER} types but supporting times
-wider than 32 bits.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-@xref{MClock8 Intrinsic}, for information on a
-similar intrinsic that might be portable to more
-GNU Fortran implementations, though to fewer
-Fortran compilers.
-
-If the system does not support @code{clock(3)},
--1 is returned.
-
-@node MClock8 Intrinsic
-@subsubsection MClock8 Intrinsic
-@cindex MClock8 intrinsic
-@cindex intrinsics, MClock8
-
-@noindent
-@example
-MClock8()
-@end example
-
-@noindent
-MClock8: @code{INTEGER(KIND=2)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the number of clock ticks since the start of the process.
-Supported on systems with @code{clock(3)} (q.v.).
-
-@cindex wraparound, timings
-@cindex limits, timings
-@emph{Warning:} this intrinsic does not increase the range
-of the timing values over that returned by @code{clock(3)}.
-On a system with a 32-bit @code{clock(3)},
-@code{MCLOCK8} will return a 32-bit value,
-even though converted to an @samp{INTEGER(KIND=2)} value.
-That means overflows of the 32-bit value can still occur.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-No Fortran implementations other than GNU Fortran are
-known to support this intrinsic at the time of this
-writing.
-@xref{MClock Intrinsic}, for information on a
-similar intrinsic that might be portable to more Fortran
-compilers, though to fewer GNU Fortran implementations.
-
-If the system does not support @code{clock(3)},
--1 is returned.
-
-@end ifset
-@ifset familyF90
-@node Merge Intrinsic
-@subsubsection Merge Intrinsic
-@cindex Merge intrinsic
-@cindex intrinsics, Merge
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Merge} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node Min Intrinsic
-@subsubsection Min Intrinsic
-@cindex Min intrinsic
-@cindex intrinsics, Min
-
-@noindent
-@example
-Min(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-Min: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{A}: @code{INTEGER} or @code{REAL}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the argument with the smallest value.
-
-@xref{Max Intrinsic}, for the opposite function.
-
-@node Min0 Intrinsic
-@subsubsection Min0 Intrinsic
-@cindex Min0 intrinsic
-@cindex intrinsics, Min0
-
-@noindent
-@example
-Min0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-Min0: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MIN()} that is specific
-to one type for @var{A}.
-@xref{Min Intrinsic}.
-
-@node Min1 Intrinsic
-@subsubsection Min1 Intrinsic
-@cindex Min1 intrinsic
-@cindex intrinsics, Min1
-
-@noindent
-@example
-Min1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n)
-@end example
-
-@noindent
-Min1: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{MIN()} that is specific
-to one type for @var{A} and a different return type.
-@xref{Min Intrinsic}.
-
-@end ifset
-@ifset familyF90
-@node MinExponent Intrinsic
-@subsubsection MinExponent Intrinsic
-@cindex MinExponent intrinsic
-@cindex intrinsics, MinExponent
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL MinExponent} to use this name for an
-external procedure.
-
-@node MinLoc Intrinsic
-@subsubsection MinLoc Intrinsic
-@cindex MinLoc intrinsic
-@cindex intrinsics, MinLoc
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL MinLoc} to use this name for an
-external procedure.
-
-@node MinVal Intrinsic
-@subsubsection MinVal Intrinsic
-@cindex MinVal intrinsic
-@cindex intrinsics, MinVal
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL MinVal} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node Mod Intrinsic
-@subsubsection Mod Intrinsic
-@cindex Mod intrinsic
-@cindex intrinsics, Mod
-
-@noindent
-@example
-Mod(@var{A}, @var{P})
-@end example
-
-@noindent
-Mod: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{A}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-@var{P}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns remainder calculated as:
-
-@smallexample
-@var{A} - (INT(@var{A} / @var{P}) * @var{P})
-@end smallexample
-
-@var{P} must not be zero.
-
-@end ifset
-@ifset familyF90
-@node Modulo Intrinsic
-@subsubsection Modulo Intrinsic
-@cindex Modulo intrinsic
-@cindex intrinsics, Modulo
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Modulo} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyMIL
-@node MvBits Intrinsic
-@subsubsection MvBits Intrinsic
-@cindex MvBits intrinsic
-@cindex intrinsics, MvBits
-
-@noindent
-@example
-CALL MvBits(@var{From}, @var{FromPos}, @var{Len}, @var{TO}, @var{ToPos})
-@end example
-
-@noindent
-@var{From}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{FromPos}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Len}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{TO}: @code{INTEGER} with same @samp{KIND=} value as for @var{From}; scalar; INTENT(INOUT).
-
-@noindent
-@var{ToPos}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Moves @var{Len} bits from positions @var{FromPos} through
-@samp{@var{FromPos}+@var{Len}-1} of @var{From} to positions @var{ToPos} through
-@samp{@var{FromPos}+@var{Len}-1} of @var{TO}. The portion of argument
-@var{TO} not affected by the movement of bits is unchanged. Arguments
-@var{From} and @var{TO} are permitted to be the same numeric storage
-unit. The values of @samp{@var{FromPos}+@var{Len}} and
-@samp{@var{ToPos}+@var{Len}} must be less than or equal to
-@samp{BIT_SIZE(@var{From})}.
-
-@end ifset
-@ifset familyF90
-@node Nearest Intrinsic
-@subsubsection Nearest Intrinsic
-@cindex Nearest intrinsic
-@cindex intrinsics, Nearest
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Nearest} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node NInt Intrinsic
-@subsubsection NInt Intrinsic
-@cindex NInt intrinsic
-@cindex intrinsics, NInt
-
-@noindent
-@example
-NInt(@var{A})
-@end example
-
-@noindent
-NInt: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @var{A} with the fractional portion of its
-magnitude eliminated by rounding to the nearest whole
-number and with its sign preserved, converted
-to type @code{INTEGER(KIND=1)}.
-
-If @var{A} is type @code{COMPLEX}, its real part is
-rounded and converted.
-
-A fractional portion exactly equal to
-@samp{.5} is rounded to the whole number that
-is larger in magnitude.
-(Also called ``Fortran round''.)
-
-@xref{Int Intrinsic}, for how to convert, truncate to
-whole number.
-
-@xref{ANInt Intrinsic}, for how to round to nearest whole number
-without converting.
-
-@end ifset
-@ifset familyMIL
-@node Not Intrinsic
-@subsubsection Not Intrinsic
-@cindex Not intrinsic
-@cindex intrinsics, Not
-
-@noindent
-@example
-Not(@var{I})
-@end example
-
-@noindent
-Not: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}.
-
-@noindent
-Description:
-
-Returns value resulting from boolean NOT of each bit
-in @var{I}.
-
-@end ifset
-@ifset familyF2C
-@node Or Intrinsic
-@subsubsection Or Intrinsic
-@cindex Or intrinsic
-@cindex intrinsics, Or
-
-@noindent
-@example
-Or(@var{I}, @var{J})
-@end example
-
-@noindent
-Or: @code{INTEGER} or @code{LOGICAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{I}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN).
-
-@noindent
-@var{J}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Returns value resulting from boolean OR of
-pair of bits in each of @var{I} and @var{J}.
-
-@end ifset
-@ifset familyF90
-@node Pack Intrinsic
-@subsubsection Pack Intrinsic
-@cindex Pack intrinsic
-@cindex intrinsics, Pack
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Pack} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node PError Intrinsic
-@subsubsection PError Intrinsic
-@cindex PError intrinsic
-@cindex intrinsics, PError
-
-@noindent
-@example
-CALL PError(@var{String})
-@end example
-
-@noindent
-@var{String}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Prints (on the C @code{stderr} stream) a newline-terminated error
-message corresponding to the last system error.
-This is prefixed by @var{String}, a colon and a space.
-See @code{perror(3)}.
-
-@end ifset
-@ifset familyF90
-@node Precision Intrinsic
-@subsubsection Precision Intrinsic
-@cindex Precision intrinsic
-@cindex intrinsics, Precision
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Precision} to use this name for an
-external procedure.
-
-@node Present Intrinsic
-@subsubsection Present Intrinsic
-@cindex Present intrinsic
-@cindex intrinsics, Present
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Present} to use this name for an
-external procedure.
-
-@node Product Intrinsic
-@subsubsection Product Intrinsic
-@cindex Product intrinsic
-@cindex intrinsics, Product
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Product} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyVXT
-@node QAbs Intrinsic
-@subsubsection QAbs Intrinsic
-@cindex QAbs intrinsic
-@cindex intrinsics, QAbs
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QAbs} to use this name for an
-external procedure.
-
-@node QACos Intrinsic
-@subsubsection QACos Intrinsic
-@cindex QACos intrinsic
-@cindex intrinsics, QACos
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QACos} to use this name for an
-external procedure.
-
-@node QACosD Intrinsic
-@subsubsection QACosD Intrinsic
-@cindex QACosD intrinsic
-@cindex intrinsics, QACosD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QACosD} to use this name for an
-external procedure.
-
-@node QASin Intrinsic
-@subsubsection QASin Intrinsic
-@cindex QASin intrinsic
-@cindex intrinsics, QASin
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QASin} to use this name for an
-external procedure.
-
-@node QASinD Intrinsic
-@subsubsection QASinD Intrinsic
-@cindex QASinD intrinsic
-@cindex intrinsics, QASinD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QASinD} to use this name for an
-external procedure.
-
-@node QATan Intrinsic
-@subsubsection QATan Intrinsic
-@cindex QATan intrinsic
-@cindex intrinsics, QATan
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QATan} to use this name for an
-external procedure.
-
-@node QATan2 Intrinsic
-@subsubsection QATan2 Intrinsic
-@cindex QATan2 intrinsic
-@cindex intrinsics, QATan2
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QATan2} to use this name for an
-external procedure.
-
-@node QATan2D Intrinsic
-@subsubsection QATan2D Intrinsic
-@cindex QATan2D intrinsic
-@cindex intrinsics, QATan2D
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QATan2D} to use this name for an
-external procedure.
-
-@node QATanD Intrinsic
-@subsubsection QATanD Intrinsic
-@cindex QATanD intrinsic
-@cindex intrinsics, QATanD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QATanD} to use this name for an
-external procedure.
-
-@node QCos Intrinsic
-@subsubsection QCos Intrinsic
-@cindex QCos intrinsic
-@cindex intrinsics, QCos
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QCos} to use this name for an
-external procedure.
-
-@node QCosD Intrinsic
-@subsubsection QCosD Intrinsic
-@cindex QCosD intrinsic
-@cindex intrinsics, QCosD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QCosD} to use this name for an
-external procedure.
-
-@node QCosH Intrinsic
-@subsubsection QCosH Intrinsic
-@cindex QCosH intrinsic
-@cindex intrinsics, QCosH
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QCosH} to use this name for an
-external procedure.
-
-@node QDiM Intrinsic
-@subsubsection QDiM Intrinsic
-@cindex QDiM intrinsic
-@cindex intrinsics, QDiM
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QDiM} to use this name for an
-external procedure.
-
-@node QExp Intrinsic
-@subsubsection QExp Intrinsic
-@cindex QExp intrinsic
-@cindex intrinsics, QExp
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QExp} to use this name for an
-external procedure.
-
-@node QExt Intrinsic
-@subsubsection QExt Intrinsic
-@cindex QExt intrinsic
-@cindex intrinsics, QExt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QExt} to use this name for an
-external procedure.
-
-@node QExtD Intrinsic
-@subsubsection QExtD Intrinsic
-@cindex QExtD intrinsic
-@cindex intrinsics, QExtD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QExtD} to use this name for an
-external procedure.
-
-@node QFloat Intrinsic
-@subsubsection QFloat Intrinsic
-@cindex QFloat intrinsic
-@cindex intrinsics, QFloat
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QFloat} to use this name for an
-external procedure.
-
-@node QInt Intrinsic
-@subsubsection QInt Intrinsic
-@cindex QInt intrinsic
-@cindex intrinsics, QInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QInt} to use this name for an
-external procedure.
-
-@node QLog Intrinsic
-@subsubsection QLog Intrinsic
-@cindex QLog intrinsic
-@cindex intrinsics, QLog
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QLog} to use this name for an
-external procedure.
-
-@node QLog10 Intrinsic
-@subsubsection QLog10 Intrinsic
-@cindex QLog10 intrinsic
-@cindex intrinsics, QLog10
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QLog10} to use this name for an
-external procedure.
-
-@node QMax1 Intrinsic
-@subsubsection QMax1 Intrinsic
-@cindex QMax1 intrinsic
-@cindex intrinsics, QMax1
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QMax1} to use this name for an
-external procedure.
-
-@node QMin1 Intrinsic
-@subsubsection QMin1 Intrinsic
-@cindex QMin1 intrinsic
-@cindex intrinsics, QMin1
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QMin1} to use this name for an
-external procedure.
-
-@node QMod Intrinsic
-@subsubsection QMod Intrinsic
-@cindex QMod intrinsic
-@cindex intrinsics, QMod
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QMod} to use this name for an
-external procedure.
-
-@node QNInt Intrinsic
-@subsubsection QNInt Intrinsic
-@cindex QNInt intrinsic
-@cindex intrinsics, QNInt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QNInt} to use this name for an
-external procedure.
-
-@node QSin Intrinsic
-@subsubsection QSin Intrinsic
-@cindex QSin intrinsic
-@cindex intrinsics, QSin
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QSin} to use this name for an
-external procedure.
-
-@node QSinD Intrinsic
-@subsubsection QSinD Intrinsic
-@cindex QSinD intrinsic
-@cindex intrinsics, QSinD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QSinD} to use this name for an
-external procedure.
-
-@node QSinH Intrinsic
-@subsubsection QSinH Intrinsic
-@cindex QSinH intrinsic
-@cindex intrinsics, QSinH
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QSinH} to use this name for an
-external procedure.
-
-@node QSqRt Intrinsic
-@subsubsection QSqRt Intrinsic
-@cindex QSqRt intrinsic
-@cindex intrinsics, QSqRt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QSqRt} to use this name for an
-external procedure.
-
-@node QTan Intrinsic
-@subsubsection QTan Intrinsic
-@cindex QTan intrinsic
-@cindex intrinsics, QTan
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QTan} to use this name for an
-external procedure.
-
-@node QTanD Intrinsic
-@subsubsection QTanD Intrinsic
-@cindex QTanD intrinsic
-@cindex intrinsics, QTanD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QTanD} to use this name for an
-external procedure.
-
-@node QTanH Intrinsic
-@subsubsection QTanH Intrinsic
-@cindex QTanH intrinsic
-@cindex intrinsics, QTanH
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL QTanH} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF90
-@node Radix Intrinsic
-@subsubsection Radix Intrinsic
-@cindex Radix intrinsic
-@cindex intrinsics, Radix
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Radix} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node Rand Intrinsic
-@subsubsection Rand Intrinsic
-@cindex Rand intrinsic
-@cindex intrinsics, Rand
-
-@noindent
-@example
-Rand(@var{Flag})
-@end example
-
-@noindent
-Rand: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{Flag}: @code{INTEGER}; OPTIONAL; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns a uniform quasi-random number between 0 and 1.
-If @var{Flag} is 0, the next number in sequence is returned; if
-@var{Flag} is 1, the generator is restarted by calling @samp{srand(0)};
-if @var{Flag} has any other value, it is used as a new seed with
-@code{srand}.
-
-@xref{SRand Intrinsic}.
-
-@emph{Note:} As typically implemented (by the routine of the same
-name in the C library), this random number generator is a very poor
-one, though the BSD and GNU libraries provide a much better
-implementation than the `traditional' one.
-On a different system you
-almost certainly want to use something better.
-
-@end ifset
-@ifset familyF90
-@node Random_Number Intrinsic
-@subsubsection Random_Number Intrinsic
-@cindex Random_Number intrinsic
-@cindex intrinsics, Random_Number
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Random_Number} to use this name for an
-external procedure.
-
-@node Random_Seed Intrinsic
-@subsubsection Random_Seed Intrinsic
-@cindex Random_Seed intrinsic
-@cindex intrinsics, Random_Seed
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Random_Seed} to use this name for an
-external procedure.
-
-@node Range Intrinsic
-@subsubsection Range Intrinsic
-@cindex Range intrinsic
-@cindex intrinsics, Range
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Range} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node Real Intrinsic
-@subsubsection Real Intrinsic
-@cindex Real intrinsic
-@cindex intrinsics, Real
-
-@noindent
-@example
-Real(@var{A})
-@end example
-
-@noindent
-Real: @code{REAL} function.
-The exact type is @samp{REAL(KIND=1)} when argument @var{A} is
-any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}.
-When @var{A} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)},
-this intrinsic is valid only when used as the argument to
-@code{REAL()}, as explained below.
-
-@noindent
-@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Converts @var{A} to @code{REAL(KIND=1)}.
-
-Use of @code{REAL()} with a @code{COMPLEX} argument
-(other than @code{COMPLEX(KIND=1)}) is restricted to the following case:
-
-@example
-REAL(REAL(A))
-@end example
-
-@noindent
-This expression converts the real part of A to
-@code{REAL(KIND=1)}.
-
-@xref{RealPart Intrinsic}, for information on a GNU Fortran
-intrinsic that extracts the real part of an arbitrary
-@code{COMPLEX} value.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-
-@end ifset
-@ifset familyGNU
-@node RealPart Intrinsic
-@subsubsection RealPart Intrinsic
-@cindex RealPart intrinsic
-@cindex intrinsics, RealPart
-
-@noindent
-@example
-RealPart(@var{Z})
-@end example
-
-@noindent
-RealPart: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{Z}.
-
-@noindent
-@var{Z}: @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{gnu}.
-
-@noindent
-Description:
-
-The real part of @var{Z} is returned, without conversion.
-
-@emph{Note:} The way to do this in standard Fortran 90
-is @samp{REAL(@var{Z})}.
-However, when, for example, @var{Z} is @code{COMPLEX(KIND=2)},
-@samp{REAL(@var{Z})} means something different for some compilers
-that are not true Fortran 90 compilers but offer some
-extensions standardized by Fortran 90 (such as the
-@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}).
-
-The advantage of @code{REALPART()} is that, while not necessarily
-more or less portable than @code{REAL()}, it is more likely to
-cause a compiler that doesn't support it to produce a diagnostic
-than generate incorrect code.
-
-@xref{REAL() and AIMAG() of Complex}, for more information.
-
-@end ifset
-@ifset familyF2U
-@node Rename Intrinsic (subroutine)
-@subsubsection Rename Intrinsic (subroutine)
-@cindex Rename intrinsic
-@cindex intrinsics, Rename
-
-@noindent
-@example
-CALL Rename(@var{Path1}, @var{Path2}, @var{Status})
-@end example
-
-@noindent
-@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Renames the file @var{Path1} to @var{Path2}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{Path1} and @var{Path2}---otherwise,
-trailing blanks in @var{Path1} and @var{Path2} are ignored.
-See @code{rename(2)}.
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{Rename Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node Rename Intrinsic (function)
-@subsubsection Rename Intrinsic (function)
-@cindex Rename intrinsic
-@cindex intrinsics, Rename
-
-@noindent
-@example
-Rename(@var{Path1}, @var{Path2})
-@end example
-
-@noindent
-Rename: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Renames the file @var{Path1} to @var{Path2}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{Path1} and @var{Path2}---otherwise,
-trailing blanks in @var{Path1} and @var{Path2} are ignored.
-See @code{rename(2)}.
-Returns 0 on success or a nonzero error code.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{Rename Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node Repeat Intrinsic
-@subsubsection Repeat Intrinsic
-@cindex Repeat intrinsic
-@cindex intrinsics, Repeat
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Repeat} to use this name for an
-external procedure.
-
-@node Reshape Intrinsic
-@subsubsection Reshape Intrinsic
-@cindex Reshape intrinsic
-@cindex intrinsics, Reshape
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Reshape} to use this name for an
-external procedure.
-
-@node RRSpacing Intrinsic
-@subsubsection RRSpacing Intrinsic
-@cindex RRSpacing intrinsic
-@cindex intrinsics, RRSpacing
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL RRSpacing} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2C
-@node RShift Intrinsic
-@subsubsection RShift Intrinsic
-@cindex RShift intrinsic
-@cindex intrinsics, RShift
-
-@noindent
-@example
-RShift(@var{I}, @var{Shift})
-@end example
-
-@noindent
-RShift: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}.
-
-@noindent
-@var{I}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Shift}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Returns @var{I} shifted to the right
-@var{Shift} bits.
-
-Although similar to the expression
-@samp{@var{I}/(2**@var{Shift})}, there
-are important differences.
-For example, the sign of the result is
-undefined.
-
-Currently this intrinsic is defined assuming
-the underlying representation of @var{I}
-is as a two's-complement integer.
-It is unclear at this point whether that
-definition will apply when a different
-representation is involved.
-
-@xref{RShift Intrinsic}, for the inverse of this function.
-
-@xref{IShft Intrinsic}, for information
-on a more widely available right-shifting
-intrinsic that is also more precisely defined.
-
-@end ifset
-@ifset familyF90
-@node Scale Intrinsic
-@subsubsection Scale Intrinsic
-@cindex Scale intrinsic
-@cindex intrinsics, Scale
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Scale} to use this name for an
-external procedure.
-
-@node Scan Intrinsic
-@subsubsection Scan Intrinsic
-@cindex Scan intrinsic
-@cindex intrinsics, Scan
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Scan} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyVXT
-@node Secnds Intrinsic
-@subsubsection Secnds Intrinsic
-@cindex Secnds intrinsic
-@cindex intrinsics, Secnds
-
-@noindent
-@example
-Secnds(@var{T})
-@end example
-
-@noindent
-Secnds: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{T}: @code{REAL(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{vxt}.
-
-@noindent
-Description:
-
-Returns the local time in seconds since midnight minus the value
-@var{T}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-This values returned by this intrinsic
-become numerically less than previous values
-(they wrap around) during a single run of the
-compiler program, under normal circumstances
-(such as running through the midnight hour).
-
-@end ifset
-@ifset familyF2U
-@node Second Intrinsic (function)
-@subsubsection Second Intrinsic (function)
-@cindex Second intrinsic
-@cindex intrinsics, Second
-
-@noindent
-@example
-Second()
-@end example
-
-@noindent
-Second: @code{REAL(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the process's runtime in seconds---the same value as the
-UNIX function @code{etime} returns.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-For information on other intrinsics with the same name:
-@xref{Second Intrinsic (subroutine)}.
-
-@node Second Intrinsic (subroutine)
-@subsubsection Second Intrinsic (subroutine)
-@cindex Second intrinsic
-@cindex intrinsics, Second
-
-@noindent
-@example
-CALL Second(@var{Seconds})
-@end example
-
-@noindent
-@var{Seconds}: @code{REAL}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the process's runtime in seconds in @var{Seconds}---the same value
-as the UNIX function @code{etime} returns.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-This routine is known from Cray Fortran. @xref{CPU_Time Intrinsic},
-for a standard equivalent.
-
-For information on other intrinsics with the same name:
-@xref{Second Intrinsic (function)}.
-
-@end ifset
-@ifset familyF90
-@node Selected_Int_Kind Intrinsic
-@subsubsection Selected_Int_Kind Intrinsic
-@cindex Selected_Int_Kind intrinsic
-@cindex intrinsics, Selected_Int_Kind
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Selected_Int_Kind} to use this name for an
-external procedure.
-
-@node Selected_Real_Kind Intrinsic
-@subsubsection Selected_Real_Kind Intrinsic
-@cindex Selected_Real_Kind intrinsic
-@cindex intrinsics, Selected_Real_Kind
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Selected_Real_Kind} to use this name for an
-external procedure.
-
-@node Set_Exponent Intrinsic
-@subsubsection Set_Exponent Intrinsic
-@cindex Set_Exponent intrinsic
-@cindex intrinsics, Set_Exponent
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Set_Exponent} to use this name for an
-external procedure.
-
-@node Shape Intrinsic
-@subsubsection Shape Intrinsic
-@cindex Shape intrinsic
-@cindex intrinsics, Shape
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Shape} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node Short Intrinsic
-@subsubsection Short Intrinsic
-@cindex Short intrinsic
-@cindex intrinsics, Short
-
-@noindent
-@example
-Short(@var{A})
-@end example
-
-@noindent
-Short: @code{INTEGER(KIND=6)} function.
-
-@noindent
-@var{A}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns @var{A} with the fractional portion of its
-magnitude truncated and its sign preserved, converted
-to type @code{INTEGER(KIND=6)}.
-
-If @var{A} is type @code{COMPLEX}, its real part
-is truncated and converted, and its imaginary part is disregarded.
-
-@xref{Int Intrinsic}.
-
-The precise meaning of this intrinsic might change
-in a future version of the GNU Fortran language,
-as more is learned about how it is used.
-
-@end ifset
-@ifset familyF77
-@node Sign Intrinsic
-@subsubsection Sign Intrinsic
-@cindex Sign intrinsic
-@cindex intrinsics, Sign
-
-@noindent
-@example
-Sign(@var{A}, @var{B})
-@end example
-
-@noindent
-Sign: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{A}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-@var{B}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns @samp{ABS(@var{A})*@var{s}}, where
-@var{s} is +1 if @samp{@var{B}.GE.0},
--1 otherwise.
-
-@xref{Abs Intrinsic}, for the function that returns
-the magnitude of a value.
-
-@end ifset
-@ifset familyF2U
-@node Signal Intrinsic (subroutine)
-@subsubsection Signal Intrinsic (subroutine)
-@cindex Signal intrinsic
-@cindex intrinsics, Signal
-
-@noindent
-@example
-CALL Signal(@var{Number}, @var{Handler}, @var{Status})
-@end example
-
-@noindent
-@var{Number}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Handler}: Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})
-or dummy/global @code{INTEGER(KIND=1)} scalar.
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=7)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-If @var{Handler} is a an @code{EXTERNAL} routine, arranges for it to be
-invoked with a single integer argument (of system-dependent length)
-when signal @var{Number} occurs.
-If @var{Handler} is an integer, it can be
-used to turn off handling of signal @var{Number} or revert to its default
-action.
-See @code{signal(2)}.
-
-Note that @var{Handler} will be called using C conventions,
-so the value of its argument in Fortran terms
-Fortran terms is obtained by applying @code{%LOC()} (or @code{LOC()}) to it.
-
-The value returned by @code{signal(2)} is written to @var{Status}, if
-that argument is supplied.
-Otherwise the return value is ignored.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-@emph{Warning:} Use of the @code{libf2c} run-time library function
-@samp{signal_} directly
-(such as via @samp{EXTERNAL SIGNAL})
-requires use of the @code{%VAL()} construct
-to pass an @code{INTEGER} value
-(such as @samp{SIG_IGN} or @samp{SIG_DFL})
-for the @var{Handler} argument.
-
-However, while @samp{CALL SIGNAL(@var{signum}, %VAL(SIG_IGN))}
-works when @samp{SIGNAL} is treated as an external procedure
-(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine),
-this construct is not valid when @samp{SIGNAL} is recognized
-as the intrinsic of that name.
-
-Therefore, for maximum portability and reliability,
-code such references to the @samp{SIGNAL} facility as follows:
-
-@smallexample
-INTRINSIC SIGNAL
-@dots{}
-CALL SIGNAL(@var{signum}, SIG_IGN)
-@end smallexample
-
-@code{g77} will compile such a call correctly,
-while other compilers will generally either do so as well
-or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic,
-allowing you to take appropriate action.
-
-For information on other intrinsics with the same name:
-@xref{Signal Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node Signal Intrinsic (function)
-@subsubsection Signal Intrinsic (function)
-@cindex Signal intrinsic
-@cindex intrinsics, Signal
-
-@noindent
-@example
-Signal(@var{Number}, @var{Handler})
-@end example
-
-@noindent
-Signal: @code{INTEGER(KIND=7)} function.
-
-@noindent
-@var{Number}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Handler}: Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})
-or dummy/global @code{INTEGER(KIND=1)} scalar.
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-If @var{Handler} is a an @code{EXTERNAL} routine, arranges for it to be
-invoked with a single integer argument (of system-dependent length)
-when signal @var{Number} occurs.
-If @var{Handler} is an integer, it can be
-used to turn off handling of signal @var{Number} or revert to its default
-action.
-See @code{signal(2)}.
-
-Note that @var{Handler} will be called using C conventions,
-so the value of its argument in Fortran terms
-is obtained by applying @code{%LOC()} (or @code{LOC()}) to it.
-
-The value returned by @code{signal(2)} is returned.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-@emph{Warning:} If the returned value is stored in
-an @code{INTEGER(KIND=1)} (default @code{INTEGER}) argument,
-truncation of the original return value occurs on some systems
-(such as Alphas, which have 64-bit pointers but 32-bit default integers),
-with no warning issued by @code{g77} under normal circumstances.
-
-Therefore, the following code fragment might silently fail on
-some systems:
-
-@smallexample
-INTEGER RTN
-EXTERNAL MYHNDL
-RTN = SIGNAL(@var{signum}, MYHNDL)
-@dots{}
-! Restore original handler:
-RTN = SIGNAL(@var{signum}, RTN)
-@end smallexample
-
-The reason for the failure is that @samp{RTN} might not hold
-all the information on the original handler for the signal,
-thus restoring an invalid handler.
-This bug could manifest itself as a spurious run-time failure
-at an arbitrary point later during the program's execution,
-for example.
-
-@emph{Warning:} Use of the @code{libf2c} run-time library function
-@samp{signal_} directly
-(such as via @samp{EXTERNAL SIGNAL})
-requires use of the @code{%VAL()} construct
-to pass an @code{INTEGER} value
-(such as @samp{SIG_IGN} or @samp{SIG_DFL})
-for the @var{Handler} argument.
-
-However, while @samp{RTN = SIGNAL(@var{signum}, %VAL(SIG_IGN))}
-works when @samp{SIGNAL} is treated as an external procedure
-(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine),
-this construct is not valid when @samp{SIGNAL} is recognized
-as the intrinsic of that name.
-
-Therefore, for maximum portability and reliability,
-code such references to the @samp{SIGNAL} facility as follows:
-
-@smallexample
-INTRINSIC SIGNAL
-@dots{}
-RTN = SIGNAL(@var{signum}, SIG_IGN)
-@end smallexample
-
-@code{g77} will compile such a call correctly,
-while other compilers will generally either do so as well
-or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic,
-allowing you to take appropriate action.
-
-For information on other intrinsics with the same name:
-@xref{Signal Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF77
-@node Sin Intrinsic
-@subsubsection Sin Intrinsic
-@cindex Sin intrinsic
-@cindex intrinsics, Sin
-
-@noindent
-@example
-Sin(@var{X})
-@end example
-
-@noindent
-Sin: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the sine of @var{X}, an angle measured
-in radians.
-
-@xref{ASin Intrinsic}, for the inverse of this function.
-
-@end ifset
-@ifset familyVXT
-@node SinD Intrinsic
-@subsubsection SinD Intrinsic
-@cindex SinD intrinsic
-@cindex intrinsics, SinD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL SinD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node SinH Intrinsic
-@subsubsection SinH Intrinsic
-@cindex SinH intrinsic
-@cindex intrinsics, SinH
-
-@noindent
-@example
-SinH(@var{X})
-@end example
-
-@noindent
-SinH: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the hyperbolic sine of @var{X}.
-
-@end ifset
-@ifset familyF2U
-@node Sleep Intrinsic
-@subsubsection Sleep Intrinsic
-@cindex Sleep intrinsic
-@cindex intrinsics, Sleep
-
-@noindent
-@example
-CALL Sleep(@var{Seconds})
-@end example
-
-@noindent
-@var{Seconds}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Causes the process to pause for @var{Seconds} seconds.
-See @code{sleep(2)}.
-
-@end ifset
-@ifset familyF77
-@node Sngl Intrinsic
-@subsubsection Sngl Intrinsic
-@cindex Sngl intrinsic
-@cindex intrinsics, Sngl
-
-@noindent
-@example
-Sngl(@var{A})
-@end example
-
-@noindent
-Sngl: @code{REAL(KIND=1)} function.
-
-@noindent
-@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Archaic form of @code{REAL()} that is specific
-to one type for @var{A}.
-@xref{Real Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node SnglQ Intrinsic
-@subsubsection SnglQ Intrinsic
-@cindex SnglQ intrinsic
-@cindex intrinsics, SnglQ
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL SnglQ} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF90
-@node Spacing Intrinsic
-@subsubsection Spacing Intrinsic
-@cindex Spacing intrinsic
-@cindex intrinsics, Spacing
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Spacing} to use this name for an
-external procedure.
-
-@node Spread Intrinsic
-@subsubsection Spread Intrinsic
-@cindex Spread intrinsic
-@cindex intrinsics, Spread
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Spread} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node SqRt Intrinsic
-@subsubsection SqRt Intrinsic
-@cindex SqRt intrinsic
-@cindex intrinsics, SqRt
-
-@noindent
-@example
-SqRt(@var{X})
-@end example
-
-@noindent
-SqRt: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the square root of @var{X}, which must
-not be negative.
-
-To calculate and represent the square root of a negative
-number, complex arithmetic must be used.
-For example, @samp{SQRT(COMPLEX(@var{X}))}.
-
-The inverse of this function is @samp{SQRT(@var{X}) * SQRT(@var{X})}.
-
-@end ifset
-@ifset familyF2U
-@node SRand Intrinsic
-@subsubsection SRand Intrinsic
-@cindex SRand intrinsic
-@cindex intrinsics, SRand
-
-@noindent
-@example
-CALL SRand(@var{Seed})
-@end example
-
-@noindent
-@var{Seed}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Reinitializes the generator with the seed in @var{Seed}.
-@xref{IRand Intrinsic}.
-@xref{Rand Intrinsic}.
-
-@node Stat Intrinsic (subroutine)
-@subsubsection Stat Intrinsic (subroutine)
-@cindex Stat intrinsic
-@cindex intrinsics, Stat
-
-@noindent
-@example
-CALL Stat(@var{File}, @var{SArray}, @var{Status})
-@end example
-
-@noindent
-@var{File}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Obtains data about the given file @var{File} and places them in the array
-@var{SArray}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{File}---otherwise,
-trailing blanks in @var{File} are ignored.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{Stat Intrinsic (function)}.
-
-@node Stat Intrinsic (function)
-@subsubsection Stat Intrinsic (function)
-@cindex Stat intrinsic
-@cindex intrinsics, Stat
-
-@noindent
-@example
-Stat(@var{File}, @var{SArray})
-@end example
-
-@noindent
-Stat: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{File}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Obtains data about the given file @var{File} and places them in the array
-@var{SArray}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{File}---otherwise,
-trailing blanks in @var{File} are ignored.
-The values in this array are extracted from the
-@code{stat} structure as returned by @code{fstat(2)} q.v., as follows:
-
-@enumerate
-@item
-Device ID
-
-@item
-Inode number
-
-@item
-File mode
-
-@item
-Number of links
-
-@item
-Owner's uid
-
-@item
-Owner's gid
-
-@item
-ID of device containing directory entry for file
-(0 if not available)
-
-@item
-File size (bytes)
-
-@item
-Last access time
-
-@item
-Last modification time
-
-@item
-Last file status change time
-
-@item
-Preferred I/O block size (-1 if not available)
-
-@item
-Number of blocks allocated (-1 if not available)
-@end enumerate
-
-Not all these elements are relevant on all systems.
-If an element is not relevant, it is returned as 0.
-
-Returns 0 on success or a nonzero error code.
-
-For information on other intrinsics with the same name:
-@xref{Stat Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node Sum Intrinsic
-@subsubsection Sum Intrinsic
-@cindex Sum intrinsic
-@cindex intrinsics, Sum
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Sum} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node SymLnk Intrinsic (subroutine)
-@subsubsection SymLnk Intrinsic (subroutine)
-@cindex SymLnk intrinsic
-@cindex intrinsics, SymLnk
-
-@noindent
-@example
-CALL SymLnk(@var{Path1}, @var{Path2}, @var{Status})
-@end example
-
-@noindent
-@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Makes a symbolic link from file @var{Path1} to @var{Path2}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{Path1} and @var{Path2}---otherwise,
-trailing blanks in @var{Path1} and @var{Path2} are ignored.
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return
-(@code{ENOSYS} if the system does not provide @code{symlink(2)}).
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{SymLnk Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node SymLnk Intrinsic (function)
-@subsubsection SymLnk Intrinsic (function)
-@cindex SymLnk intrinsic
-@cindex intrinsics, SymLnk
-
-@noindent
-@example
-SymLnk(@var{Path1}, @var{Path2})
-@end example
-
-@noindent
-SymLnk: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Makes a symbolic link from file @var{Path1} to @var{Path2}.
-A null character (@samp{CHAR(0)}) marks the end of
-the names in @var{Path1} and @var{Path2}---otherwise,
-trailing blanks in @var{Path1} and @var{Path2} are ignored.
-Returns 0 on success or a nonzero error code
-(@code{ENOSYS} if the system does not provide @code{symlink(2)}).
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{SymLnk Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF2U
-@node System Intrinsic (subroutine)
-@subsubsection System Intrinsic (subroutine)
-@cindex System intrinsic
-@cindex intrinsics, System
-
-@noindent
-@example
-CALL System(@var{Command}, @var{Status})
-@end example
-
-@noindent
-@var{Command}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Passes the command @var{Command} to a shell (see @code{system(3)}).
-If argument @var{Status} is present, it contains the value returned by
-@code{system(3)}, presumably 0 if the shell command succeeded.
-Note that which shell is used to invoke the command is system-dependent
-and environment-dependent.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{System Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node System Intrinsic (function)
-@subsubsection System Intrinsic (function)
-@cindex System intrinsic
-@cindex intrinsics, System
-
-@noindent
-@example
-System(@var{Command})
-@end example
-
-@noindent
-System: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Command}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Passes the command @var{Command} to a shell (see @code{system(3)}).
-Returns the value returned by
-@code{system(3)}, presumably 0 if the shell command succeeded.
-Note that which shell is used to invoke the command is system-dependent
-and environment-dependent.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-However, the function form can be valid in cases where the
-actual side effects performed by the call are unimportant to
-the application.
-
-For example, on a UNIX system, @samp{SAME = SYSTEM('cmp a b')}
-does not perform any side effects likely to be important to the
-program, so the programmer would not care if the actual system
-call (and invocation of @code{cmp}) was optimized away in a situation
-where the return value could be determined otherwise, or was not
-actually needed (@samp{SAME} not actually referenced after the
-sample assignment statement).
-
-For information on other intrinsics with the same name:
-@xref{System Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node System_Clock Intrinsic
-@subsubsection System_Clock Intrinsic
-@cindex System_Clock intrinsic
-@cindex intrinsics, System_Clock
-
-@noindent
-@example
-CALL System_Clock(@var{Count}, @var{Rate}, @var{Max})
-@end example
-
-@noindent
-@var{Count}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT).
-
-@noindent
-@var{Rate}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-@var{Max}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{f90}.
-
-@noindent
-Description:
-
-Returns in @var{Count} the current value of the system clock; this is
-the value returned by the UNIX function @code{times(2)}
-in this implementation, but
-isn't in general.
-@var{Rate} is the number of clock ticks per second and
-@var{Max} is the maximum value this can take, which isn't very useful
-in this implementation since it's just the maximum C @code{unsigned
-int} value.
-
-@cindex wraparound, timings
-@cindex limits, timings
-On some systems, the underlying timings are represented
-using types with sufficiently small limits that overflows
-(wraparounds) are possible, such as 32-bit types.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-@end ifset
-@ifset familyF77
-@node Tan Intrinsic
-@subsubsection Tan Intrinsic
-@cindex Tan intrinsic
-@cindex intrinsics, Tan
-
-@noindent
-@example
-Tan(@var{X})
-@end example
-
-@noindent
-Tan: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the tangent of @var{X}, an angle measured
-in radians.
-
-@xref{ATan Intrinsic}, for the inverse of this function.
-
-@end ifset
-@ifset familyVXT
-@node TanD Intrinsic
-@subsubsection TanD Intrinsic
-@cindex TanD intrinsic
-@cindex intrinsics, TanD
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL TanD} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF77
-@node TanH Intrinsic
-@subsubsection TanH Intrinsic
-@cindex TanH intrinsic
-@cindex intrinsics, TanH
-
-@noindent
-@example
-TanH(@var{X})
-@end example
-
-@noindent
-TanH: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}.
-
-@noindent
-@var{X}: @code{REAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: (standard FORTRAN 77).
-
-@noindent
-Description:
-
-Returns the hyperbolic tangent of @var{X}.
-
-@end ifset
-@ifset familyF2U
-@node Time Intrinsic (UNIX)
-@subsubsection Time Intrinsic (UNIX)
-@cindex Time intrinsic
-@cindex intrinsics, Time
-
-@noindent
-@example
-Time()
-@end example
-
-@noindent
-Time: @code{INTEGER(KIND=1)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the current time encoded as an integer
-(in the manner of the UNIX function @code{time(3)}).
-This value is suitable for passing to @code{CTIME},
-@code{GMTIME}, and @code{LTIME}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-This intrinsic is not fully portable, such as to systems
-with 32-bit @code{INTEGER} types but supporting times
-wider than 32 bits.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-@xref{Time8 Intrinsic}, for information on a
-similar intrinsic that might be portable to more
-GNU Fortran implementations, though to fewer
-Fortran compilers.
-
-For information on other intrinsics with the same name:
-@xref{Time Intrinsic (VXT)}.
-
-@end ifset
-@ifset familyVXT
-@node Time Intrinsic (VXT)
-@subsubsection Time Intrinsic (VXT)
-@cindex Time intrinsic
-@cindex intrinsics, Time
-
-@noindent
-@example
-CALL Time(@var{Time})
-@end example
-
-@noindent
-@var{Time}: @code{CHARACTER*8}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{vxt}.
-
-@noindent
-Description:
-
-Returns in @var{Time} a character representation of the current time as
-obtained from @code{ctime(3)}.
-
-@cindex Y10K compliance
-@cindex Year 10000 compliance
-@cindex wraparound, Y10K
-@cindex limits, Y10K
-Programs making use of this intrinsic
-might not be Year 10000 (Y10K) compliant.
-For example, the date might appear,
-to such programs, to wrap around
-(change from a larger value to a smaller one)
-as of the Year 10000.
-
-@xref{FDate Intrinsic (subroutine)}, for an equivalent routine.
-
-For information on other intrinsics with the same name:
-@xref{Time Intrinsic (UNIX)}.
-
-@end ifset
-@ifset familyF2U
-@node Time8 Intrinsic
-@subsubsection Time8 Intrinsic
-@cindex Time8 intrinsic
-@cindex intrinsics, Time8
-
-@noindent
-@example
-Time8()
-@end example
-
-@noindent
-Time8: @code{INTEGER(KIND=2)} function.
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the current time encoded as a long integer
-(in the manner of the UNIX function @code{time(3)}).
-This value is suitable for passing to @code{CTIME},
-@code{GMTIME}, and @code{LTIME}.
-
-@cindex wraparound, timings
-@cindex limits, timings
-@emph{Warning:} this intrinsic does not increase the range
-of the timing values over that returned by @code{time(3)}.
-On a system with a 32-bit @code{time(3)},
-@code{TIME8} will return a 32-bit value,
-even though converted to an @samp{INTEGER(KIND=2)} value.
-That means overflows of the 32-bit value can still occur.
-Therefore, the values returned by this intrinsic
-might be, or become, negative,
-or numerically less than previous values,
-during a single run of the compiled program.
-
-No Fortran implementations other than GNU Fortran are
-known to support this intrinsic at the time of this
-writing.
-@xref{Time Intrinsic (UNIX)}, for information on a
-similar intrinsic that might be portable to more Fortran
-compilers, though to fewer GNU Fortran implementations.
-
-@end ifset
-@ifset familyF90
-@node Tiny Intrinsic
-@subsubsection Tiny Intrinsic
-@cindex Tiny intrinsic
-@cindex intrinsics, Tiny
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Tiny} to use this name for an
-external procedure.
-
-@node Transfer Intrinsic
-@subsubsection Transfer Intrinsic
-@cindex Transfer intrinsic
-@cindex intrinsics, Transfer
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Transfer} to use this name for an
-external procedure.
-
-@node Transpose Intrinsic
-@subsubsection Transpose Intrinsic
-@cindex Transpose intrinsic
-@cindex intrinsics, Transpose
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Transpose} to use this name for an
-external procedure.
-
-@node Trim Intrinsic
-@subsubsection Trim Intrinsic
-@cindex Trim intrinsic
-@cindex intrinsics, Trim
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Trim} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node TtyNam Intrinsic (subroutine)
-@subsubsection TtyNam Intrinsic (subroutine)
-@cindex TtyNam intrinsic
-@cindex intrinsics, TtyNam
-
-@noindent
-@example
-CALL TtyNam(@var{Unit}, @var{Name})
-@end example
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Sets @var{Name} to the name of the terminal device open on logical unit
-@var{Unit} or to a blank string if @var{Unit} is not connected to a
-terminal.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-
-For information on other intrinsics with the same name:
-@xref{TtyNam Intrinsic (function)}.
-
-@node TtyNam Intrinsic (function)
-@subsubsection TtyNam Intrinsic (function)
-@cindex TtyNam intrinsic
-@cindex intrinsics, TtyNam
-
-@noindent
-@example
-TtyNam(@var{Unit})
-@end example
-
-@noindent
-TtyNam: @code{CHARACTER*(*)} function.
-
-@noindent
-@var{Unit}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Returns the name of the terminal device open on logical unit
-@var{Unit} or a blank string if @var{Unit} is not connected to a
-terminal.
-
-For information on other intrinsics with the same name:
-@xref{TtyNam Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node UBound Intrinsic
-@subsubsection UBound Intrinsic
-@cindex UBound intrinsic
-@cindex intrinsics, UBound
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL UBound} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2U
-@node UMask Intrinsic (subroutine)
-@subsubsection UMask Intrinsic (subroutine)
-@cindex UMask intrinsic
-@cindex intrinsics, UMask
-
-@noindent
-@example
-CALL UMask(@var{Mask}, @var{Old})
-@end example
-
-@noindent
-@var{Mask}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-@var{Old}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Sets the file creation mask to @var{Mask} and returns the old value in
-argument @var{Old} if it is supplied.
-See @code{umask(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine.
-
-For information on other intrinsics with the same name:
-@xref{UMask Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node UMask Intrinsic (function)
-@subsubsection UMask Intrinsic (function)
-@cindex UMask intrinsic
-@cindex intrinsics, UMask
-
-@noindent
-@example
-UMask(@var{Mask})
-@end example
-
-@noindent
-UMask: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{Mask}: @code{INTEGER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Sets the file creation mask to @var{Mask} and returns the old value.
-See @code{umask(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{UMask Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF2U
-@node Unlink Intrinsic (subroutine)
-@subsubsection Unlink Intrinsic (subroutine)
-@cindex Unlink intrinsic
-@cindex intrinsics, Unlink
-
-@noindent
-@example
-CALL Unlink(@var{File}, @var{Status})
-@end example
-
-@noindent
-@var{File}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT).
-
-@noindent
-Intrinsic groups: @code{unix}.
-
-@noindent
-Description:
-
-Unlink the file @var{File}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{File}---otherwise,
-trailing blanks in @var{File} are ignored.
-If the @var{Status} argument is supplied, it contains
-0 on success or a nonzero error code upon return.
-See @code{unlink(2)}.
-
-Some non-GNU implementations of Fortran provide this intrinsic as
-only a function, not as a subroutine, or do not support the
-(optional) @var{Status} argument.
-
-For information on other intrinsics with the same name:
-@xref{Unlink Intrinsic (function)}.
-
-@end ifset
-@ifset familyBADU77
-@node Unlink Intrinsic (function)
-@subsubsection Unlink Intrinsic (function)
-@cindex Unlink intrinsic
-@cindex intrinsics, Unlink
-
-@noindent
-@example
-Unlink(@var{File})
-@end example
-
-@noindent
-Unlink: @code{INTEGER(KIND=1)} function.
-
-@noindent
-@var{File}: @code{CHARACTER}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{badu77}.
-
-@noindent
-Description:
-
-Unlink the file @var{File}.
-A null character (@samp{CHAR(0)}) marks the end of
-the name in @var{File}---otherwise,
-trailing blanks in @var{File} are ignored.
-Returns 0 on success or a nonzero error code.
-See @code{unlink(2)}.
-
-Due to the side effects performed by this intrinsic, the function
-form is not recommended.
-
-For information on other intrinsics with the same name:
-@xref{Unlink Intrinsic (subroutine)}.
-
-@end ifset
-@ifset familyF90
-@node Unpack Intrinsic
-@subsubsection Unpack Intrinsic
-@cindex Unpack intrinsic
-@cindex intrinsics, Unpack
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Unpack} to use this name for an
-external procedure.
-
-@node Verify Intrinsic
-@subsubsection Verify Intrinsic
-@cindex Verify intrinsic
-@cindex intrinsics, Verify
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL Verify} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2C
-@node XOr Intrinsic
-@subsubsection XOr Intrinsic
-@cindex XOr intrinsic
-@cindex intrinsics, XOr
-
-@noindent
-@example
-XOr(@var{I}, @var{J})
-@end example
-
-@noindent
-XOr: @code{INTEGER} or @code{LOGICAL} function, the exact type being the result of cross-promoting the
-types of all the arguments.
-
-@noindent
-@var{I}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN).
-
-@noindent
-@var{J}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Returns value resulting from boolean exclusive-OR of
-pair of bits in each of @var{I} and @var{J}.
-
-@node ZAbs Intrinsic
-@subsubsection ZAbs Intrinsic
-@cindex ZAbs intrinsic
-@cindex intrinsics, ZAbs
-
-@noindent
-@example
-ZAbs(@var{A})
-@end example
-
-@noindent
-ZAbs: @code{REAL(KIND=2)} function.
-
-@noindent
-@var{A}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Archaic form of @code{ABS()} that is specific
-to one type for @var{A}.
-@xref{Abs Intrinsic}.
-
-@node ZCos Intrinsic
-@subsubsection ZCos Intrinsic
-@cindex ZCos intrinsic
-@cindex intrinsics, ZCos
-
-@noindent
-@example
-ZCos(@var{X})
-@end example
-
-@noindent
-ZCos: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Archaic form of @code{COS()} that is specific
-to one type for @var{X}.
-@xref{Cos Intrinsic}.
-
-@node ZExp Intrinsic
-@subsubsection ZExp Intrinsic
-@cindex ZExp intrinsic
-@cindex intrinsics, ZExp
-
-@noindent
-@example
-ZExp(@var{X})
-@end example
-
-@noindent
-ZExp: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Archaic form of @code{EXP()} that is specific
-to one type for @var{X}.
-@xref{Exp Intrinsic}.
-
-@end ifset
-@ifset familyVXT
-@node ZExt Intrinsic
-@subsubsection ZExt Intrinsic
-@cindex ZExt intrinsic
-@cindex intrinsics, ZExt
-
-This intrinsic is not yet implemented.
-The name is, however, reserved as an intrinsic.
-Use @samp{EXTERNAL ZExt} to use this name for an
-external procedure.
-
-@end ifset
-@ifset familyF2C
-@node ZLog Intrinsic
-@subsubsection ZLog Intrinsic
-@cindex ZLog intrinsic
-@cindex intrinsics, ZLog
-
-@noindent
-@example
-ZLog(@var{X})
-@end example
-
-@noindent
-ZLog: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Archaic form of @code{LOG()} that is specific
-to one type for @var{X}.
-@xref{Log Intrinsic}.
-
-@node ZSin Intrinsic
-@subsubsection ZSin Intrinsic
-@cindex ZSin intrinsic
-@cindex intrinsics, ZSin
-
-@noindent
-@example
-ZSin(@var{X})
-@end example
-
-@noindent
-ZSin: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Archaic form of @code{SIN()} that is specific
-to one type for @var{X}.
-@xref{Sin Intrinsic}.
-
-@node ZSqRt Intrinsic
-@subsubsection ZSqRt Intrinsic
-@cindex ZSqRt intrinsic
-@cindex intrinsics, ZSqRt
-
-@noindent
-@example
-ZSqRt(@var{X})
-@end example
-
-@noindent
-ZSqRt: @code{COMPLEX(KIND=2)} function.
-
-@noindent
-@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN).
-
-@noindent
-Intrinsic groups: @code{f2c}.
-
-@noindent
-Description:
-
-Archaic form of @code{SQRT()} that is specific
-to one type for @var{X}.
-@xref{SqRt Intrinsic}.
-
-@end ifset
+++ /dev/null
-/* intrin.c -- Recognize references to intrinsics
- Copyright (C) 1995, 1996, 1997, 1998, 2002,
- 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
-*/
-
-#include "proj.h"
-#include "intrin.h"
-#include "expr.h"
-#include "info.h"
-#include "src.h"
-#include "symbol.h"
-#include "target.h"
-#include "top.h"
-
-struct _ffeintrin_name_
- {
- const char *const name_uc;
- const char *const name_lc;
- const char *const name_ic;
- const ffeintrinGen generic;
- const ffeintrinSpec specific;
- };
-
-struct _ffeintrin_gen_
- {
- const char *const name; /* Name as seen in program. */
- const ffeintrinSpec specs[2];
- };
-
-struct _ffeintrin_spec_
- {
- const char *const name; /* Uppercase name as seen in source code,
- lowercase if no source name, "none" if no
- name at all (NONE case). */
- const bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */
- const ffeintrinFamily family;
- const ffeintrinImp implementation;
- };
-
-struct _ffeintrin_imp_
- {
- const char *const name; /* Name of implementation. */
- const ffecomGfrt gfrt_direct;/* library routine, direct-callable form. */
- const ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */
- const ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */
- const char *const control;
- const char y2kbad;
- };
-
-static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
- ffebld args, ffeinfoBasictype *xbt,
- ffeinfoKindtype *xkt,
- ffetargetCharacterSize *xsz,
- bool *check_intrin,
- ffelexToken t,
- bool commit);
-static bool ffeintrin_check_any_ (ffebld arglist);
-static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic);
-
-static const struct _ffeintrin_name_ ffeintrin_names_[]
-=
-{ /* Alpha order. */
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
- { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-
-static const struct _ffeintrin_gen_ ffeintrin_gens_[]
-=
-{
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
- { NAME, { SPEC1, SPEC2, }, },
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-
-static const struct _ffeintrin_imp_ ffeintrin_imps_[]
-=
-{
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
- { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
- FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE },
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
- { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
- FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD },
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-
-static const struct _ffeintrin_spec_ ffeintrin_specs_[]
-=
-{
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
- { NAME, CALLABLE, FAMILY, IMP, },
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
-};
-\f
-
-static ffebad
-ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
- ffebld args, ffeinfoBasictype *xbt,
- ffeinfoKindtype *xkt,
- ffetargetCharacterSize *xsz,
- bool *check_intrin,
- ffelexToken t,
- bool commit)
-{
- const char *c = ffeintrin_imps_[imp].control;
- bool subr = (c[0] == '-');
- const char *argc;
- ffebld arg;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
- ffeinfoKindtype firstarg_kt;
- bool need_col;
- ffeinfoBasictype col_bt = FFEINFO_basictypeNONE;
- ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE;
- int colon = (c[2] == ':') ? 2 : 3;
- int argno;
-
- /* Check procedure type (function vs. subroutine) against
- invocation. */
-
- if (op == FFEBLD_opSUBRREF)
- {
- if (!subr)
- return FFEBAD_INTRINSIC_IS_FUNC;
- }
- else if (op == FFEBLD_opFUNCREF)
- {
- if (subr)
- return FFEBAD_INTRINSIC_IS_SUBR;
- }
- else
- return FFEBAD_INTRINSIC_REF;
-
- /* Check the arglist for validity. */
-
- if ((args != NULL)
- && (ffebld_head (args) != NULL))
- firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args)));
- else
- firstarg_kt = FFEINFO_kindtype;
-
- for (argc = &c[colon + 3],
- arg = args;
- *argc != '\0';
- )
- {
- char optional = '\0';
- char required = '\0';
- char extra = '\0';
- char basic;
- char kind;
- int length;
- int elements;
- bool lastarg_complex = FALSE;
-
- /* We don't do anything with keywords yet. */
- do
- {
- } while (*(++argc) != '=');
-
- ++argc;
- if ((*argc == '?')
- || (*argc == '!')
- || (*argc == '*'))
- optional = *(argc++);
- if ((*argc == '+')
- || (*argc == 'n')
- || (*argc == 'p'))
- required = *(argc++);
- basic = *(argc++);
- kind = *(argc++);
- if (*argc == '[')
- {
- length = *++argc - '0';
- if (*++argc != ']')
- length = 10 * length + (*(argc++) - '0');
- ++argc;
- }
- else
- length = -1;
- if (*argc == '(')
- {
- elements = *++argc - '0';
- if (*++argc != ')')
- elements = 10 * elements + (*(argc++) - '0');
- ++argc;
- }
- else if (*argc == '&')
- {
- elements = -1;
- ++argc;
- }
- else
- elements = 0;
- if ((*argc == '&')
- || (*argc == 'i')
- || (*argc == 'w')
- || (*argc == 'x'))
- extra = *(argc++);
- if (*argc == ',')
- ++argc;
-
- /* Break out of this loop only when current arg spec completely
- processed. */
-
- do
- {
- bool okay;
- ffebld a;
- ffeinfo i;
- bool anynum;
- ffeinfoBasictype abt = FFEINFO_basictypeNONE;
- ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
-
- if ((arg == NULL)
- || (ffebld_head (arg) == NULL))
- {
- if (required != '\0')
- return FFEBAD_INTRINSIC_TOOFEW;
- if (optional == '\0')
- return FFEBAD_INTRINSIC_TOOFEW;
- if (arg != NULL)
- arg = ffebld_trail (arg);
- break; /* Try next argspec. */
- }
-
- a = ffebld_head (arg);
- i = ffebld_info (a);
- anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
-
- /* See how well the arg matches up to the spec. */
-
- switch (basic)
- {
- case 'A':
- okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
- && ((length == -1)
- || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
- break;
-
- case 'C':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
- abt = FFEINFO_basictypeCOMPLEX;
- break;
-
- case 'I':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
- abt = FFEINFO_basictypeINTEGER;
- break;
-
- case 'L':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
- abt = FFEINFO_basictypeLOGICAL;
- break;
-
- case 'R':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- abt = FFEINFO_basictypeREAL;
- break;
-
- case 'B':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
- break;
-
- case 'F':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- break;
-
- case 'N':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- break;
-
- case 'S':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- break;
-
- case 'g':
- okay = ((ffebld_op (a) == FFEBLD_opLABTER)
- || (ffebld_op (a) == FFEBLD_opLABTOK));
- elements = -1;
- extra = '-';
- break;
-
- case 's':
- okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
- && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
- && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
- || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
- && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
- || (ffeinfo_kind (i) == FFEINFO_kindNONE))
- && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
- || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
- || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
- elements = -1;
- extra = '-';
- break;
-
- case '-':
- default:
- okay = TRUE;
- break;
- }
-
- switch (kind)
- {
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- akt = (kind - '0');
- if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
- {
- switch (akt)
- { /* Translate to internal kinds for now! */
- default:
- break;
-
- case 2:
- akt = 4;
- break;
-
- case 3:
- akt = 2;
- break;
-
- case 4:
- akt = 5;
- break;
-
- case 6:
- akt = 3;
- break;
-
- case 7:
- akt = ffecom_pointer_kind ();
- break;
- }
- }
- okay &= anynum || (ffeinfo_kindtype (i) == akt);
- break;
-
- case 'A':
- okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
- akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
- : firstarg_kt;
- break;
-
- case 'N':
- /* Accept integers and logicals not wider than the default integer/logical. */
- if (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- {
- okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER1
- || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER2
- || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER3);
- akt = FFEINFO_kindtypeINTEGER1; /* The default. */
- }
- else if (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)
- {
- okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL1
- || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL2
- || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL3);
- akt = FFEINFO_kindtypeLOGICAL1; /* The default. */
- }
- break;
-
- case '*':
- default:
- break;
- }
-
- switch (elements)
- {
- ffebld b;
-
- case -1:
- break;
-
- case 0:
- if (ffeinfo_rank (i) != 0)
- okay = FALSE;
- break;
-
- default:
- if ((ffeinfo_rank (i) != 1)
- || (ffebld_op (a) != FFEBLD_opSYMTER)
- || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
- || (ffebld_op (b) != FFEBLD_opCONTER)
- || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
- || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
- okay = FALSE;
- break;
- }
-
- switch (extra)
- {
- case '&':
- if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
- || ((ffebld_op (a) != FFEBLD_opSYMTER)
- && (ffebld_op (a) != FFEBLD_opSUBSTR)
- && (ffebld_op (a) != FFEBLD_opARRAYREF)))
- okay = FALSE;
- break;
-
- case 'w':
- case 'x':
- if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
- || ((ffebld_op (a) != FFEBLD_opSYMTER)
- && (ffebld_op (a) != FFEBLD_opARRAYREF)
- && (ffebld_op (a) != FFEBLD_opSUBSTR)))
- okay = FALSE;
- break;
-
- case '-':
- case 'i':
- break;
-
- default:
- if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
- okay = FALSE;
- break;
- }
-
- if ((optional == '!')
- && lastarg_complex)
- okay = FALSE;
-
- if (!okay)
- {
- /* If it wasn't optional, it's an error,
- else maybe it could match a later argspec. */
- if (optional == '\0')
- return FFEBAD_INTRINSIC_REF;
- break; /* Try next argspec. */
- }
-
- lastarg_complex
- = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
-
- if (anynum)
- {
- /* If we know dummy arg type, convert to that now. */
-
- if ((abt != FFEINFO_basictypeNONE)
- && (akt != FFEINFO_kindtypeNONE)
- && commit)
- {
- /* We have a known type, convert hollerith/typeless
- to it. */
-
- a = ffeexpr_convert (a, t, NULL,
- abt, akt, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- ffebld_set_head (arg, a);
- }
- }
-
- arg = ffebld_trail (arg); /* Arg accepted, now move on. */
-
- if (optional == '*')
- continue; /* Go ahead and try another arg. */
- if (required == '\0')
- break;
- if ((required == 'n')
- || (required == '+'))
- {
- optional = '*';
- required = '\0';
- }
- else if (required == 'p')
- required = 'n';
- } while (TRUE);
- }
-
- if (arg != NULL)
- return FFEBAD_INTRINSIC_TOOMANY;
-
- /* Set up the initial type for the return value of the function. */
-
- need_col = FALSE;
- switch (c[0])
- {
- case 'A':
- bt = FFEINFO_basictypeCHARACTER;
- sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1;
- break;
-
- case 'C':
- bt = FFEINFO_basictypeCOMPLEX;
- break;
-
- case 'I':
- bt = FFEINFO_basictypeINTEGER;
- break;
-
- case 'L':
- bt = FFEINFO_basictypeLOGICAL;
- break;
-
- case 'R':
- bt = FFEINFO_basictypeREAL;
- break;
-
- case 'B':
- case 'F':
- case 'N':
- case 'S':
- need_col = TRUE;
- /* Fall through. */
- case '-':
- default:
- bt = FFEINFO_basictypeNONE;
- break;
- }
-
- switch (c[1])
- {
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- kt = (c[1] - '0');
- if ((bt == FFEINFO_basictypeINTEGER)
- || (bt == FFEINFO_basictypeLOGICAL))
- {
- switch (kt)
- { /* Translate to internal kinds for now! */
- default:
- break;
-
- case 2:
- kt = 4;
- break;
-
- case 3:
- kt = 2;
- break;
-
- case 4:
- kt = 5;
- break;
-
- case 6:
- kt = 3;
- break;
-
- case 7:
- kt = ffecom_pointer_kind ();
- break;
- }
- }
- break;
-
- case 'C':
- if (ffe_is_90 ())
- need_col = TRUE;
- kt = 1;
- break;
-
- case '=':
- need_col = TRUE;
- /* Fall through. */
- case '-':
- default:
- kt = FFEINFO_kindtypeNONE;
- break;
- }
-
- /* Determine collective type of COL, if there is one. */
-
- if (need_col || c[colon + 1] != '-')
- {
- bool okay = TRUE;
- bool have_anynum = FALSE;
- int arg_count=0;
-
- for (arg = args, arg_count=0;
- arg != NULL;
- arg = ffebld_trail (arg), arg_count++ )
- {
- ffebld a = ffebld_head (arg);
- ffeinfo i;
- bool anynum;
-
- if (a == NULL)
- continue;
- i = ffebld_info (a);
-
- if ( c[colon+1] != '*' && (c[colon+1]-'0') != arg_count )
- continue;
-
- anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
- if (anynum)
- {
- have_anynum = TRUE;
- continue;
- }
-
- if ((col_bt == FFEINFO_basictypeNONE)
- && (col_kt == FFEINFO_kindtypeNONE))
- {
- col_bt = ffeinfo_basictype (i);
- col_kt = ffeinfo_kindtype (i);
- }
- else
- {
- ffeexpr_type_combine (&col_bt, &col_kt,
- col_bt, col_kt,
- ffeinfo_basictype (i),
- ffeinfo_kindtype (i),
- NULL);
- if ((col_bt == FFEINFO_basictypeNONE)
- || (col_kt == FFEINFO_kindtypeNONE))
- return FFEBAD_INTRINSIC_REF;
- }
- }
-
- if (have_anynum
- && ((col_bt == FFEINFO_basictypeNONE)
- || (col_kt == FFEINFO_kindtypeNONE)))
- {
- /* No type, but have hollerith/typeless. Use type of return
- value to determine type of COL. */
-
- switch (c[0])
- {
- case 'A':
- return FFEBAD_INTRINSIC_REF;
-
- case 'B':
- case 'I':
- case 'L':
- if ((col_bt != FFEINFO_basictypeNONE)
- && (col_bt != FFEINFO_basictypeINTEGER))
- return FFEBAD_INTRINSIC_REF;
- /* Fall through. */
- case 'N':
- case 'S':
- case '-':
- default:
- col_bt = FFEINFO_basictypeINTEGER;
- col_kt = FFEINFO_kindtypeINTEGER1;
- break;
-
- case 'C':
- if ((col_bt != FFEINFO_basictypeNONE)
- && (col_bt != FFEINFO_basictypeCOMPLEX))
- return FFEBAD_INTRINSIC_REF;
- col_bt = FFEINFO_basictypeCOMPLEX;
- col_kt = FFEINFO_kindtypeREAL1;
- break;
-
- case 'R':
- if ((col_bt != FFEINFO_basictypeNONE)
- && (col_bt != FFEINFO_basictypeREAL))
- return FFEBAD_INTRINSIC_REF;
- /* Fall through. */
- case 'F':
- col_bt = FFEINFO_basictypeREAL;
- col_kt = FFEINFO_kindtypeREAL1;
- break;
- }
- }
-
- switch (c[0])
- {
- case 'B':
- okay = (col_bt == FFEINFO_basictypeINTEGER)
- || (col_bt == FFEINFO_basictypeLOGICAL);
- if (need_col)
- bt = col_bt;
- break;
-
- case 'F':
- okay = (col_bt == FFEINFO_basictypeCOMPLEX)
- || (col_bt == FFEINFO_basictypeREAL);
- if (need_col)
- bt = col_bt;
- break;
-
- case 'N':
- okay = (col_bt == FFEINFO_basictypeCOMPLEX)
- || (col_bt == FFEINFO_basictypeINTEGER)
- || (col_bt == FFEINFO_basictypeREAL);
- if (need_col)
- bt = col_bt;
- break;
-
- case 'S':
- okay = (col_bt == FFEINFO_basictypeINTEGER)
- || (col_bt == FFEINFO_basictypeREAL)
- || (col_bt == FFEINFO_basictypeCOMPLEX);
- if (need_col)
- bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt
- : FFEINFO_basictypeREAL);
- break;
- }
-
- switch (c[1])
- {
- case '=':
- if (need_col)
- kt = col_kt;
- break;
-
- case 'C':
- if (col_bt == FFEINFO_basictypeCOMPLEX)
- {
- if (col_kt != FFEINFO_kindtypeREALDEFAULT)
- *check_intrin = TRUE;
- if (need_col)
- kt = col_kt;
- }
- break;
- }
-
- if (!okay)
- return FFEBAD_INTRINSIC_REF;
- }
-
- /* Now, convert args in the arglist to the final type of the COL. */
-
- for (argno = 0, argc = &c[colon + 3],
- arg = args;
- *argc != '\0';
- ++argno)
- {
- char optional = '\0';
- char required = '\0';
- char extra = '\0';
- char basic;
- char kind;
- int length;
- int elements;
- bool lastarg_complex = FALSE;
-
- /* We don't do anything with keywords yet. */
- do
- {
- } while (*(++argc) != '=');
-
- ++argc;
- if ((*argc == '?')
- || (*argc == '!')
- || (*argc == '*'))
- optional = *(argc++);
- if ((*argc == '+')
- || (*argc == 'n')
- || (*argc == 'p'))
- required = *(argc++);
- basic = *(argc++);
- kind = *(argc++);
- if (*argc == '[')
- {
- length = *++argc - '0';
- if (*++argc != ']')
- length = 10 * length + (*(argc++) - '0');
- ++argc;
- }
- else
- length = -1;
- if (*argc == '(')
- {
- elements = *++argc - '0';
- if (*++argc != ')')
- elements = 10 * elements + (*(argc++) - '0');
- ++argc;
- }
- else if (*argc == '&')
- {
- elements = -1;
- ++argc;
- }
- else
- elements = 0;
- if ((*argc == '&')
- || (*argc == 'i')
- || (*argc == 'w')
- || (*argc == 'x'))
- extra = *(argc++);
- if (*argc == ',')
- ++argc;
-
- /* Break out of this loop only when current arg spec completely
- processed. */
-
- do
- {
- bool okay;
- ffebld a;
- ffeinfo i;
- bool anynum;
- ffeinfoBasictype abt = FFEINFO_basictypeNONE;
- ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
-
- if ((arg == NULL)
- || (ffebld_head (arg) == NULL))
- {
- if (arg != NULL)
- arg = ffebld_trail (arg);
- break; /* Try next argspec. */
- }
-
- a = ffebld_head (arg);
- i = ffebld_info (a);
- anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
-
- /* Determine what the default type for anynum would be. */
-
- if (anynum)
- {
- switch (c[colon + 1])
- {
- case '-':
- break;
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- if (argno != (c[colon + 1] - '0'))
- break;
- case '*':
- abt = col_bt;
- akt = col_kt;
- break;
- }
- }
-
- /* Again, match arg up to the spec. We go through all of
- this again to properly follow the contour of optional
- arguments. Probably this level of flexibility is not
- needed, perhaps it's even downright naughty. */
-
- switch (basic)
- {
- case 'A':
- okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
- && ((length == -1)
- || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
- break;
-
- case 'C':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
- abt = FFEINFO_basictypeCOMPLEX;
- break;
-
- case 'I':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
- abt = FFEINFO_basictypeINTEGER;
- break;
-
- case 'L':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
- abt = FFEINFO_basictypeLOGICAL;
- break;
-
- case 'R':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- abt = FFEINFO_basictypeREAL;
- break;
-
- case 'B':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
- break;
-
- case 'F':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- break;
-
- case 'N':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- break;
-
- case 'S':
- okay = anynum
- || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
- break;
-
- case 'g':
- okay = ((ffebld_op (a) == FFEBLD_opLABTER)
- || (ffebld_op (a) == FFEBLD_opLABTOK));
- elements = -1;
- extra = '-';
- break;
-
- case 's':
- okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
- && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
- && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
- || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
- && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
- || (ffeinfo_kind (i) == FFEINFO_kindNONE))
- && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
- || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
- || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
- elements = -1;
- extra = '-';
- break;
-
- case '-':
- default:
- okay = TRUE;
- break;
- }
-
- switch (kind)
- {
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- akt = (kind - '0');
- if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
- || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
- {
- switch (akt)
- { /* Translate to internal kinds for now! */
- default:
- break;
-
- case 2:
- akt = 4;
- break;
-
- case 3:
- akt = 2;
- break;
-
- case 4:
- akt = 5;
- break;
-
- case 6:
- akt = 3;
- break;
-
- case 7:
- akt = ffecom_pointer_kind ();
- break;
- }
- }
- okay &= anynum || (ffeinfo_kindtype (i) == akt);
- break;
-
- case 'A':
- okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
- akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
- : firstarg_kt;
- break;
-
- case '*':
- default:
- break;
- }
-
- switch (elements)
- {
- ffebld b;
-
- case -1:
- break;
-
- case 0:
- if (ffeinfo_rank (i) != 0)
- okay = FALSE;
- break;
-
- default:
- if ((ffeinfo_rank (i) != 1)
- || (ffebld_op (a) != FFEBLD_opSYMTER)
- || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
- || (ffebld_op (b) != FFEBLD_opCONTER)
- || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
- || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
- okay = FALSE;
- break;
- }
-
- switch (extra)
- {
- case '&':
- if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
- || ((ffebld_op (a) != FFEBLD_opSYMTER)
- && (ffebld_op (a) != FFEBLD_opSUBSTR)
- && (ffebld_op (a) != FFEBLD_opARRAYREF)))
- okay = FALSE;
- break;
-
- case 'w':
- case 'x':
- if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
- || ((ffebld_op (a) != FFEBLD_opSYMTER)
- && (ffebld_op (a) != FFEBLD_opARRAYREF)
- && (ffebld_op (a) != FFEBLD_opSUBSTR)))
- okay = FALSE;
- break;
-
- case '-':
- case 'i':
- break;
-
- default:
- if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
- okay = FALSE;
- break;
- }
-
- if ((optional == '!')
- && lastarg_complex)
- okay = FALSE;
-
- if (!okay)
- {
- /* If it wasn't optional, it's an error,
- else maybe it could match a later argspec. */
- if (optional == '\0')
- return FFEBAD_INTRINSIC_REF;
- break; /* Try next argspec. */
- }
-
- lastarg_complex
- = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
-
- if (anynum && commit)
- {
- /* If we know dummy arg type, convert to that now. */
-
- if (abt == FFEINFO_basictypeNONE)
- abt = FFEINFO_basictypeINTEGER;
- if (akt == FFEINFO_kindtypeNONE)
- akt = FFEINFO_kindtypeINTEGER1;
-
- /* We have a known type, convert hollerith/typeless to it. */
-
- a = ffeexpr_convert (a, t, NULL,
- abt, akt, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- ffebld_set_head (arg, a);
- }
- else if ((c[colon + 1] == '*') && commit)
- {
- /* This is where we promote types to the consensus
- type for the COL. Maybe this is where -fpedantic
- should issue a warning as well. */
-
- a = ffeexpr_convert (a, t, NULL,
- col_bt, col_kt, 0,
- ffeinfo_size (i),
- FFEEXPR_contextLET);
- ffebld_set_head (arg, a);
- }
-
- arg = ffebld_trail (arg); /* Arg accepted, now move on. */
-
- if (optional == '*')
- continue; /* Go ahead and try another arg. */
- if (required == '\0')
- break;
- if ((required == 'n')
- || (required == '+'))
- {
- optional = '*';
- required = '\0';
- }
- else if (required == 'p')
- required = 'n';
- } while (TRUE);
- }
-
- *xbt = bt;
- *xkt = kt;
- *xsz = sz;
- return FFEBAD;
-}
-
-static bool
-ffeintrin_check_any_ (ffebld arglist)
-{
- ffebld item;
-
- for (; arglist != NULL; arglist = ffebld_trail (arglist))
- {
- item = ffebld_head (arglist);
- if ((item != NULL)
- && (ffebld_op (item) == FFEBLD_opANY))
- return TRUE;
- }
-
- return FALSE;
-}
-
-/* Compare a forced-to-uppercase name with a known-upper-case name. */
-
-static int
-upcasecmp_ (const char *name, const char *ucname)
-{
- for ( ; *name != 0 && *ucname != 0; name++, ucname++)
- {
- int i = TOUPPER(*name) - *ucname;
-
- if (i != 0)
- return i;
- }
-
- return *name - *ucname;
-}
-
-/* Compare name to intrinsic's name.
- The intrinsics table is sorted on the upper case entries; so first
- compare irrespective of case on the `uc' entry. If it matches,
- compare according to the setting of intrinsics case comparison mode. */
-
-static int
-ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
-{
- const char *const uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc;
- const char *const lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc;
- const char *const ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic;
- int i;
-
- if ((i = upcasecmp_ (name, uc)) == 0)
- {
- switch (ffe_case_intrin ())
- {
- case FFE_caseLOWER:
- return strcmp(name, lc);
- case FFE_caseINITCAP:
- return strcmp(name, ic);
- default:
- return 0;
- }
- }
-
- return i;
-}
-
-/* Return basic type of intrinsic implementation, based on its
- run-time implementation *only*. (This is used only when
- the type of an intrinsic name is needed without having a
- list of arguments, i.e. an interface signature, such as when
- passing the intrinsic itself, or really the run-time-library
- function, as an argument.)
-
- If there's no eligible intrinsic implementation, there must be
- a bug somewhere else; no such reference should have been permitted
- to go this far. (Well, this might be wrong.) */
-
-ffeinfoBasictype
-ffeintrin_basictype (ffeintrinSpec spec)
-{
- ffeintrinImp imp;
- ffecomGfrt gfrt;
-
- assert (spec < FFEINTRIN_spec);
- imp = ffeintrin_specs_[spec].implementation;
- assert (imp < FFEINTRIN_imp);
-
- if (ffe_is_f2c ())
- gfrt = ffeintrin_imps_[imp].gfrt_f2c;
- else
- gfrt = ffeintrin_imps_[imp].gfrt_gnu;
-
- assert (gfrt != FFECOM_gfrt);
-
- return ffecom_gfrt_basictype (gfrt);
-}
-
-/* Return family to which specific intrinsic belongs. */
-
-ffeintrinFamily
-ffeintrin_family (ffeintrinSpec spec)
-{
- if (spec >= FFEINTRIN_spec)
- return FALSE;
- return ffeintrin_specs_[spec].family;
-}
-
-/* Check and fill in info on func/subr ref node.
-
- ffebld expr; // FUNCREF or SUBRREF with no info (caller
- // gets it from the modified info structure).
- ffeinfo info; // Already filled in, will be overwritten.
- ffelexToken token; // Used for error message.
- ffeintrin_fulfill_generic (&expr, &info, token);
-
- Based on the generic id, figure out which specific procedure is meant and
- pick that one. Else return an error, a la _specific. */
-
-void
-ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t)
-{
- ffebld symter;
- ffebldOp op;
- ffeintrinGen gen;
- ffeintrinSpec spec = FFEINTRIN_specNONE;
- ffeinfoBasictype bt = FFEINFO_basictypeNONE;
- ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
- ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
- ffeintrinImp imp;
- ffeintrinSpec tspec;
- ffeintrinImp nimp = FFEINTRIN_impNONE;
- ffebad error;
- bool any = FALSE;
- bool highly_specific = FALSE;
- int i;
-
- op = ffebld_op (*expr);
- assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
- assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
-
- gen = ffebld_symter_generic (ffebld_left (*expr));
- assert (gen != FFEINTRIN_genNONE);
-
- imp = FFEINTRIN_impNONE;
- error = FFEBAD;
-
- any = ffeintrin_check_any_ (ffebld_right (*expr));
-
- for (i = 0;
- (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
- && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE)
- && !any;
- ++i)
- {
- ffeintrinImp timp = ffeintrin_specs_[tspec].implementation;
- ffeinfoBasictype tbt;
- ffeinfoKindtype tkt;
- ffetargetCharacterSize tsz;
- ffeIntrinsicState state
- = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
- ffebad terror;
-
- if (state == FFE_intrinsicstateDELETED)
- continue;
-
- if (timp != FFEINTRIN_impNONE)
- {
- if (!(ffeintrin_imps_[timp].control[0] == '-')
- != !(ffebld_op (*expr) == FFEBLD_opSUBRREF))
- continue; /* Form of reference must match form of specific. */
- }
-
- if (state == FFE_intrinsicstateDISABLED)
- terror = FFEBAD_INTRINSIC_DISABLED;
- else if (timp == FFEINTRIN_impNONE)
- terror = FFEBAD_INTRINSIC_UNIMPL;
- else
- {
- terror = ffeintrin_check_ (timp, ffebld_op (*expr),
- ffebld_right (*expr),
- &tbt, &tkt, &tsz, NULL, t, FALSE);
- if (terror == FFEBAD)
- {
- if (imp != FFEINTRIN_impNONE)
- {
- ffebad_start (FFEBAD_INTRINSIC_AMBIG);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (ffeintrin_gens_[gen].name);
- ffebad_string (ffeintrin_specs_[spec].name);
- ffebad_string (ffeintrin_specs_[tspec].name);
- ffebad_finish ();
- }
- else
- {
- if (ffebld_symter_specific (ffebld_left (*expr))
- == tspec)
- highly_specific = TRUE;
- imp = timp;
- spec = tspec;
- bt = tbt;
- kt = tkt;
- sz = tkt;
- error = terror;
- }
- }
- else if (terror != FFEBAD)
- { /* This error has precedence over others. */
- if ((error == FFEBAD_INTRINSIC_DISABLED)
- || (error == FFEBAD_INTRINSIC_UNIMPL))
- error = FFEBAD;
- }
- }
-
- if (error == FFEBAD)
- error = terror;
- }
-
- if (any || (imp == FFEINTRIN_impNONE))
- {
- if (!any)
- {
- if (error == FFEBAD)
- error = FFEBAD_INTRINSIC_REF;
- ffebad_start (error);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (ffeintrin_gens_[gen].name);
- ffebad_finish ();
- }
-
- *expr = ffebld_new_any ();
- *info = ffeinfo_new_any ();
- }
- else
- {
- if (!highly_specific && (nimp != FFEINTRIN_impNONE))
- {
- fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n",
- (long) input_line,
- ffeintrin_gens_[gen].name,
- ffeintrin_imps_[imp].name,
- ffeintrin_imps_[nimp].name);
- assert ("Ambiguous generic reference" == NULL);
- abort ();
- }
- error = ffeintrin_check_ (imp, ffebld_op (*expr),
- ffebld_right (*expr),
- &bt, &kt, &sz, NULL, t, TRUE);
- assert (error == FFEBAD);
- *info = ffeinfo_new (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereFLEETING,
- sz);
- symter = ffebld_left (*expr);
- ffebld_symter_set_specific (symter, spec);
- ffebld_symter_set_implementation (symter, imp);
- ffebld_set_info (symter,
- ffeinfo_new (bt,
- kt,
- 0,
- (bt == FFEINFO_basictypeNONE)
- ? FFEINFO_kindSUBROUTINE
- : FFEINFO_kindFUNCTION,
- FFEINFO_whereINTRINSIC,
- sz));
-
- if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
- && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
- || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
- || ((sz != FFETARGET_charactersizeNONE)
- && (sz != ffesymbol_size (ffebld_symter (symter)))))))
- {
- ffebad_start (FFEBAD_INTRINSIC_TYPE);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (ffeintrin_gens_[gen].name);
- ffebad_finish ();
- }
- if (ffeintrin_imps_[imp].y2kbad)
- {
- ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (ffeintrin_gens_[gen].name);
- ffebad_finish ();
- }
- }
-}
-
-/* Check and fill in info on func/subr ref node.
-
- ffebld expr; // FUNCREF or SUBRREF with no info (caller
- // gets it from the modified info structure).
- ffeinfo info; // Already filled in, will be overwritten.
- bool check_intrin; // May be omitted, else set TRUE if intrinsic needs checking.
- ffelexToken token; // Used for error message.
- ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token);
-
- Based on the specific id, determine whether the arg list is valid
- (number, type, rank, and kind of args) and fill in the info structure
- accordingly. Currently don't rewrite the expression, but perhaps
- someday do so for constant collapsing, except when an error occurs,
- in which case it is overwritten with ANY and info is also overwritten
- accordingly. */
-
-void
-ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
- bool *check_intrin, ffelexToken t)
-{
- ffebld symter;
- ffebldOp op;
- ffeintrinGen gen;
- ffeintrinSpec spec;
- ffeintrinImp imp;
- ffeinfoBasictype bt = FFEINFO_basictypeNONE;
- ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
- ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
- ffeIntrinsicState state;
- ffebad error;
- bool any = FALSE;
- const char *name;
-
- op = ffebld_op (*expr);
- assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
- assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
-
- gen = ffebld_symter_generic (ffebld_left (*expr));
- spec = ffebld_symter_specific (ffebld_left (*expr));
- assert (spec != FFEINTRIN_specNONE);
-
- if (gen != FFEINTRIN_genNONE)
- name = ffeintrin_gens_[gen].name;
- else
- name = ffeintrin_specs_[spec].name;
-
- state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
-
- imp = ffeintrin_specs_[spec].implementation;
- if (check_intrin != NULL)
- *check_intrin = FALSE;
-
- any = ffeintrin_check_any_ (ffebld_right (*expr));
-
- if (state == FFE_intrinsicstateDISABLED)
- error = FFEBAD_INTRINSIC_DISABLED;
- else if (imp == FFEINTRIN_impNONE)
- error = FFEBAD_INTRINSIC_UNIMPL;
- else if (!any)
- {
- error = ffeintrin_check_ (imp, ffebld_op (*expr),
- ffebld_right (*expr),
- &bt, &kt, &sz, check_intrin, t, TRUE);
- }
- else
- error = FFEBAD; /* Not really needed, but quiet -Wuninitialized. */
-
- if (any || (error != FFEBAD))
- {
- if (!any)
- {
-
- ffebad_start (error);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (name);
- ffebad_finish ();
- }
-
- *expr = ffebld_new_any ();
- *info = ffeinfo_new_any ();
- }
- else
- {
- *info = ffeinfo_new (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereFLEETING,
- sz);
- symter = ffebld_left (*expr);
- ffebld_set_info (symter,
- ffeinfo_new (bt,
- kt,
- 0,
- (bt == FFEINFO_basictypeNONE)
- ? FFEINFO_kindSUBROUTINE
- : FFEINFO_kindFUNCTION,
- FFEINFO_whereINTRINSIC,
- sz));
-
- if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
- && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
- || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
- || (sz != ffesymbol_size (ffebld_symter (symter))))))
- {
- ffebad_start (FFEBAD_INTRINSIC_TYPE);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (name);
- ffebad_finish ();
- }
- if (ffeintrin_imps_[imp].y2kbad)
- {
- ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_string (name);
- ffebad_finish ();
- }
- }
-}
-
-/* Return run-time index of intrinsic implementation as direct call. */
-
-ffecomGfrt
-ffeintrin_gfrt_direct (ffeintrinImp imp)
-{
- assert (imp < FFEINTRIN_imp);
-
- return ffeintrin_imps_[imp].gfrt_direct;
-}
-
-/* Return run-time index of intrinsic implementation as actual argument. */
-
-ffecomGfrt
-ffeintrin_gfrt_indirect (ffeintrinImp imp)
-{
- assert (imp < FFEINTRIN_imp);
-
- if (! ffe_is_f2c ())
- return ffeintrin_imps_[imp].gfrt_gnu;
- return ffeintrin_imps_[imp].gfrt_f2c;
-}
-
-void
-ffeintrin_init_0 (void)
-{
- int i;
- const char *p1;
- const char *p2;
- const char *p3;
- int colon;
-
- if (!ffe_is_do_internal_checks ())
- return;
-
- assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_));
- assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_));
- assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_));
-
- for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
- { /* Make sure binary-searched list is in alpha
- order. */
- if (strcmp (ffeintrin_names_[i - 1].name_uc,
- ffeintrin_names_[i].name_uc) >= 0)
- assert ("name list out of order" == NULL);
- }
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
- {
- assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE)
- || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE));
-
- p1 = ffeintrin_names_[i].name_uc;
- p2 = ffeintrin_names_[i].name_lc;
- p3 = ffeintrin_names_[i].name_ic;
- for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3)
- {
- if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
- continue;
- if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
- || (*p1 != TOUPPER (*p2))
- || ((*p3 != *p1) && (*p3 != *p2)))
- break;
- }
- assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
- }
-
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i)
- {
- const char *c = ffeintrin_imps_[i].control;
-
- if (c[0] == '\0')
- continue;
-
- if ((c[0] != '-')
- && (c[0] != 'A')
- && (c[0] != 'C')
- && (c[0] != 'I')
- && (c[0] != 'L')
- && (c[0] != 'R')
- && (c[0] != 'B')
- && (c[0] != 'F')
- && (c[0] != 'N')
- && (c[0] != 'S'))
- {
- fprintf (stderr, "%s: bad return-base-type\n",
- ffeintrin_imps_[i].name);
- continue;
- }
- if ((c[1] != '-')
- && (c[1] != '=')
- && ((c[1] < '1')
- || (c[1] > '9'))
- && (c[1] != 'C'))
- {
- fprintf (stderr, "%s: bad return-kind-type\n",
- ffeintrin_imps_[i].name);
- continue;
- }
- if (c[2] == ':')
- colon = 2;
- else
- {
- if (c[2] != '*')
- {
- fprintf (stderr, "%s: bad return-modifier\n",
- ffeintrin_imps_[i].name);
- continue;
- }
- colon = 3;
- }
- if ((c[colon] != ':') || (c[colon + 2] != ':'))
- {
- fprintf (stderr, "%s: bad control\n",
- ffeintrin_imps_[i].name);
- continue;
- }
- if ((c[colon + 1] != '-')
- && (c[colon + 1] != '*')
- && (! ISDIGIT (c[colon + 1])))
- {
- fprintf (stderr, "%s: bad COL-spec\n",
- ffeintrin_imps_[i].name);
- continue;
- }
- c += (colon + 3);
- while (c[0] != '\0')
- {
- while ((c[0] != '=')
- && (c[0] != ',')
- && (c[0] != '\0'))
- ++c;
- if (c[0] != '=')
- {
- fprintf (stderr, "%s: bad keyword\n",
- ffeintrin_imps_[i].name);
- break;
- }
- if ((c[1] == '?')
- || (c[1] == '!')
- || (c[1] == '+')
- || (c[1] == '*')
- || (c[1] == 'n')
- || (c[1] == 'p'))
- ++c;
- if ((c[1] != '-')
- && (c[1] != 'A')
- && (c[1] != 'C')
- && (c[1] != 'I')
- && (c[1] != 'L')
- && (c[1] != 'R')
- && (c[1] != 'B')
- && (c[1] != 'F')
- && (c[1] != 'N')
- && (c[1] != 'S')
- && (c[1] != 'g')
- && (c[1] != 's'))
- {
- fprintf (stderr, "%s: bad arg-base-type\n",
- ffeintrin_imps_[i].name);
- break;
- }
- if ((c[2] != '*')
- && ((c[2] < '1')
- || (c[2] > '9'))
- && (c[2] != 'A'))
- {
- fprintf (stderr, "%s: bad arg-kind-type\n",
- ffeintrin_imps_[i].name);
- break;
- }
- if (c[3] == '[')
- {
- if ((! ISDIGIT (c[4]))
- || ((c[5] != ']')
- && (++c, ! ISDIGIT (c[4])
- || (c[5] != ']'))))
- {
- fprintf (stderr, "%s: bad arg-len\n",
- ffeintrin_imps_[i].name);
- break;
- }
- c += 3;
- }
- if (c[3] == '(')
- {
- if ((! ISDIGIT (c[4]))
- || ((c[5] != ')')
- && (++c, ! ISDIGIT (c[4])
- || (c[5] != ')'))))
- {
- fprintf (stderr, "%s: bad arg-rank\n",
- ffeintrin_imps_[i].name);
- break;
- }
- c += 3;
- }
- else if ((c[3] == '&')
- && (c[4] == '&'))
- ++c;
- if ((c[3] == '&')
- || (c[3] == 'i')
- || (c[3] == 'w')
- || (c[3] == 'x'))
- ++c;
- if (c[3] == ',')
- {
- c += 4;
- continue;
- }
- if (c[3] != '\0')
- {
- fprintf (stderr, "%s: bad arg-list\n",
- ffeintrin_imps_[i].name);
- }
- break;
- }
- }
-}
-
-/* Determine whether intrinsic is okay as an actual argument. */
-
-bool
-ffeintrin_is_actualarg (ffeintrinSpec spec)
-{
- ffeIntrinsicState state;
-
- if (spec >= FFEINTRIN_spec)
- return FALSE;
-
- state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
-
- return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
- && (ffe_is_f2c ()
- ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
- != FFECOM_gfrt)
- : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
- != FFECOM_gfrt))
- && ((state == FFE_intrinsicstateENABLED)
- || (state == FFE_intrinsicstateHIDDEN));
-}
-
-/* Determine if name is intrinsic, return info.
-
- const char *name; // C-string name of possible intrinsic.
- ffelexToken t; // NULL if no diagnostic to be given.
- bool explicit; // TRUE if INTRINSIC name.
- ffeintrinGen gen; // (TRUE only) Generic id of intrinsic.
- ffeintrinSpec spec; // (TRUE only) Specific id of intrinsic.
- ffeintrinImp imp; // (TRUE only) Implementation id of intrinsic.
- if (ffeintrin_is_intrinsic (name, t, explicit,
- &gen, &spec, &imp))
- // is an intrinsic, use gen, spec, imp, and
- // kind accordingly. */
-
-bool
-ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
- ffeintrinGen *xgen, ffeintrinSpec *xspec,
- ffeintrinImp *ximp)
-{
- struct _ffeintrin_name_ *intrinsic;
- ffeintrinGen gen;
- ffeintrinSpec spec;
- ffeintrinImp imp;
- ffeIntrinsicState state;
- bool disabled = FALSE;
- bool unimpl = FALSE;
-
- intrinsic = bsearch (name, &ffeintrin_names_[0],
- ARRAY_SIZE (ffeintrin_names_),
- sizeof (struct _ffeintrin_name_),
- (void *) ffeintrin_cmp_name_);
-
- if (intrinsic == NULL)
- return FALSE;
-
- gen = intrinsic->generic;
- spec = intrinsic->specific;
- imp = ffeintrin_specs_[spec].implementation;
-
- /* Generic is okay only if at least one of its specifics is okay. */
-
- if (gen != FFEINTRIN_genNONE)
- {
- int i;
- ffeintrinSpec tspec;
- bool ok = FALSE;
-
- name = ffeintrin_gens_[gen].name;
-
- for (i = 0;
- (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
- && ((tspec
- = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
- ++i)
- {
- state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
-
- if (state == FFE_intrinsicstateDELETED)
- continue;
-
- if (state == FFE_intrinsicstateDISABLED)
- {
- disabled = TRUE;
- continue;
- }
-
- if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
- {
- unimpl = TRUE;
- continue;
- }
-
- if ((state == FFE_intrinsicstateENABLED)
- || (explicit
- && (state == FFE_intrinsicstateHIDDEN)))
- {
- ok = TRUE;
- break;
- }
- }
- if (!ok)
- gen = FFEINTRIN_genNONE;
- }
-
- /* Specific is okay only if not: unimplemented, disabled, deleted, or
- hidden and not explicit. */
-
- if (spec != FFEINTRIN_specNONE)
- {
- if (gen != FFEINTRIN_genNONE)
- name = ffeintrin_gens_[gen].name;
- else
- name = ffeintrin_specs_[spec].name;
-
- if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
- == FFE_intrinsicstateDELETED)
- || (!explicit
- && (state == FFE_intrinsicstateHIDDEN)))
- spec = FFEINTRIN_specNONE;
- else if (state == FFE_intrinsicstateDISABLED)
- {
- disabled = TRUE;
- spec = FFEINTRIN_specNONE;
- }
- else if (imp == FFEINTRIN_impNONE)
- {
- unimpl = TRUE;
- spec = FFEINTRIN_specNONE;
- }
- }
-
- /* If neither is okay, not an intrinsic. */
-
- if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
- {
- /* Here is where we produce a diagnostic about a reference to a
- disabled or unimplemented intrinsic, if the diagnostic is desired. */
-
- if ((disabled || unimpl)
- && (t != NULL))
- {
- ffebad_start (disabled
- ? FFEBAD_INTRINSIC_DISABLED
- : FFEBAD_INTRINSIC_UNIMPLW);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_string (name);
- ffebad_finish ();
- }
-
- return FALSE;
- }
-
- /* Determine whether intrinsic is function or subroutine. If no specific
- id, scan list of possible specifics for generic to get consensus. If
- not unanimous, or clear from the context, return NONE. */
-
- if (spec == FFEINTRIN_specNONE)
- {
- int i;
- ffeintrinSpec tspec;
- ffeintrinImp timp;
- bool at_least_one_ok = FALSE;
-
- for (i = 0;
- (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
- && ((tspec
- = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
- ++i)
- {
- if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family))
- == FFE_intrinsicstateDELETED)
- || (state == FFE_intrinsicstateDISABLED))
- continue;
-
- if ((timp = ffeintrin_specs_[tspec].implementation)
- == FFEINTRIN_impNONE)
- continue;
-
- at_least_one_ok = TRUE;
- break;
- }
-
- if (!at_least_one_ok)
- {
- *xgen = FFEINTRIN_genNONE;
- *xspec = FFEINTRIN_specNONE;
- *ximp = FFEINTRIN_impNONE;
- return FALSE;
- }
- }
-
- *xgen = gen;
- *xspec = spec;
- *ximp = imp;
- return TRUE;
-}
-
-/* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90). */
-
-bool
-ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec)
-{
- if (spec == FFEINTRIN_specNONE)
- {
- if (gen == FFEINTRIN_genNONE)
- return FALSE;
-
- spec = ffeintrin_gens_[gen].specs[0];
- if (spec == FFEINTRIN_specNONE)
- return FALSE;
- }
-
- if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77)
- || (ffe_is_90 ()
- && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90)
- || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL)
- || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC))))
- return TRUE;
- return FALSE;
-}
-
-/* Return kind type of intrinsic implementation. See ffeintrin_basictype,
- its sibling. */
-
-ffeinfoKindtype
-ffeintrin_kindtype (ffeintrinSpec spec)
-{
- ffeintrinImp imp;
- ffecomGfrt gfrt;
-
- assert (spec < FFEINTRIN_spec);
- imp = ffeintrin_specs_[spec].implementation;
- assert (imp < FFEINTRIN_imp);
-
- if (ffe_is_f2c ())
- gfrt = ffeintrin_imps_[imp].gfrt_f2c;
- else
- gfrt = ffeintrin_imps_[imp].gfrt_gnu;
-
- assert (gfrt != FFECOM_gfrt);
-
- return ffecom_gfrt_kindtype (gfrt);
-}
-
-/* Return name of generic intrinsic. */
-
-const char *
-ffeintrin_name_generic (ffeintrinGen gen)
-{
- assert (gen < FFEINTRIN_gen);
- return ffeintrin_gens_[gen].name;
-}
-
-/* Return name of intrinsic implementation. */
-
-const char *
-ffeintrin_name_implementation (ffeintrinImp imp)
-{
- assert (imp < FFEINTRIN_imp);
- return ffeintrin_imps_[imp].name;
-}
-
-/* Return external/internal name of specific intrinsic. */
-
-const char *
-ffeintrin_name_specific (ffeintrinSpec spec)
-{
- assert (spec < FFEINTRIN_spec);
- return ffeintrin_specs_[spec].name;
-}
-
-/* Return state of family. */
-
-ffeIntrinsicState
-ffeintrin_state_family (ffeintrinFamily family)
-{
- ffeIntrinsicState state;
-
- switch (family)
- {
- case FFEINTRIN_familyNONE:
- return FFE_intrinsicstateDELETED;
-
- case FFEINTRIN_familyF77:
- return FFE_intrinsicstateENABLED;
-
- case FFEINTRIN_familyASC:
- state = ffe_intrinsic_state_f2c ();
- state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
- return state;
-
- case FFEINTRIN_familyMIL:
- state = ffe_intrinsic_state_vxt ();
- state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
- state = ffe_state_max (state, ffe_intrinsic_state_mil ());
- return state;
-
- case FFEINTRIN_familyGNU:
- state = ffe_intrinsic_state_gnu ();
- return state;
-
- case FFEINTRIN_familyF90:
- state = ffe_intrinsic_state_f90 ();
- return state;
-
- case FFEINTRIN_familyVXT:
- state = ffe_intrinsic_state_vxt ();
- return state;
-
- case FFEINTRIN_familyFVZ:
- state = ffe_intrinsic_state_f2c ();
- state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
- return state;
-
- case FFEINTRIN_familyF2C:
- state = ffe_intrinsic_state_f2c ();
- return state;
-
- case FFEINTRIN_familyF2U:
- state = ffe_intrinsic_state_unix ();
- return state;
-
- case FFEINTRIN_familyBADU77:
- state = ffe_intrinsic_state_badu77 ();
- return state;
-
- default:
- assert ("bad family" == NULL);
- return FFE_intrinsicstateDELETED;
- }
-}
+++ /dev/null
-/* intrin.def -- Public #include File (module.h template V1.0)
- The Free Software Foundation has released this file into the
- public domain.
-
- Owning Modules:
- intrin.c
-
- Modifications:
-*/
-
-/* Intrinsic names listed in alphabetical order, sorted by uppercase name.
- This list is keyed to the names of intrinsics as seen in source code. */
-
-DEFNAME ("ABORT", "abort", "Abort", genNONE, specABORT) /* UNIX */
-DEFNAME ("ABS", "abs", "Abs", genNONE, specABS)
-DEFNAME ("ACCESS", "access", "Access", genNONE, specACCESS) /* UNIX */
-DEFNAME ("ACHAR", "achar", "AChar", genNONE, specACHAR) /* F90, F2C */
-DEFNAME ("ACOS", "acos", "ACos", genNONE, specACOS)
-DEFNAME ("ACOSD", "acosd", "ACosD", genNONE, specACOSD) /* VXT */
-DEFNAME ("ADJUSTL", "adjustl", "AdjustL", genNONE, specADJUSTL) /* F90 */
-DEFNAME ("ADJUSTR", "adjustr", "AdjustR", genNONE, specADJUSTR) /* F90 */
-DEFNAME ("AIMAG", "aimag", "AImag", genNONE, specAIMAG)
-DEFNAME ("AIMAX0", "aimax0", "AIMax0", genNONE, specAIMAX0) /* VXT */
-DEFNAME ("AIMIN0", "aimin0", "AIMin0", genNONE, specAIMIN0) /* VXT */
-DEFNAME ("AINT", "aint", "AInt", genNONE, specAINT)
-DEFNAME ("AJMAX0", "ajmax0", "AJMax0", genNONE, specAJMAX0) /* VXT */
-DEFNAME ("AJMIN0", "ajmin0", "AJMin0", genNONE, specAJMIN0) /* VXT */
-DEFNAME ("ALARM", "alarm", "Alarm", genNONE, specALARM) /* UNIX */
-DEFNAME ("ALL", "all", "All", genNONE, specALL) /* F90 */
-DEFNAME ("ALLOCATED", "allocated", "Allocated", genNONE, specALLOCATED) /* F90 */
-DEFNAME ("ALOG", "alog", "ALog", genNONE, specALOG)
-DEFNAME ("ALOG10", "alog10", "ALog10", genNONE, specALOG10)
-DEFNAME ("AMAX0", "amax0", "AMax0", genNONE, specAMAX0)
-DEFNAME ("AMAX1", "amax1", "AMax1", genNONE, specAMAX1)
-DEFNAME ("AMIN0", "amin0", "AMin0", genNONE, specAMIN0)
-DEFNAME ("AMIN1", "amin1", "AMin1", genNONE, specAMIN1)
-DEFNAME ("AMOD", "amod", "AMod", genNONE, specAMOD)
-DEFNAME ("AND", "and", "And", genNONE, specAND) /* F2C */
-DEFNAME ("ANINT", "anint", "ANInt", genNONE, specANINT)
-DEFNAME ("ANY", "any", "Any", genNONE, specANY) /* F90 */
-DEFNAME ("ASIN", "asin", "ASin", genNONE, specASIN)
-DEFNAME ("ASIND", "asind", "ASinD", genNONE, specASIND) /* VXT */
-DEFNAME ("ASSOCIATED", "associated", "Associated", genNONE, specASSOCIATED) /* F90 */
-DEFNAME ("ATAN", "atan", "ATan", genNONE, specATAN)
-DEFNAME ("ATAN2", "atan2", "ATan2", genNONE, specATAN2)
-DEFNAME ("ATAN2D", "atan2d", "ATan2D", genNONE, specATAN2D) /* VXT */
-DEFNAME ("ATAND", "atand", "ATanD", genNONE, specATAND) /* VXT */
-DEFNAME ("BESJ0", "besj0", "BesJ0", genNONE, specBESJ0) /* UNIX */
-DEFNAME ("BESJ1", "besj1", "BesJ1", genNONE, specBESJ1) /* UNIX */
-DEFNAME ("BESJN", "besjn", "BesJN", genNONE, specBESJN) /* UNIX */
-DEFNAME ("BESY0", "besy0", "BesY0", genNONE, specBESY0) /* UNIX */
-DEFNAME ("BESY1", "besy1", "BesY1", genNONE, specBESY1) /* UNIX */
-DEFNAME ("BESYN", "besyn", "BesYN", genNONE, specBESYN) /* UNIX */
-DEFNAME ("BITEST", "bitest", "BITest", genNONE, specBITEST) /* VXT */
-DEFNAME ("BIT_SIZE", "bit_size", "Bit_Size", genNONE, specBIT_SIZE) /* F90 */
-DEFNAME ("BJTEST", "bjtest", "BJTest", genNONE, specBJTEST) /* VXT */
-DEFNAME ("BTEST", "btest", "BTest", genNONE, specBTEST) /* F90, VXT */
-DEFNAME ("CABS", "cabs", "CAbs", genNONE, specCABS)
-DEFNAME ("CCOS", "ccos", "CCos", genNONE, specCCOS)
-DEFNAME ("CDABS", "cdabs", "CDAbs", genNONE, specCDABS) /* VXT */
-DEFNAME ("CDCOS", "cdcos", "CDCos", genNONE, specCDCOS) /* VXT */
-DEFNAME ("CDEXP", "cdexp", "CDExp", genNONE, specCDEXP) /* VXT */
-DEFNAME ("CDLOG", "cdlog", "CDLog", genNONE, specCDLOG) /* VXT */
-DEFNAME ("CDSIN", "cdsin", "CDSin", genNONE, specCDSIN) /* VXT */
-DEFNAME ("CDSQRT", "cdsqrt", "CDSqRt", genNONE, specCDSQRT) /* VXT */
-DEFNAME ("CEILING", "ceiling", "Ceiling", genNONE, specCEILING) /* F90 */
-DEFNAME ("CEXP", "cexp", "CExp", genNONE, specCEXP)
-DEFNAME ("CHAR", "char", "Char", genNONE, specCHAR)
-DEFNAME ("CHDIR", "chdir", "ChDir", genCHDIR, specNONE) /* UNIX */
-DEFNAME ("CHMOD", "chmod", "ChMod", genCHMOD, specNONE) /* UNIX */
-DEFNAME ("CLOG", "clog", "CLog", genNONE, specCLOG)
-DEFNAME ("CMPLX", "cmplx", "Cmplx", genNONE, specCMPLX)
-DEFNAME ("COMPLEX", "complex", "Complex", genNONE, specCOMPLEX)
-DEFNAME ("CONJG", "conjg", "Conjg", genNONE, specCONJG)
-DEFNAME ("COS", "cos", "Cos", genNONE, specCOS)
-DEFNAME ("COSD", "cosd", "CosD", genNONE, specCOSD) /* VXT */
-DEFNAME ("COSH", "cosh", "CosH", genNONE, specCOSH)
-DEFNAME ("COUNT", "count", "Count", genNONE, specCOUNT) /* F90 */
-DEFNAME ("CPU_TIME", "cpu_time", "CPU_Time", genNONE, specCPU_TIME) /* F95 */
-DEFNAME ("CSHIFT", "cshift", "CShift", genNONE, specCSHIFT) /* F90 */
-DEFNAME ("CSIN", "csin", "CSin", genNONE, specCSIN)
-DEFNAME ("CSQRT", "csqrt", "CSqRt", genNONE, specCSQRT)
-DEFNAME ("CTIME", "ctime", "CTime", genCTIME, specNONE) /* UNIX */
-DEFNAME ("DABS", "dabs", "DAbs", genNONE, specDABS)
-DEFNAME ("DACOS", "dacos", "DACos", genNONE, specDACOS)
-DEFNAME ("DACOSD", "dacosd", "DACosD", genNONE, specDACOSD) /* VXT */
-DEFNAME ("DASIN", "dasin", "DASin", genNONE, specDASIN)
-DEFNAME ("DASIND", "dasind", "DASinD", genNONE, specDASIND) /* VXT */
-DEFNAME ("DATAN", "datan", "DATan", genNONE, specDATAN)
-DEFNAME ("DATAN2", "datan2", "DATan2", genNONE, specDATAN2)
-DEFNAME ("DATAN2D", "datan2d", "DATan2D", genNONE, specDATAN2D) /* VXT */
-DEFNAME ("DATAND", "datand", "DATanD", genNONE, specDATAND) /* VXT */
-DEFNAME ("DATE", "date", "Date", genNONE, specDATE) /* VXT */
-DEFNAME ("DATE_AND_TIME", "date_and_time", "Date_and_Time", genNONE, specDATE_AND_TIME) /* F90 */
-DEFNAME ("DBESJ0", "dbesj0", "DbesJ0", genNONE, specDBESJ0) /* UNIX */
-DEFNAME ("DBESJ1", "dbesj1", "DbesJ1", genNONE, specDBESJ1) /* UNIX */
-DEFNAME ("DBESJN", "dbesjn", "DbesJN", genNONE, specDBESJN) /* UNIX */
-DEFNAME ("DBESY0", "dbesy0", "DbesY0", genNONE, specDBESY0) /* UNIX */
-DEFNAME ("DBESY1", "dbesy1", "DbesY1", genNONE, specDBESY1) /* UNIX */
-DEFNAME ("DBESYN", "dbesyn", "DbesYN", genNONE, specDBESYN) /* UNIX */
-DEFNAME ("DBLE", "dble", "Dble", genNONE, specDBLE)
-DEFNAME ("DBLEQ", "dbleq", "DbleQ", genNONE, specDBLEQ) /* VXT */
-DEFNAME ("DCMPLX", "dcmplx", "DCmplx", genNONE, specDCMPLX) /* F2C, VXT */
-DEFNAME ("DCONJG", "dconjg", "DConjg", genNONE, specDCONJG) /* F2C, VXT */
-DEFNAME ("DCOS", "dcos", "DCos", genNONE, specDCOS)
-DEFNAME ("DCOSD", "dcosd", "DCosD", genNONE, specDCOSD) /* VXT */
-DEFNAME ("DCOSH", "dcosh", "DCosH", genNONE, specDCOSH)
-DEFNAME ("DDIM", "ddim", "DDiM", genNONE, specDDIM)
-DEFNAME ("DERF", "derf", "DErF", genNONE, specDERF) /* UNIX */
-DEFNAME ("DERFC", "derfc", "DErFC", genNONE, specDERFC) /* UNIX */
-DEFNAME ("DEXP", "dexp", "DExp", genNONE, specDEXP)
-DEFNAME ("DFLOAT", "dfloat", "DFloat", genNONE, specDFLOAT) /* F2C, VXT */
-DEFNAME ("DFLOTI", "dfloti", "DFlotI", genNONE, specDFLOTI) /* VXT */
-DEFNAME ("DFLOTJ", "dflotj", "DFlotJ", genNONE, specDFLOTJ) /* VXT */
-DEFNAME ("DIGITS", "digits", "Digits", genNONE, specDIGITS) /* F90 */
-DEFNAME ("DIM", "dim", "DiM", genNONE, specDIM)
-DEFNAME ("DIMAG", "dimag", "DImag", genNONE, specDIMAG) /* F2C, VXT */
-DEFNAME ("DINT", "dint", "DInt", genNONE, specDINT)
-DEFNAME ("DLOG", "dlog", "DLog", genNONE, specDLOG)
-DEFNAME ("DLOG10", "dlog10", "DLog10", genNONE, specDLOG10)
-DEFNAME ("DMAX1", "dmax1", "DMax1", genNONE, specDMAX1)
-DEFNAME ("DMIN1", "dmin1", "DMin1", genNONE, specDMIN1)
-DEFNAME ("DMOD", "dmod", "DMod", genNONE, specDMOD)
-DEFNAME ("DNINT", "dnint", "DNInt", genNONE, specDNINT)
-DEFNAME ("DOT_PRODUCT", "dot_product", "Dot_Product", genNONE, specDOT_PRODUCT) /* F90 */
-DEFNAME ("DPROD", "dprod", "DProd", genNONE, specDPROD)
-DEFNAME ("DREAL", "dreal", "DReal", genNONE, specDREAL) /* VXT */
-DEFNAME ("DSIGN", "dsign", "DSign", genNONE, specDSIGN)
-DEFNAME ("DSIN", "dsin", "DSin", genNONE, specDSIN)
-DEFNAME ("DSIND", "dsind", "DSinD", genNONE, specDSIND) /* VXT */
-DEFNAME ("DSINH", "dsinh", "DSinH", genNONE, specDSINH)
-DEFNAME ("DSQRT", "dsqrt", "DSqRt", genNONE, specDSQRT)
-DEFNAME ("DTAN", "dtan", "DTan", genNONE, specDTAN)
-DEFNAME ("DTAND", "dtand", "DTanD", genNONE, specDTAND) /* VXT */
-DEFNAME ("DTANH", "dtanh", "DTanH", genNONE, specDTANH)
-DEFNAME ("DTIME", "dtime", "DTime", genDTIME, specNONE) /* UNIX */
-DEFNAME ("EOSHIFT", "eoshift", "EOShift", genNONE, specEOSHIFT) /* F90 */
-DEFNAME ("EPSILON", "epsilon", "Epsilon", genNONE, specEPSILON) /* F90 */
-DEFNAME ("ERF", "erf", "ErF", genNONE, specERF) /* UNIX */
-DEFNAME ("ERFC", "erfc", "ErFC", genNONE, specERFC) /* UNIX */
-DEFNAME ("ETIME", "etime", "ETime", genETIME, specNONE) /* UNIX */
-DEFNAME ("EXIT", "exit", "Exit", genNONE, specEXIT) /* UNIX */
-DEFNAME ("EXP", "exp", "Exp", genNONE, specEXP)
-DEFNAME ("EXPONENT", "exponent", "Exponent", genNONE, specEXPONENT) /* F90 */
-DEFNAME ("FDATE", "fdate", "FDate", genFDATE, specNONE) /* UNIX */
-DEFNAME ("FGET", "fget", "FGet", genFGET, specNONE) /* UNIX */
-DEFNAME ("FGETC", "fgetc", "FGetC", genFGETC, specNONE) /* UNIX */
-DEFNAME ("FLOAT", "float", "Float", genNONE, specFLOAT)
-DEFNAME ("FLOATI", "floati", "FloatI", genNONE, specFLOATI) /* VXT */
-DEFNAME ("FLOATJ", "floatj", "FloatJ", genNONE, specFLOATJ) /* VXT */
-DEFNAME ("FLOOR", "floor", "Floor", genNONE, specFLOOR) /* F90 */
-DEFNAME ("FLUSH", "flush", "Flush", genNONE, specFLUSH) /* UNIX */
-DEFNAME ("FNUM", "fnum", "FNum", genNONE, specFNUM) /* UNIX */
-DEFNAME ("FPABSP", "fpabsp", "FPAbsP", genFPABSP, specNONE) /* F2C */
-DEFNAME ("FPEXPN", "fpexpn", "FPExpn", genFPEXPN, specNONE) /* F2C */
-DEFNAME ("FPFRAC", "fpfrac", "FPFrac", genFPFRAC, specNONE) /* F2C */
-DEFNAME ("FPMAKE", "fpmake", "FPMake", genFPMAKE, specNONE) /* F2C */
-DEFNAME ("FPRRSP", "fprrsp", "FPRRSp", genFPRRSP, specNONE) /* F2C */
-DEFNAME ("FPSCAL", "fpscal", "FPScal", genFPSCAL, specNONE) /* F2C */
-DEFNAME ("FPUT", "fput", "FPut", genFPUT, specNONE) /* UNIX */
-DEFNAME ("FPUTC", "fputc", "FPutC", genFPUTC, specNONE) /* UNIX */
-DEFNAME ("FRACTION", "fraction", "Fraction", genNONE, specFRACTION) /* F90 */
-DEFNAME ("FSEEK", "fseek", "FSeek", genNONE, specFSEEK) /* UNIX */
-DEFNAME ("FSTAT", "fstat", "FStat", genFSTAT, specNONE) /* UNIX */
-DEFNAME ("FTELL", "ftell", "FTell", genFTELL, specNONE) /* UNIX */
-DEFNAME ("GERROR", "gerror", "GError", genNONE, specGERROR) /* UNIX */
-DEFNAME ("GETARG", "getarg", "GetArg", genNONE, specGETARG) /* UNIX */
-DEFNAME ("GETCWD", "getcwd", "GetCWD", genGETCWD, specNONE) /* UNIX */
-DEFNAME ("GETENV", "getenv", "GetEnv", genNONE, specGETENV) /* UNIX */
-DEFNAME ("GETGID", "getgid", "GetGId", genNONE, specGETGID) /* UNIX */
-DEFNAME ("GETLOG", "getlog", "GetLog", genNONE, specGETLOG) /* UNIX */
-DEFNAME ("GETPID", "getpid", "GetPId", genNONE, specGETPID) /* UNIX */
-DEFNAME ("GETUID", "getuid", "GetUId", genNONE, specGETUID) /* UNIX */
-DEFNAME ("GMTIME", "gmtime", "GMTime", genNONE, specGMTIME) /* UNIX */
-DEFNAME ("HOSTNM", "hostnm", "HostNm", genHOSTNM, specNONE) /* UNIX */
-DEFNAME ("HUGE", "huge", "Huge", genNONE, specHUGE) /* F90 */
-DEFNAME ("IABS", "iabs", "IAbs", genNONE, specIABS)
-DEFNAME ("IACHAR", "iachar", "IAChar", genNONE, specIACHAR) /* F90, F2C */
-DEFNAME ("IAND", "iand", "IAnd", genNONE, specIAND) /* F90, VXT */
-DEFNAME ("IARGC", "iargc", "IArgC", genNONE, specIARGC) /* UNIX */
-DEFNAME ("IBCLR", "ibclr", "IBClr", genNONE, specIBCLR) /* F90, VXT */
-DEFNAME ("IBITS", "ibits", "IBits", genNONE, specIBITS) /* F90, VXT */
-DEFNAME ("IBSET", "ibset", "IBSet", genNONE, specIBSET) /* F90, VXT */
-DEFNAME ("ICHAR", "ichar", "IChar", genNONE, specICHAR)
-DEFNAME ("IDATE", "idate", "IDate", genIDATE, specNONE) /* UNIX, VXT */
-DEFNAME ("IDIM", "idim", "IDiM", genNONE, specIDIM)
-DEFNAME ("IDINT", "idint", "IDInt", genNONE, specIDINT)
-DEFNAME ("IDNINT", "idnint", "IDNInt", genNONE, specIDNINT)
-DEFNAME ("IEOR", "ieor", "IEOr", genNONE, specIEOR) /* F90, VXT */
-DEFNAME ("IERRNO", "ierrno", "IErrNo", genNONE, specIERRNO) /* UNIX */
-DEFNAME ("IFIX", "ifix", "IFix", genNONE, specIFIX)
-DEFNAME ("IIABS", "iiabs", "IIAbs", genNONE, specIIABS) /* VXT */
-DEFNAME ("IIAND", "iiand", "IIAnd", genNONE, specIIAND) /* VXT */
-DEFNAME ("IIBCLR", "iibclr", "IIBClr", genNONE, specIIBCLR) /* VXT */
-DEFNAME ("IIBITS", "iibits", "IIBits", genNONE, specIIBITS) /* VXT */
-DEFNAME ("IIBSET", "iibset", "IIBSet", genNONE, specIIBSET) /* VXT */
-DEFNAME ("IIDIM", "iidim", "IIDiM", genNONE, specIIDIM) /* VXT */
-DEFNAME ("IIDINT", "iidint", "IIDInt", genNONE, specIIDINT) /* VXT */
-DEFNAME ("IIDNNT", "iidnnt", "IIDNnt", genNONE, specIIDNNT) /* VXT */
-DEFNAME ("IIEOR", "iieor", "IIEOr", genNONE, specIIEOR) /* VXT */
-DEFNAME ("IIFIX", "iifix", "IIFix", genNONE, specIIFIX) /* VXT */
-DEFNAME ("IINT", "iint", "IInt", genNONE, specIINT) /* VXT */
-DEFNAME ("IIOR", "iior", "IIOr", genNONE, specIIOR) /* VXT */
-DEFNAME ("IIQINT", "iiqint", "IIQint", genNONE, specIIQINT) /* VXT */
-DEFNAME ("IIQNNT", "iiqnnt", "IIQNnt", genNONE, specIIQNNT) /* VXT */
-DEFNAME ("IISHFT", "iishft", "IIShft", genNONE, specNONE) /* VXT */
-DEFNAME ("IISHFTC", "iishftc", "IIShftC", genNONE, specIISHFTC) /* VXT */
-DEFNAME ("IISIGN", "iisign", "IISign", genNONE, specIISIGN) /* VXT */
-DEFNAME ("IMAG", "imag", "Imag", genNONE, specIMAG) /* F2C */
-DEFNAME ("IMAGPART", "imagpart", "ImagPart", genNONE, specIMAGPART) /* GNU */
-DEFNAME ("IMAX0", "imax0", "IMax0", genNONE, specIMAX0) /* VXT */
-DEFNAME ("IMAX1", "imax1", "IMax1", genNONE, specIMAX1) /* VXT */
-DEFNAME ("IMIN0", "imin0", "IMin0", genNONE, specIMIN0) /* VXT */
-DEFNAME ("IMIN1", "imin1", "IMin1", genNONE, specIMIN1) /* VXT */
-DEFNAME ("IMOD", "imod", "IMod", genNONE, specIMOD) /* VXT */
-DEFNAME ("INDEX", "index", "Index", genNONE, specINDEX)
-DEFNAME ("ININT", "inint", "INInt", genNONE, specININT) /* VXT */
-DEFNAME ("INOT", "inot", "INot", genNONE, specINOT) /* VXT */
-DEFNAME ("INT", "int", "Int", genNONE, specINT)
-DEFNAME ("INT2", "int2", "Int2", genNONE, specINT2) /* MS */
-DEFNAME ("INT8", "int8", "Int8", genNONE, specINT8) /* GNU */
-DEFNAME ("IOR", "ior", "IOr", genNONE, specIOR) /* F90, VXT */
-DEFNAME ("IRAND", "irand", "IRand", genNONE, specIRAND) /* UNIX */
-DEFNAME ("ISATTY", "isatty", "IsaTty", genNONE, specISATTY) /* UNIX */
-DEFNAME ("ISHFT", "ishft", "IShft", genNONE, specISHFT) /* F90 */
-DEFNAME ("ISHFTC", "ishftc", "IShftC", genNONE, specISHFTC) /* F90, VXT */
-DEFNAME ("ISIGN", "isign", "ISign", genNONE, specISIGN)
-DEFNAME ("ITIME", "itime", "ITime", genNONE, specITIME) /* UNIX */
-DEFNAME ("IZEXT", "izext", "IZExt", genNONE, specIZEXT) /* VXT */
-DEFNAME ("JIABS", "jiabs", "JIAbs", genNONE, specJIABS) /* VXT */
-DEFNAME ("JIAND", "jiand", "JIAnd", genNONE, specJIAND) /* VXT */
-DEFNAME ("JIBCLR", "jibclr", "JIBClr", genNONE, specJIBCLR) /* VXT */
-DEFNAME ("JIBITS", "jibits", "JIBits", genNONE, specJIBITS) /* VXT */
-DEFNAME ("JIBSET", "jibset", "JIBSet", genNONE, specJIBSET) /* VXT */
-DEFNAME ("JIDIM", "jidim", "JIDiM", genNONE, specJIDIM) /* VXT */
-DEFNAME ("JIDINT", "jidint", "JIDInt", genNONE, specJIDINT) /* VXT */
-DEFNAME ("JIDNNT", "jidnnt", "JIDNnt", genNONE, specJIDNNT) /* VXT */
-DEFNAME ("JIEOR", "jieor", "JIEOr", genNONE, specJIEOR) /* VXT */
-DEFNAME ("JIFIX", "jifix", "JIFix", genNONE, specJIFIX) /* VXT */
-DEFNAME ("JINT", "jint", "JInt", genNONE, specJINT) /* VXT */
-DEFNAME ("JIOR", "jior", "JIOr", genNONE, specJIOR) /* VXT */
-DEFNAME ("JIQINT", "jiqint", "JIQint", genNONE, specJIQINT) /* VXT */
-DEFNAME ("JIQNNT", "jiqnnt", "JIQNnt", genNONE, specJIQNNT) /* VXT */
-DEFNAME ("JISHFT", "jishft", "JIShft", genNONE, specJISHFT) /* VXT */
-DEFNAME ("JISHFTC", "jishftc", "JIShftC", genNONE, specJISHFTC) /* VXT */
-DEFNAME ("JISIGN", "jisign", "JISign", genNONE, specJISIGN) /* VXT */
-DEFNAME ("JMAX0", "jmax0", "JMax0", genNONE, specJMAX0) /* VXT */
-DEFNAME ("JMAX1", "jmax1", "JMax1", genNONE, specJMAX1) /* VXT */
-DEFNAME ("JMIN0", "jmin0", "JMin0", genNONE, specJMIN0) /* VXT */
-DEFNAME ("JMIN1", "jmin1", "JMin1", genNONE, specJMIN1) /* VXT */
-DEFNAME ("JMOD", "jmod", "JMod", genNONE, specJMOD) /* VXT */
-DEFNAME ("JNINT", "jnint", "JNInt", genNONE, specJNINT) /* VXT */
-DEFNAME ("JNOT", "jnot", "JNot", genNONE, specJNOT) /* VXT */
-DEFNAME ("JZEXT", "jzext", "JZExt", genNONE, specJZEXT) /* VXT */
-DEFNAME ("KILL", "kill", "Kill", genKILL, specNONE) /* UNIX */
-DEFNAME ("KIND", "kind", "Kind", genNONE, specKIND) /* F90 */
-DEFNAME ("LBOUND", "lbound", "LBound", genNONE, specLBOUND) /* F90 */
-DEFNAME ("LEN", "len", "Len", genNONE, specLEN)
-DEFNAME ("LEN_TRIM", "len_trim", "Len_Trim", genNONE, specLEN_TRIM) /* F90 */
-DEFNAME ("LGE", "lge", "LGe", genNONE, specLGE)
-DEFNAME ("LGT", "lgt", "LGt", genNONE, specLGT)
-DEFNAME ("LINK", "link", "Link", genLINK, specNONE) /* UNIX */
-DEFNAME ("LLE", "lle", "LLe", genNONE, specLLE)
-DEFNAME ("LLT", "llt", "LLt", genNONE, specLLT)
-DEFNAME ("LNBLNK", "lnblnk", "LnBlnk", genNONE, specLNBLNK) /* UNIX */
-DEFNAME ("LOC", "loc", "Loc", genNONE, specLOC) /* VXT */
-DEFNAME ("LOG", "log", "Log", genNONE, specLOG)
-DEFNAME ("LOG10", "log10", "Log10", genNONE, specLOG10)
-DEFNAME ("LOGICAL", "logical", "Logical", genNONE, specLOGICAL) /* F90 */
-DEFNAME ("LONG", "long", "Long", genNONE, specLONG) /* UNIX */
-DEFNAME ("LSHIFT", "lshift", "LShift", genNONE, specLSHIFT) /* F2C */
-DEFNAME ("LSTAT", "lstat", "LStat", genLSTAT, specNONE) /* UNIX */
-DEFNAME ("LTIME", "ltime", "LTime", genNONE, specLTIME) /* UNIX */
-DEFNAME ("MATMUL", "matmul", "MatMul", genNONE, specMATMUL) /* F90 */
-DEFNAME ("MAX", "max", "Max", genNONE, specMAX)
-DEFNAME ("MAX0", "max0", "Max0", genNONE, specMAX0)
-DEFNAME ("MAX1", "max1", "Max1", genNONE, specMAX1)
-DEFNAME ("MAXEXPONENT", "maxexponent", "MaxExponent", genNONE, specMAXEXPONENT) /* F90 */
-DEFNAME ("MAXLOC", "maxloc", "MaxLoc", genNONE, specMAXLOC) /* F90 */
-DEFNAME ("MAXVAL", "maxval", "MaxVal", genNONE, specMAXVAL) /* F90 */
-DEFNAME ("MCLOCK", "mclock", "MClock", genNONE, specMCLOCK) /* UNIX */
-DEFNAME ("MCLOCK8", "mclock8", "MClock8", genNONE, specMCLOCK8) /* UNIX */
-DEFNAME ("MERGE", "merge", "Merge", genNONE, specMERGE) /* F90 */
-DEFNAME ("MIN", "min", "Min", genNONE, specMIN)
-DEFNAME ("MIN0", "min0", "Min0", genNONE, specMIN0)
-DEFNAME ("MIN1", "min1", "Min1", genNONE, specMIN1)
-DEFNAME ("MINEXPONENT", "minexponent", "MinExponent", genNONE, specMINEXPONENT) /* F90 */
-DEFNAME ("MINLOC", "minloc", "MinLoc", genNONE, specMINLOC) /* F90 */
-DEFNAME ("MINVAL", "minval", "MinVal", genNONE, specMINVAL) /* F90 */
-DEFNAME ("MOD", "mod", "Mod", genNONE, specMOD)
-DEFNAME ("MODULO", "modulo", "Modulo", genNONE, specMODULO) /* F90 */
-DEFNAME ("MVBITS", "mvbits", "MvBits", genNONE, specMVBITS) /* F90 */
-DEFNAME ("NEAREST", "nearest", "Nearest", genNONE, specNEAREST) /* F90 */
-DEFNAME ("NINT", "nint", "NInt", genNONE, specNINT)
-DEFNAME ("NOT", "not", "Not", genNONE, specNOT) /* F2C, F90, VXT */
-DEFNAME ("OR", "or", "Or", genNONE, specOR) /* F2C */
-DEFNAME ("PACK", "pack", "Pack", genNONE, specPACK) /* F90 */
-DEFNAME ("PERROR", "perror", "PError", genNONE, specPERROR) /* UNIX */
-DEFNAME ("PRECISION", "precision", "Precision", genNONE, specPRECISION) /* F90 */
-DEFNAME ("PRESENT", "present", "Present", genNONE, specPRESENT) /* F90 */
-DEFNAME ("PRODUCT", "product", "Product", genNONE, specPRODUCT) /* F90 */
-DEFNAME ("QABS", "qabs", "QAbs", genNONE, specQABS) /* VXT */
-DEFNAME ("QACOS", "qacos", "QACos", genNONE, specQACOS) /* VXT */
-DEFNAME ("QACOSD", "qacosd", "QACosD", genNONE, specQACOSD) /* VXT */
-DEFNAME ("QASIN", "qasin", "QASin", genNONE, specQASIN) /* VXT */
-DEFNAME ("QASIND", "qasind", "QASinD", genNONE, specQASIND) /* VXT */
-DEFNAME ("QATAN", "qatan", "QATan", genNONE, specQATAN) /* VXT */
-DEFNAME ("QATAN2", "qatan2", "QATan2", genNONE, specQATAN2) /* VXT */
-DEFNAME ("QATAN2D", "qatan2d", "QATan2D", genNONE, specQATAN2D) /* VXT */
-DEFNAME ("QATAND", "qatand", "QATanD", genNONE, specQATAND) /* VXT */
-DEFNAME ("QCOS", "qcos", "QCos", genNONE, specQCOS) /* VXT */
-DEFNAME ("QCOSD", "qcosd", "QCosD", genNONE, specQCOSD) /* VXT */
-DEFNAME ("QCOSH", "qcosh", "QCosH", genNONE, specQCOSH) /* VXT */
-DEFNAME ("QDIM", "qdim", "QDiM", genNONE, specQDIM) /* VXT */
-DEFNAME ("QEXP", "qexp", "QExp", genNONE, specQEXP) /* VXT */
-DEFNAME ("QEXT", "qext", "QExt", genNONE, specQEXT) /* VXT */
-DEFNAME ("QEXTD", "qextd", "QExtD", genNONE, specQEXTD) /* VXT */
-DEFNAME ("QFLOAT", "qfloat", "QFloat", genNONE, specQFLOAT) /* VXT */
-DEFNAME ("QINT", "qint", "QInt", genNONE, specQINT) /* VXT */
-DEFNAME ("QLOG", "qlog", "QLog", genNONE, specQLOG) /* VXT */
-DEFNAME ("QLOG10", "qlog10", "QLog10", genNONE, specQLOG10) /* VXT */
-DEFNAME ("QMAX1", "qmax1", "QMax1", genNONE, specQMAX1) /* VXT */
-DEFNAME ("QMIN1", "qmin1", "QMin1", genNONE, specQMIN1) /* VXT */
-DEFNAME ("QMOD", "qmod", "QMod", genNONE, specQMOD) /* VXT */
-DEFNAME ("QNINT", "qnint", "QNInt", genNONE, specQNINT) /* VXT */
-DEFNAME ("QSIN", "qsin", "QSin", genNONE, specQSIN) /* VXT */
-DEFNAME ("QSIND", "qsind", "QSinD", genNONE, specQSIND) /* VXT */
-DEFNAME ("QSINH", "qsinh", "QSinH", genNONE, specQSINH) /* VXT */
-DEFNAME ("QSQRT", "qsqrt", "QSqRt", genNONE, specQSQRT) /* VXT */
-DEFNAME ("QTAN", "qtan", "QTan", genNONE, specQTAN) /* VXT */
-DEFNAME ("QTAND", "qtand", "QTanD", genNONE, specQTAND) /* VXT */
-DEFNAME ("QTANH", "qtanh", "QTanH", genNONE, specQTANH) /* VXT */
-DEFNAME ("RADIX", "radix", "Radix", genNONE, specRADIX) /* F90 */
-DEFNAME ("RAND", "rand", "Rand", genNONE, specRAND) /* UNIX */
-DEFNAME ("RANDOM_NUMBER", "random_number", "Random_Number", genNONE, specRANDOM_NUMBER) /* F90 */
-DEFNAME ("RANDOM_SEED", "random_seed", "Random_Seed", genNONE, specRANDOM_SEED) /* F90 */
-DEFNAME ("RANGE", "range", "Range", genNONE, specRANGE) /* F90 */
-DEFNAME ("REAL", "real", "Real", genNONE, specREAL)
-DEFNAME ("REALPART", "realpart", "RealPart", genNONE, specREALPART) /* GNU */
-DEFNAME ("RENAME", "rename", "Rename", genRENAME, specNONE) /* UNIX */
-DEFNAME ("REPEAT", "repeat", "Repeat", genNONE, specREPEAT) /* F90 */
-DEFNAME ("RESHAPE", "reshape", "Reshape", genNONE, specRESHAPE) /* F90 */
-DEFNAME ("RRSPACING", "rrspacing", "RRSpacing", genNONE, specRRSPACING) /* F90 */
-DEFNAME ("RSHIFT", "rshift", "RShift", genNONE, specRSHIFT) /* F2C */
-DEFNAME ("SCALE", "scale", "Scale", genNONE, specSCALE) /* F90 */
-DEFNAME ("SCAN", "scan", "Scan", genNONE, specSCAN) /* F90 */
-DEFNAME ("SECNDS", "secnds", "Secnds", genNONE, specSECNDS) /* VXT */
-DEFNAME ("SECOND", "second", "Second", genSECOND, specNONE) /* UNIX */
-DEFNAME ("SELECTED_INT_KIND", "selected_int_kind", "Selected_Int_Kind", genNONE, specSEL_INT_KIND) /* F90 */
-DEFNAME ("SELECTED_REAL_KIND", "selected_real_kind", "Selected_Real_Kind", genNONE, specSEL_REAL_KIND) /* F90 */
-DEFNAME ("SET_EXPONENT", "set_exponent", "Set_Exponent", genNONE, specSET_EXPONENT) /* F90 */
-DEFNAME ("SHAPE", "shape", "Shape", genNONE, specSHAPE) /* F90 */
-DEFNAME ("SHORT", "short", "Short", genNONE, specSHORT) /* UNIX */
-DEFNAME ("SIGN", "sign", "Sign", genNONE, specSIGN)
-DEFNAME ("SIGNAL", "signal", "Signal", genSIGNAL, specNONE) /* UNIX */
-DEFNAME ("SIN", "sin", "Sin", genNONE, specSIN)
-DEFNAME ("SIND", "sind", "SinD", genNONE, specSIND) /* VXT */
-DEFNAME ("SINH", "sinh", "SinH", genNONE, specSINH)
-DEFNAME ("SLEEP", "sleep", "Sleep", genNONE, specSLEEP) /* UNIX */
-DEFNAME ("SNGL", "sngl", "Sngl", genNONE, specSNGL)
-DEFNAME ("SNGLQ", "snglq", "SnglQ", genNONE, specSNGLQ) /* VXT */
-DEFNAME ("SPACING", "spacing", "Spacing", genNONE, specSPACING) /* F90 */
-DEFNAME ("SPREAD", "spread", "Spread", genNONE, specSPREAD) /* F90 */
-DEFNAME ("SQRT", "sqrt", "SqRt", genNONE, specSQRT)
-DEFNAME ("SRAND", "srand", "SRand", genNONE, specSRAND) /* UNIX */
-DEFNAME ("STAT", "stat", "Stat", genSTAT, specNONE) /* UNIX */
-DEFNAME ("SUM", "sum", "Sum", genNONE, specSUM) /* F90 */
-DEFNAME ("SYMLNK", "symlnk", "SymLnk", genSYMLNK, specNONE) /* UNIX */
-DEFNAME ("SYSTEM", "system", "System", genSYSTEM, specNONE) /* UNIX */
-DEFNAME ("SYSTEM_CLOCK", "system_clock", "System_Clock", genNONE, specSYSTEM_CLOCK) /* F90 */
-DEFNAME ("TAN", "tan", "Tan", genNONE, specTAN)
-DEFNAME ("TAND", "tand", "TanD", genNONE, specTAND) /* VXT */
-DEFNAME ("TANH", "tanh", "TanH", genNONE, specTANH)
-DEFNAME ("TIME", "time", "Time", genTIME, specNONE) /* UNIX, VXT */
-DEFNAME ("TIME8", "time8", "Time8", genNONE, specTIME8) /* UNIX */
-DEFNAME ("TINY", "tiny", "Tiny", genNONE, specTINY) /* F90 */
-DEFNAME ("TRANSFER", "transfer", "Transfer", genNONE, specTRANSFER) /* F90 */
-DEFNAME ("TRANSPOSE", "transpose", "Transpose", genNONE, specTRANSPOSE) /* F90 */
-DEFNAME ("TRIM", "trim", "Trim", genNONE, specTRIM) /* F90 */
-DEFNAME ("TTYNAM", "ttynam", "TtyNam", genTTYNAM, specNONE) /* UNIX */
-DEFNAME ("UBOUND", "ubound", "UBound", genNONE, specUBOUND) /* F90 */
-DEFNAME ("UMASK", "umask", "UMask", genUMASK, specNONE) /* UNIX */
-DEFNAME ("UNLINK", "unlink", "Unlink", genUNLINK, specNONE) /* UNIX */
-DEFNAME ("UNPACK", "unpack", "Unpack", genNONE, specUNPACK) /* F90 */
-DEFNAME ("VERIFY", "verify", "Verify", genNONE, specVERIFY) /* F90 */
-DEFNAME ("XOR", "xor", "XOr", genNONE, specXOR) /* F2C */
-DEFNAME ("ZABS", "zabs", "ZAbs", genNONE, specZABS) /* F2C */
-DEFNAME ("ZCOS", "zcos", "ZCos", genNONE, specZCOS) /* F2C */
-DEFNAME ("ZEXP", "zexp", "ZExp", genNONE, specZEXP) /* F2C */
-DEFNAME ("ZEXT", "zext", "ZExt", genNONE, specZEXT) /* VXT */
-DEFNAME ("ZLOG", "zlog", "ZLog", genNONE, specZLOG) /* F2C */
-DEFNAME ("ZSIN", "zsin", "ZSin", genNONE, specZSIN) /* F2C */
-DEFNAME ("ZSQRT", "zsqrt", "ZSqRt", genNONE, specZSQRT) /* F2C */
-
-/* Internally generic intrinsics.
-
- Should properly be called "mapped" intrinsics. These are intrinsics
- that map to one or more generally different implementations -- e.g.
- that have differing interpretations depending on the Fortran dialect
- being used. Also, this includes the placeholder intrinsics that
- have no specific versions, but we want to reserve the names for now. */
-
-DEFGEN (CTIME, "CTIME", /* UNIX */
- FFEINTRIN_specCTIME_subr,
- FFEINTRIN_specCTIME_func
- )
-DEFGEN (CHDIR, "CHDIR", /* UNIX */
- FFEINTRIN_specCHDIR_subr,
- FFEINTRIN_specCHDIR_func
- )
-DEFGEN (CHMOD, "CHMOD", /* UNIX */
- FFEINTRIN_specCHMOD_subr,
- FFEINTRIN_specCHMOD_func
- )
-DEFGEN (DTIME, "DTIME", /* UNIX */
- FFEINTRIN_specDTIME_subr,
- FFEINTRIN_specDTIME_func
- )
-DEFGEN (ETIME, "ETIME", /* UNIX */
- FFEINTRIN_specETIME_subr,
- FFEINTRIN_specETIME_func
- )
-DEFGEN (FDATE, "FDATE", /* UNIX */
- FFEINTRIN_specFDATE_subr,
- FFEINTRIN_specFDATE_func
- )
-DEFGEN (FGET, "FGET", /* UNIX */
- FFEINTRIN_specFGET_subr,
- FFEINTRIN_specFGET_func
- )
-DEFGEN (FGETC, "FGETC", /* UNIX */
- FFEINTRIN_specFGETC_subr,
- FFEINTRIN_specFGETC_func
- )
-DEFGEN (FPABSP, "FPABSP", /* F2C */
- FFEINTRIN_specNONE,
- FFEINTRIN_specNONE
- )
-DEFGEN (FPEXPN, "FPEXPN", /* F2C */
- FFEINTRIN_specNONE,
- FFEINTRIN_specNONE
- )
-DEFGEN (FPFRAC, "FPFRAC", /* F2C */
- FFEINTRIN_specNONE,
- FFEINTRIN_specNONE
- )
-DEFGEN (FPMAKE, "FPMAKE", /* F2C */
- FFEINTRIN_specNONE,
- FFEINTRIN_specNONE
- )
-DEFGEN (FPRRSP, "FPRRSP", /* F2C */
- FFEINTRIN_specNONE,
- FFEINTRIN_specNONE
- )
-DEFGEN (FPSCAL, "FPSCAL", /* F2C */
- FFEINTRIN_specNONE,
- FFEINTRIN_specNONE
- )
-DEFGEN (FPUT, "FPUT", /* UNIX */
- FFEINTRIN_specFPUT_subr,
- FFEINTRIN_specFPUT_func
- )
-DEFGEN (FPUTC, "FPUTC", /* UNIX */
- FFEINTRIN_specFPUTC_subr,
- FFEINTRIN_specFPUTC_func
- )
-DEFGEN (FSTAT, "FSTAT", /* UNIX */
- FFEINTRIN_specFSTAT_subr,
- FFEINTRIN_specFSTAT_func
- )
-DEFGEN (FTELL, "FTELL", /* UNIX */
- FFEINTRIN_specFTELL_subr,
- FFEINTRIN_specFTELL_func
- )
-DEFGEN (GETCWD, "GETCWD", /* UNIX */
- FFEINTRIN_specGETCWD_subr,
- FFEINTRIN_specGETCWD_func
- )
-DEFGEN (HOSTNM, "HOSTNM", /* UNIX */
- FFEINTRIN_specHOSTNM_subr,
- FFEINTRIN_specHOSTNM_func
- )
-DEFGEN (IDATE, "IDATE", /* UNIX/VXT */
- FFEINTRIN_specIDATE_unix,
- FFEINTRIN_specIDATE_vxt
- )
-DEFGEN (KILL, "KILL", /* UNIX */
- FFEINTRIN_specKILL_subr,
- FFEINTRIN_specKILL_func
- )
-DEFGEN (LINK, "LINK", /* UNIX */
- FFEINTRIN_specLINK_subr,
- FFEINTRIN_specLINK_func
- )
-DEFGEN (LSTAT, "LSTAT", /* UNIX */
- FFEINTRIN_specLSTAT_subr,
- FFEINTRIN_specLSTAT_func
- )
-DEFGEN (RENAME, "RENAME", /* UNIX */
- FFEINTRIN_specRENAME_subr,
- FFEINTRIN_specRENAME_func
- )
-DEFGEN (SECOND, "SECOND", /* UNIX/CRAY */
- FFEINTRIN_specSECOND_func,
- FFEINTRIN_specSECOND_subr
- )
-DEFGEN (SIGNAL, "SIGNAL", /* UNIX */
- FFEINTRIN_specSIGNAL_subr,
- FFEINTRIN_specSIGNAL_func
- )
-DEFGEN (STAT, "STAT", /* UNIX */
- FFEINTRIN_specSTAT_subr,
- FFEINTRIN_specSTAT_func
- )
-DEFGEN (SYMLNK, "SYMLNK", /* UNIX */
- FFEINTRIN_specSYMLNK_subr,
- FFEINTRIN_specSYMLNK_func
- )
-DEFGEN (SYSTEM, "SYSTEM", /* UNIX */
- FFEINTRIN_specSYSTEM_subr,
- FFEINTRIN_specSYSTEM_func
- )
-DEFGEN (TIME, "TIME", /* UNIX/VXT */
- FFEINTRIN_specTIME_unix,
- FFEINTRIN_specTIME_vxt
- )
-DEFGEN (TTYNAM, "TTYNAM", /* UNIX/VXT */
- FFEINTRIN_specTTYNAM_subr,
- FFEINTRIN_specTTYNAM_func
- )
-DEFGEN (UMASK, "UMASK", /* UNIX */
- FFEINTRIN_specUMASK_subr,
- FFEINTRIN_specUMASK_func
- )
-DEFGEN (UNLINK, "UNLINK", /* UNIX */
- FFEINTRIN_specUNLINK_subr,
- FFEINTRIN_specUNLINK_func
- )
-DEFGEN (NONE, "none",
- FFEINTRIN_specNONE,
- FFEINTRIN_specNONE
- )
-
-/* Specific intrinsic information.
-
- Currently this list starts with the list of F77-standard intrinsics
- in alphabetical order, then continues with the list of all other
- intrinsics.
-
- The second boolean argument specifies whether the intrinsic is
- allowed by the standard to be passed as an actual argument. */
-
-DEFSPEC (ABS,
- "ABS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impABS
- )
-DEFSPEC (ACOS,
- "ACOS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impACOS
- )
-DEFSPEC (AIMAG,
- "AIMAG",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impAIMAG
- )
-DEFSPEC (AINT,
- "AINT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impAINT
- )
-DEFSPEC (ALOG,
- "ALOG",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impALOG
- )
-DEFSPEC (ALOG10,
- "ALOG10",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impALOG10
- )
-DEFSPEC (AMAX0,
- "AMAX0",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impAMAX0
- )
-DEFSPEC (AMAX1,
- "AMAX1",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impAMAX1
- )
-DEFSPEC (AMIN0,
- "AMIN0",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impAMIN0
- )
-DEFSPEC (AMIN1,
- "AMIN1",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impAMIN1
- )
-DEFSPEC (AMOD,
- "AMOD",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impAMOD
- )
-DEFSPEC (ANINT,
- "ANINT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impANINT
- )
-DEFSPEC (ASIN,
- "ASIN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impASIN
- )
-DEFSPEC (ATAN,
- "ATAN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impATAN
- )
-DEFSPEC (ATAN2,
- "ATAN2",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impATAN2
- )
-DEFSPEC (CABS,
- "CABS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCABS
- )
-DEFSPEC (CCOS,
- "CCOS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCCOS
- )
-DEFSPEC (CEXP,
- "CEXP",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCEXP
- )
-DEFSPEC (CHAR,
- "CHAR",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCHAR
- )
-DEFSPEC (CLOG,
- "CLOG",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCLOG
- )
-DEFSPEC (CMPLX,
- "CMPLX",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCMPLX
- )
-DEFSPEC (CONJG,
- "CONJG",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCONJG
- )
-DEFSPEC (COS,
- "COS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCOS
- )
-DEFSPEC (COSH,
- "COSH",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCOSH
- )
-DEFSPEC (CSIN,
- "CSIN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCSIN
- )
-DEFSPEC (CSQRT,
- "CSQRT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impCSQRT
- )
-DEFSPEC (DABS,
- "DABS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDABS
- )
-DEFSPEC (DACOS,
- "DACOS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDACOS
- )
-DEFSPEC (DASIN,
- "DASIN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDASIN
- )
-DEFSPEC (DATAN,
- "DATAN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDATAN
- )
-DEFSPEC (DATAN2,
- "DATAN2",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDATAN2
- )
-DEFSPEC (DBLE,
- "DBLE",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDBLE
- )
-DEFSPEC (DCOS,
- "DCOS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDCOS
- )
-DEFSPEC (DCOSH,
- "DCOSH",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDCOSH
- )
-DEFSPEC (DDIM,
- "DDIM",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDDIM
- )
-DEFSPEC (DEXP,
- "DEXP",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDEXP
- )
-DEFSPEC (DIM,
- "DIM",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDIM
- )
-DEFSPEC (DINT,
- "DINT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDINT
- )
-DEFSPEC (DLOG,
- "DLOG",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDLOG
- )
-DEFSPEC (DLOG10,
- "DLOG10",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDLOG10
- )
-DEFSPEC (DMAX1,
- "DMAX1",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDMAX1
- )
-DEFSPEC (DMIN1,
- "DMIN1",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDMIN1
- )
-DEFSPEC (DMOD,
- "DMOD",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDMOD
- )
-DEFSPEC (DNINT,
- "DNINT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDNINT
- )
-DEFSPEC (DPROD,
- "DPROD",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDPROD
- )
-DEFSPEC (DSIGN,
- "DSIGN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDSIGN
- )
-DEFSPEC (DSIN,
- "DSIN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDSIN
- )
-DEFSPEC (DSINH,
- "DSINH",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDSINH
- )
-DEFSPEC (DSQRT,
- "DSQRT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDSQRT
- )
-DEFSPEC (DTAN,
- "DTAN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDTAN
- )
-DEFSPEC (DTANH,
- "DTANH",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impDTANH
- )
-DEFSPEC (EXP,
- "EXP",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impEXP
- )
-DEFSPEC (FLOAT,
- "FLOAT",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impFLOAT
- )
-DEFSPEC (IABS,
- "IABS",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impIABS
- )
-DEFSPEC (ICHAR,
- "ICHAR",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impICHAR
- )
-DEFSPEC (IDIM,
- "IDIM",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impIDIM
- )
-DEFSPEC (IDINT,
- "IDINT",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impIDINT
- )
-DEFSPEC (IDNINT,
- "IDNINT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impIDNINT
- )
-DEFSPEC (IFIX,
- "IFIX",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impIFIX
- )
-DEFSPEC (INDEX,
- "INDEX",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impINDEX
- )
-DEFSPEC (INT,
- "INT",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impINT
- )
-DEFSPEC (ISIGN,
- "ISIGN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impISIGN
- )
-DEFSPEC (LEN,
- "LEN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impLEN
- )
-DEFSPEC (LGE,
- "LGE",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impLGE
- )
-DEFSPEC (LGT,
- "LGT",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impLGT
- )
-DEFSPEC (LLE,
- "LLE",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impLLE
- )
-DEFSPEC (LLT,
- "LLT",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impLLT
- )
-DEFSPEC (LOG,
- "LOG",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impLOG
- )
-DEFSPEC (LOG10,
- "LOG10",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impLOG10
- )
-DEFSPEC (MAX,
- "MAX",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impMAX
- )
-DEFSPEC (MAX0,
- "MAX0",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impMAX0
- )
-DEFSPEC (MAX1,
- "MAX1",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impMAX1
- )
-DEFSPEC (MIN,
- "MIN",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impMIN
- )
-DEFSPEC (MIN0,
- "MIN0",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impMIN0
- )
-DEFSPEC (MIN1,
- "MIN1",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impMIN1
- )
-DEFSPEC (MOD,
- "MOD",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impMOD
- )
-DEFSPEC (NINT,
- "NINT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impNINT
- )
-DEFSPEC (REAL,
- "REAL",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impREAL
- )
-DEFSPEC (SIGN,
- "SIGN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impSIGN
- )
-DEFSPEC (SIN,
- "SIN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impSIN
- )
-DEFSPEC (SINH,
- "SINH",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impSINH
- )
-DEFSPEC (SNGL,
- "SNGL",
- FALSE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impSNGL
- )
-DEFSPEC (SQRT,
- "SQRT",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impSQRT
- )
-DEFSPEC (TAN,
- "TAN",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impTAN
- )
-DEFSPEC (TANH,
- "TANH",
- TRUE,
- FFEINTRIN_familyF77,
- FFEINTRIN_impTANH
- )
-
-DEFSPEC (ABORT,
- "ABORT",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impABORT
- )
-DEFSPEC (ACCESS,
- "ACCESS",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impACCESS
-)
-DEFSPEC (ACHAR,
- "ACHAR",
- FALSE,
- FFEINTRIN_familyASC,
- FFEINTRIN_impACHAR
- )
-DEFSPEC (ACOSD,
- "ACOSD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ADJUSTL,
- "ADJUSTL",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ADJUSTR,
- "ADJUSTR",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (AIMAX0,
- "AIMAX0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (AIMIN0,
- "AIMIN0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (AJMAX0,
- "AJMAX0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (AJMIN0,
- "AJMIN0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ALARM,
- "ALARM",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impALARM
- )
-DEFSPEC (ALL,
- "ALL",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ALLOCATED,
- "ALLOCATED",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (AND,
- "AND",
- FALSE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impAND
- )
-DEFSPEC (ANY,
- "ANY",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ASIND,
- "ASIND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ASSOCIATED,
- "ASSOCIATED",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ATAN2D,
- "ATAN2D",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ATAND,
- "ATAND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (BESJ0,
- "BESJ0",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impBESJ0
-)
-DEFSPEC (BESJ1,
- "BESJ1",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impBESJ1
-)
-DEFSPEC (BESJN,
- "BESJN",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impBESJN
-)
-DEFSPEC (BESY0,
- "BESY0",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impBESY0
-)
-DEFSPEC (BESY1,
- "BESY1",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impBESY1
-)
-DEFSPEC (BESYN,
- "BESYN",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impBESYN
-)
-DEFSPEC (BIT_SIZE,
- "BIT_SIZE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impBIT_SIZE
- )
-DEFSPEC (BITEST,
- "BITEST",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (BJTEST,
- "BJTEST",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (BTEST,
- "BTEST",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impBTEST
- )
-DEFSPEC (CDABS,
- "CDABS",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impCDABS
- )
-DEFSPEC (CDCOS,
- "CDCOS",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impCDCOS
- )
-DEFSPEC (CDEXP,
- "CDEXP",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impCDEXP
- )
-DEFSPEC (CDLOG,
- "CDLOG",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impCDLOG
- )
-DEFSPEC (CDSIN,
- "CDSIN",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impCDSIN
- )
-DEFSPEC (CDSQRT,
- "CDSQRT",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impCDSQRT
- )
-DEFSPEC (CEILING,
- "CEILING",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (CHDIR_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impCHDIR_func
-)
-DEFSPEC (CHDIR_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impCHDIR_subr
-)
-DEFSPEC (CHMOD_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impCHMOD_func
-)
-DEFSPEC (CHMOD_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impCHMOD_subr
-)
-DEFSPEC (COMPLEX,
- "COMPLEX",
- FALSE,
- FFEINTRIN_familyGNU,
- FFEINTRIN_impCOMPLEX
- )
-DEFSPEC (COSD,
- "COSD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (COUNT,
- "COUNT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (CSHIFT,
- "CSHIFT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (CPU_TIME,
- "CPU_TIME",
- FALSE,
- FFEINTRIN_familyF95,
- FFEINTRIN_impCPU_TIME
-)
-DEFSPEC (CTIME_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impCTIME_func
-)
-DEFSPEC (CTIME_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impCTIME_subr
-)
-DEFSPEC (DACOSD,
- "DACOSD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DASIND,
- "DASIND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DATAN2D,
- "DATAN2D",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DATAND,
- "DATAND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DATE,
- "DATE",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impDATE
-)
-DEFSPEC (DATE_AND_TIME,
- "DATE_AND_TIME",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impDATE_AND_TIME
- )
-DEFSPEC (DBESJ0,
- "DBESJ0",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDBESJ0
-)
-DEFSPEC (DBESJ1,
- "DBESJ1",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDBESJ1
-)
-DEFSPEC (DBESJN,
- "DBESJN",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDBESJN
-)
-DEFSPEC (DBESY0,
- "DBESY0",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDBESY0
-)
-DEFSPEC (DBESY1,
- "DBESY1",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDBESY1
-)
-DEFSPEC (DBESYN,
- "DBESYN",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDBESYN
-)
-DEFSPEC (DBLEQ,
- "DBLEQ",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DCMPLX,
- "DCMPLX",
- FALSE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impDCMPLX
- )
-DEFSPEC (DCONJG,
- "DCONJG",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impDCONJG
- )
-DEFSPEC (DCOSD,
- "DCOSD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DERF,
- "DERF",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDERF
- )
-DEFSPEC (DERFC,
- "DERFC",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDERFC
- )
-DEFSPEC (DFLOAT,
- "DFLOAT",
- FALSE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impDFLOAT
- )
-DEFSPEC (DFLOTI,
- "DFLOTI",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DFLOTJ,
- "DFLOTJ",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DIGITS,
- "DIGITS",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DIMAG,
- "DIMAG",
- TRUE,
- FFEINTRIN_familyFVZ,
- FFEINTRIN_impDIMAG
- )
-DEFSPEC (DOT_PRODUCT,
- "DOT_PRODUCT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DREAL,
- "DREAL",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impDREAL
- )
-DEFSPEC (DSIND,
- "DSIND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DTAND,
- "DTAND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (DTIME_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impDTIME_func
-)
-DEFSPEC (DTIME_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impDTIME_subr
-)
-DEFSPEC (EOSHIFT,
- "EOSHIFT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (EPSILON,
- "EPSILON",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ERF,
- "ERF",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impERF
- )
-DEFSPEC (ERFC,
- "ERFC",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impERFC
- )
-DEFSPEC (ETIME_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impETIME_func
-)
-DEFSPEC (ETIME_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impETIME_subr
-)
-DEFSPEC (EXIT,
- "EXIT",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impEXIT
- )
-DEFSPEC (EXPONENT,
- "EXPONENT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (FDATE_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFDATE_func
-)
-DEFSPEC (FDATE_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFDATE_subr
-)
-DEFSPEC (FGET_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impFGET_func
-)
-DEFSPEC (FGET_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFGET_subr
-)
-DEFSPEC (FGETC_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impFGETC_func
-)
-DEFSPEC (FGETC_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFGETC_subr
-)
-DEFSPEC (FLOATI,
- "FLOATI",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (FLOATJ,
- "FLOATJ",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (FLOOR,
- "FLOOR",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (FLUSH,
- "FLUSH",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFLUSH
- )
-DEFSPEC (FNUM,
- "FNUM",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFNUM
-)
-DEFSPEC (FPUT_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impFPUT_func
-)
-DEFSPEC (FPUT_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFPUT_subr
-)
-DEFSPEC (FPUTC_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impFPUTC_func
-)
-DEFSPEC (FPUTC_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFPUTC_subr
-)
-DEFSPEC (FRACTION,
- "FRACTION",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (FSEEK,
- "FSEEK",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFSEEK
- )
-DEFSPEC (FSTAT_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFSTAT_func
-)
-DEFSPEC (FSTAT_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFSTAT_subr
-)
-DEFSPEC (FTELL_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFTELL_func
- )
-DEFSPEC (FTELL_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impFTELL_subr
- )
-DEFSPEC (GERROR,
- "GERROR",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGERROR
-)
-DEFSPEC (GETARG,
- "GETARG",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETARG
- )
-DEFSPEC (GETCWD_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETCWD_func
-)
-DEFSPEC (GETCWD_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETCWD_subr
-)
-DEFSPEC (GETENV,
- "GETENV",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETENV
- )
-DEFSPEC (GETGID,
- "GETGID",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETGID
-)
-DEFSPEC (GETLOG,
- "GETLOG",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETLOG
-)
-DEFSPEC (GETPID,
- "GETPID",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETPID
-)
-DEFSPEC (GETUID,
- "GETUID",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGETUID
-)
-DEFSPEC (GMTIME,
- "GMTIME",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impGMTIME
-)
-DEFSPEC (HOSTNM_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impHOSTNM_func
-)
-DEFSPEC (HOSTNM_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impHOSTNM_subr
-)
-DEFSPEC (HUGE,
- "HUGE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IACHAR,
- "IACHAR",
- FALSE,
- FFEINTRIN_familyASC,
- FFEINTRIN_impIACHAR
- )
-DEFSPEC (IAND,
- "IAND",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impIAND
- )
-DEFSPEC (IARGC,
- "IARGC",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impIARGC
- )
-DEFSPEC (IBCLR,
- "IBCLR",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impIBCLR
- )
-DEFSPEC (IBITS,
- "IBITS",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impIBITS
- )
-DEFSPEC (IBSET,
- "IBSET",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impIBSET
- )
-DEFSPEC (IDATE_unix,
- "UNIX",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impIDATE_unix
-)
-DEFSPEC (IDATE_vxt,
- "VXT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impIDATE_vxt
-)
-DEFSPEC (IEOR,
- "IEOR",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impIEOR
- )
-DEFSPEC (IERRNO,
- "IERRNO",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impIERRNO
-)
-DEFSPEC (IIABS,
- "IIABS",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIAND,
- "IIAND",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIBCLR,
- "IIBCLR",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIBITS,
- "IIBITS",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIBSET,
- "IIBSET",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIDIM,
- "IIDIM",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIDINT,
- "IIDINT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIDNNT,
- "IIDNNT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIEOR,
- "IIEOR",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIFIX,
- "IIFIX",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IINT,
- "IINT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIOR,
- "IIOR",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIQINT,
- "IIQINT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IIQNNT,
- "IIQNNT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IISHFT,
- "IISHFT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IISHFTC,
- "IISHFTC",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IISIGN,
- "IISIGN",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IMAG,
- "IMAG",
- FALSE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impIMAGPART
- )
-DEFSPEC (IMAGPART,
- "IMAGPART",
- FALSE,
- FFEINTRIN_familyGNU,
- FFEINTRIN_impIMAGPART
- )
-DEFSPEC (IMAX0,
- "IMAX0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IMAX1,
- "IMAX1",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IMIN0,
- "IMIN0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IMIN1,
- "IMIN1",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (IMOD,
- "IMOD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ININT,
- "ININT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (INOT,
- "INOT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (INT2,
- "INT2",
- FALSE,
- FFEINTRIN_familyGNU,
- FFEINTRIN_impINT2
- )
-DEFSPEC (INT8,
- "INT8",
- FALSE,
- FFEINTRIN_familyGNU,
- FFEINTRIN_impINT8
- )
-DEFSPEC (IOR,
- "IOR",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impIOR
- )
-DEFSPEC (IRAND,
- "IRAND",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impIRAND
-)
-DEFSPEC (ISATTY,
- "ISATTY",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impISATTY
-)
-DEFSPEC (ISHFT,
- "ISHFT",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impISHFT
- )
-DEFSPEC (ISHFTC,
- "ISHFTC",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impISHFTC
- )
-DEFSPEC (ITIME,
- "ITIME",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impITIME
-)
-DEFSPEC (IZEXT,
- "IZEXT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIABS,
- "JIABS",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIAND,
- "JIAND",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIBCLR,
- "JIBCLR",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIBITS,
- "JIBITS",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIBSET,
- "JIBSET",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIDIM,
- "JIDIM",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIDINT,
- "JIDINT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIDNNT,
- "JIDNNT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIEOR,
- "JIEOR",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIFIX,
- "JIFIX",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JINT,
- "JINT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIOR,
- "JIOR",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIQINT,
- "JIQINT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JIQNNT,
- "JIQNNT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JISHFT,
- "JISHFT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JISHFTC,
- "JISHFTC",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JISIGN,
- "JISIGN",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JMAX0,
- "JMAX0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JMAX1,
- "JMAX1",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JMIN0,
- "JMIN0",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JMIN1,
- "JMIN1",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JMOD,
- "JMOD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JNINT,
- "JNINT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JNOT,
- "JNOT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (JZEXT,
- "JZEXT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (KILL_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impKILL_func
-)
-DEFSPEC (KILL_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impKILL_subr
-)
-DEFSPEC (KIND,
- "KIND",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (LBOUND,
- "LBOUND",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (LINK_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impLINK_func
-)
-DEFSPEC (LINK_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impLINK_subr
-)
-DEFSPEC (LEN_TRIM,
- "LEN_TRIM",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impLNBLNK
- )
-DEFSPEC (LNBLNK,
- "LNBLNK",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impLNBLNK
-)
-DEFSPEC (LOC,
- "LOC",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impLOC
- )
-DEFSPEC (LOGICAL,
- "LOGICAL",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (LONG,
- "LONG",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impLONG
- )
-DEFSPEC (LSHIFT,
- "LSHIFT",
- FALSE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impLSHIFT
- )
-DEFSPEC (LSTAT_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impLSTAT_func
-)
-DEFSPEC (LSTAT_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impLSTAT_subr
-)
-DEFSPEC (LTIME,
- "LTIME",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impLTIME
-)
-DEFSPEC (MATMUL,
- "MATMUL",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MAXEXPONENT,
- "MAXEXPONENT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MAXLOC,
- "MAXLOC",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MAXVAL,
- "MAXVAL",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MCLOCK,
- "MCLOCK",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impMCLOCK
-)
-DEFSPEC (MCLOCK8,
- "MCLOCK8",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impMCLOCK8
-)
-DEFSPEC (MERGE,
- "MERGE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MINEXPONENT,
- "MINEXPONENT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MINLOC,
- "MINLOC",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MINVAL,
- "MINVAL",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MODULO,
- "MODULO",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (MVBITS,
- "MVBITS",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impMVBITS
- )
-DEFSPEC (NEAREST,
- "NEAREST",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (NOT,
- "NOT",
- FALSE,
- FFEINTRIN_familyMIL,
- FFEINTRIN_impNOT
- )
-DEFSPEC (OR,
- "OR",
- FALSE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impOR
- )
-DEFSPEC (PACK,
- "PACK",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (PERROR,
- "PERROR",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impPERROR
-)
-DEFSPEC (PRECISION,
- "PRECISION",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (PRESENT,
- "PRESENT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (PRODUCT,
- "PRODUCT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QABS,
- "QABS",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QACOS,
- "QACOS",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QACOSD,
- "QACOSD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QASIN,
- "QASIN",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QASIND,
- "QASIND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QATAN,
- "QATAN",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QATAN2,
- "QATAN2",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QATAN2D,
- "QATAN2D",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QATAND,
- "QATAND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QCOS,
- "QCOS",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QCOSD,
- "QCOSD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QCOSH,
- "QCOSH",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QDIM,
- "QDIM",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QEXP,
- "QEXP",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QEXT,
- "QEXT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QEXTD,
- "QEXTD",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QFLOAT,
- "QFLOAT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QINT,
- "QINT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QLOG,
- "QLOG",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QLOG10,
- "QLOG10",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QMAX1,
- "QMAX1",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QMIN1,
- "QMIN1",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QMOD,
- "QMOD",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QNINT,
- "QNINT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QSIGN,
- "QSIGN",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QSIN,
- "QSIN",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QSIND,
- "QSIND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QSINH,
- "QSINH",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QSQRT,
- "QSQRT",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QTAN,
- "QTAN",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QTAND,
- "QTAND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (QTANH,
- "QTANH",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (RADIX,
- "RADIX",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (RAND,
- "RAND",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impRAND
-)
-DEFSPEC (RANDOM_NUMBER,
- "RANDOM_NUMBER",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (RANDOM_SEED,
- "RANDOM_SEED",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (RANGE,
- "RANGE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (REALPART,
- "REALPART",
- FALSE,
- FFEINTRIN_familyGNU,
- FFEINTRIN_impREALPART
- )
-DEFSPEC (RENAME_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impRENAME_func
-)
-DEFSPEC (RENAME_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impRENAME_subr
-)
-DEFSPEC (REPEAT,
- "REPEAT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (RESHAPE,
- "RESHAPE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (RRSPACING,
- "RRSPACING",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (RSHIFT,
- "RSHIFT",
- FALSE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impRSHIFT
- )
-DEFSPEC (SCALE,
- "SCALE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SCAN,
- "SCAN",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SECNDS,
- "SECNDS",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impSECNDS
-)
-DEFSPEC (SECOND_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSECOND_func
-)
-DEFSPEC (SECOND_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSECOND_subr
-)
-DEFSPEC (SEL_INT_KIND,
- "SEL_INT_KIND",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SEL_REAL_KIND,
- "SEL_REAL_KIND",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SET_EXPONENT,
- "SET_EXPONENT",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SHAPE,
- "SHAPE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SHORT,
- "SHORT",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSHORT
- )
-DEFSPEC (SIGNAL_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impSIGNAL_func
- )
-DEFSPEC (SIGNAL_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSIGNAL_subr
- )
-DEFSPEC (SIND,
- "SIND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SLEEP,
- "SLEEP",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSLEEP
-)
-DEFSPEC (SNGLQ,
- "SNGLQ",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SPACING,
- "SPACING",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SPREAD,
- "SPREAD",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SRAND,
- "SRAND",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSRAND
-)
-DEFSPEC (STAT_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSTAT_func
-)
-DEFSPEC (STAT_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSTAT_subr
-)
-DEFSPEC (SUM,
- "SUM",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (SYMLNK_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impSYMLNK_func
-)
-DEFSPEC (SYMLNK_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSYMLNK_subr
-)
-DEFSPEC (SYSTEM_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impSYSTEM_func
- )
-DEFSPEC (SYSTEM_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impSYSTEM_subr
- )
-DEFSPEC (SYSTEM_CLOCK,
- "SYSTEM_CLOCK",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impSYSTEM_CLOCK
- )
-DEFSPEC (TAND,
- "TAND",
- TRUE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (TIME8,
- "UNIX",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impTIME8
-)
-DEFSPEC (TIME_unix,
- "UNIX",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impTIME_unix
-)
-DEFSPEC (TIME_vxt,
- "VXT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impTIME_vxt
-)
-DEFSPEC (TINY,
- "TINY",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (TRANSFER,
- "TRANSFER",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (TRANSPOSE,
- "TRANSPOSE",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (TRIM,
- "TRIM",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (TTYNAM_func,
- "function",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impTTYNAM_func
-)
-DEFSPEC (TTYNAM_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impTTYNAM_subr
-)
-DEFSPEC (UBOUND,
- "UBOUND",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (UMASK_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impUMASK_func
-)
-DEFSPEC (UMASK_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impUMASK_subr
-)
-DEFSPEC (UNLINK_func,
- "function",
- FALSE,
- FFEINTRIN_familyBADU77,
- FFEINTRIN_impUNLINK_func
-)
-DEFSPEC (UNLINK_subr,
- "subroutine",
- FALSE,
- FFEINTRIN_familyF2U,
- FFEINTRIN_impUNLINK_subr
-)
-DEFSPEC (UNPACK,
- "UNPACK",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (VERIFY,
- "VERIFY",
- FALSE,
- FFEINTRIN_familyF90,
- FFEINTRIN_impNONE
- )
-DEFSPEC (XOR,
- "XOR",
- FALSE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impXOR
- )
-DEFSPEC (ZABS,
- "ZABS",
- TRUE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impCDABS
- )
-DEFSPEC (ZCOS,
- "ZCOS",
- TRUE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impCDCOS
- )
-DEFSPEC (ZEXP,
- "ZEXP",
- TRUE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impCDEXP
- )
-DEFSPEC (ZEXT,
- "ZEXT",
- FALSE,
- FFEINTRIN_familyVXT,
- FFEINTRIN_impNONE
- )
-DEFSPEC (ZLOG,
- "ZLOG",
- TRUE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impCDLOG
- )
-DEFSPEC (ZSIN,
- "ZSIN",
- TRUE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impCDSIN
- )
-DEFSPEC (ZSQRT,
- "ZSQRT",
- TRUE,
- FFEINTRIN_familyF2C,
- FFEINTRIN_impCDSQRT
- )
-DEFSPEC (NONE,
- "none",
- FALSE,
- FFEINTRIN_familyNONE,
- FFEINTRIN_impNONE
- )
-
-/* Intrinsic implementations ordered in two sections:
- F77, then extensions; secondarily, alphabetical
- ordering. */
-
-/* The DEFIMP macro specifies the following fields for an intrinsic:
-
- CODE -- The internal name for this intrinsic; `FFEINTRIN_imp'
- prepends this to form the `enum' name.
-
- NAME -- The textual name to use when printing information on
- this intrinsic.
-
- GFRTDIRECT -- The run-time library routine that is suitable for
- a call to implement a *direct* invocation of the
- intrinsic (e.g. `ABS(10)').
-
- GFRTF2C -- The run-time library routine that is suitable for
- passing as an argument to a procedure that will
- invoke the argument as an EXTERNAL procedure, when
- f2c calling conventions will be used (e.g.
- `CALL FOO(ABS)', when FOO compiled with -ff2c).
-
- GFRTGNU -- The run-time library routine that is suitable for
- passing as an argument to a procedure that will
- invoke the argument as an EXTERNAL procedure, when
- GNU calling conventions will be used (e.g.
- `CALL FOO(ABS)', when FOO compiled with -fno-f2c).
-
- CONTROL -- A control string, described below.
-
- The DEFIMPY macro specifies the above, plus:
-
- Y2KBAD -- TRUE if the intrinsic is known to be non-Y2K-compliant,
- FALSE if it is known to be Y2K-compliant. (In terms of
- interface and libg2c implementation.)
-
-*/
-
-/* The control string has the following format:
-
- <return-type>:<arglist-info>:[<argitem-info>,...]
-
- <return-type> is:
-
- <return-base-type><return-kind-type>[<return-modifier>]
-
- <return-base-type> is:
-
- - Subroutine
- A Character
- C Complex
- I Integer
- L Logical
- R Real
- B Boolean (I or L), decided by co-operand list (COL)
- F Floating-point (C or R), decided by COL
- N Numeric (C, I, or R), decided by co-operand list (COL)
- S Scalar numeric (I or R), decided by COL, which may be COMPLEX
-
- <return-kind-type> is:
-
- - Subroutine
- = Decided by COL
- 1 (Default)
- 2 (Twice the size of 1)
- 3 (Same size as CHARACTER*1)
- 4 (Twice the size of 2)
- 6 (Twice the size as 3)
- 7 (Same size as `char *')
- C Like 1 (F77), except (F90), if COL is COMPLEX, uses kind type of COL
-
- <return-modifier> is:
-
- * Valid for <return-base-type> of `A' only, means program may
- declare any length for return value, default being (*)
-
- <arglist-info> is:
-
- <COL-spec>
-
- <COL-spec> is:
-
- - No COL (return-base-type and return-kind-type must be definitive)
- * All arguments form COL (must have more than one argument)
- n Argument n (0 for first arg, 1 for second, etc.) forms COL
-
- <argitem-info> is:
-
- <name>=[<optionality>]<arg-base-type><arg-kind-type>[<arg-len>][<arg-rank>][<arg-extra>]
-
- <name> is the standard keyword name for the argument.
-
- <optionality> is:
-
- ? Argument is optional
- ! Like ?, but argument must be omitted if previous arg was COMPLEX
- + One or more of these arguments must be specified
- * Zero or more of these arguments must be specified
- n Numbered names for arguments, one or more must be specified
- p Like n, but two or more must be specified
-
- <arg-base-type> is:
-
- - Any is valid (arg-kind-type is 0)
- A Character*(*)
- C Complex
- I Integer
- L Logical
- R Real
- B Boolean (I or L)
- F Floating-point (C or R)
- N Numeric (C, I, or R)
- S Scalar numeric (I or R)
- g GOTO label (alternate-return form of CALL) (arg-kind-type is 0)
- s Signal handler (INTEGER FUNCTION, SUBROUTINE or dummy/global
- default INTEGER variable) (arg-kind-type is 0)
-
- <arg-kind-type> is:
-
- * Any is valid
- 1 (Default)
- 2 (Twice the size of 1)
- 3 (Same size as CHARACTER*1)
- 4 (Twice the size of 2)
- 6 (Twice the size as 3)
- A Same as first argument
- N Not wider than the default kind
-
- <arg-len> is:
-
- (Default) CHARACTER*(*)
- [n] CHARACTER*n
-
- <arg-rank> is:
-
- (default) Rank-0 (variable or array element)
- (n) Rank-1 array n elements long
- & Any (arg-extra is &)
-
- <arg-extra> is:
-
- (default) Arg is INTENT(IN)
- i Arg's attributes are all that matter (inquiry function)
- w Arg is INTENT(OUT)
- x Arg is INTENT(INOUT)
- & Arg can have its address taken (LOC(), for example)
-
-*/
-
-DEFIMP (ABS, "ABS", ,ABS,, "S=:0:A=N*")
-DEFIMP (ACOS, "ACOS", L_ACOS,ACOS,, "R=:0:X=R*")
-DEFIMP (AIMAG, "AIMAG", ,AIMAG,, "RC:0:Z=C*")
-DEFIMP (AINT, "AINT", ,AINT,, "R=:0:A=R*")
-DEFIMP (ALOG, "ALOG", L_LOG,ALOG,, "R1:-:X=R1")
-DEFIMP (ALOG10, "ALOG10", L_LOG10,ALOG10,,"R1:-:X=R1")
-DEFIMP (AMAX0, "AMAX0", ,,, "R1:*:A=pI1")
-DEFIMP (AMAX1, "AMAX1", ,,, "R1:*:A=pR1")
-DEFIMP (AMIN0, "AMIN0", ,,, "R1:*:A=pI1")
-DEFIMP (AMIN1, "AMIN1", ,,, "R1:*:A=pR1")
-DEFIMP (AMOD, "AMOD", L_FMOD,AMOD,, "R1:*:A=R1,P=R1")
-DEFIMP (ANINT, "ANINT", ,ANINT,, "R=:0:A=R*")
-DEFIMP (ASIN, "ASIN", L_ASIN,ASIN,, "R=:0:X=R*")
-DEFIMP (ATAN, "ATAN", L_ATAN,ATAN,, "R=:0:X=R*")
-DEFIMP (ATAN2, "ATAN2", L_ATAN2,ATAN2,, "R=:*:Y=R*,X=R*")
-DEFIMP (CABS, "CABS", ,CABS,, "R1:-:A=C1")
-DEFIMP (CCOS, "CCOS", ,CCOS,, "C1:-:X=C1")
-DEFIMP (CEXP, "CEXP", ,CEXP,, "C1:-:X=C1")
-DEFIMP (CHAR, "CHAR", ,,, "A1:-:I=I*")
-DEFIMP (CLOG, "CLOG", ,CLOG,, "C1:-:X=C1")
-DEFIMP (CMPLX, "CMPLX", ,,, "C1:*:X=N*,Y=!S*")
-DEFIMP (CONJG, "CONJG", ,CONJG,, "C=:0:Z=C*")
-DEFIMP (COS, "COS", L_COS,COS,, "F=:0:X=F*")
-DEFIMP (COSH, "COSH", L_COSH,COSH,, "R=:0:X=R*")
-DEFIMP (CSIN, "CSIN", ,CSIN,, "C1:-:X=C1")
-DEFIMP (CSQRT, "CSQRT", ,CSQRT,, "C1:-:X=C1")
-DEFIMP (DABS, "DABS", ,DABS,, "R2:-:A=R2")
-DEFIMP (DACOS, "DACOS", L_ACOS,DACOS,, "R2:-:X=R2")
-DEFIMP (DASIN, "DASIN", L_ASIN,DASIN,, "R2:-:X=R2")
-DEFIMP (DATAN, "DATAN", L_ATAN,DATAN,, "R2:-:X=R2")
-DEFIMP (DATAN2, "DATAN2", L_ATAN2,DATAN2,,"R2:*:Y=R2,X=R2")
-DEFIMP (DBLE, "DBLE", ,,, "R2:-:A=N*")
-DEFIMP (DCMPLX, "DCMPLX", ,,, "C2:*:X=N*,Y=!S*")
-DEFIMP (DCOS, "DCOS", L_COS,DCOS,, "R2:-:X=R2")
-DEFIMP (DCOSH, "DCOSH", L_COSH,DCOSH,, "R2:-:X=R2")
-DEFIMP (DDIM, "DDIM", ,DDIM,, "R2:*:X=R2,Y=R2")
-DEFIMP (DEXP, "DEXP", L_EXP,DEXP,, "R2:-:X=R2")
-DEFIMP (DIM, "DIM", ,DIM,, "S=:*:X=S*,Y=S*")
-DEFIMP (DINT, "DINT", ,DINT,, "R2:-:A=R2")
-DEFIMP (DLOG, "DLOG", L_LOG,DLOG,, "R2:-:X=R2")
-DEFIMP (DLOG10, "DLOG10", L_LOG10,DLOG10,,"R2:-:X=R2")
-DEFIMP (DMAX1, "DMAX1", ,,, "R2:*:A=pR2")
-DEFIMP (DMIN1, "DMIN1", ,,, "R2:*:A=pR2")
-DEFIMP (DMOD, "DMOD", L_FMOD,DMOD,, "R2:*:A=R2,P=R2")
-DEFIMP (DNINT, "DNINT", ,DNINT,, "R2:-:A=R2")
-DEFIMP (DPROD, "DPROD", ,DPROD,, "R2:*:X=R1,Y=R1")
-DEFIMP (DSIGN, "DSIGN", ,DSIGN,, "R2:*:A=R2,B=R2")
-DEFIMP (DSIN, "DSIN", L_SIN,DSIN,, "R2:-:X=R2")
-DEFIMP (DSINH, "DSINH", L_SINH,DSINH,, "R2:-:X=R2")
-DEFIMP (DSQRT, "DSQRT", L_SQRT,DSQRT,, "R2:-:X=R2")
-DEFIMP (DTAN, "DTAN", L_TAN,DTAN,, "R2:-:X=R2")
-DEFIMP (DTANH, "DTANH", L_TANH,DTANH,, "R2:-:X=R2")
-DEFIMP (EXP, "EXP", L_EXP,EXP,, "F=:0:X=F*")
-DEFIMP (FLOAT, "FLOAT", ,,, "R1:-:A=I*")
-DEFIMP (IABS, "IABS", ,IABS,IABS, "I1:-:A=I1")
-DEFIMP (ICHAR, "ICHAR", ,,, "I1:-:C=A*")
-DEFIMP (IDIM, "IDIM", ,IDIM,IDIM, "I1:*:X=I1,Y=I1")
-DEFIMP (IDINT, "IDINT", ,,, "I1:-:A=R2")
-DEFIMP (IDNINT, "IDNINT", ,IDNINT,IDNINT, "I1:-:A=R2")
-DEFIMP (IFIX, "IFIX", ,,, "I1:-:A=R1")
-DEFIMP (INDEX, "INDEX", ,INDEX,INDEX, "I1:*:String=A*,Substring=A*")
-DEFIMP (INT, "INT", ,,, "I1:-:A=N*")
-DEFIMP (ISIGN, "ISIGN", ,ISIGN,ISIGN, "I1:*:A=I1,B=I1")
-DEFIMP (LEN, "LEN", ,LEN,LEN, "I1:-:String=A*i")
-DEFIMP (LGE, "LGE", ,LGE,LGE, "L1:*:String_A=A1,String_B=A1")
-DEFIMP (LGT, "LGT", ,LGT,LGT, "L1:*:String_A=A1,String_B=A1")
-DEFIMP (LLE, "LLE", ,LLE,LLE, "L1:*:String_A=A1,String_B=A1")
-DEFIMP (LLT, "LLT", ,LLT,LLT, "L1:*:String_A=A1,String_B=A1")
-DEFIMP (LOG, "LOG", L_LOG,ALOG,, "F=:0:X=F*")
-DEFIMP (LOG10, "LOG10", L_LOG10,ALOG10,,"R=:0:X=R*")
-DEFIMP (MAX, "MAX", ,,, "S=:*:A=pS*")
-DEFIMP (MIN, "MIN", ,,, "S=:*:A=pS*")
-DEFIMP (MAX0, "MAX0", ,,, "I1:*:A=pI1")
-DEFIMP (MAX1, "MAX1", ,,, "I1:*:A=pR1")
-DEFIMP (MIN0, "MIN0", ,,, "I1:*:A=pI1")
-DEFIMP (MIN1, "MIN1", ,,, "I1:*:A=pR1")
-DEFIMP (MOD, "MOD", ,MOD,MOD, "S=:*:A=S*,P=S*")
-DEFIMP (NINT, "NINT", ,NINT,NINT, "I1:-:A=R*")
-DEFIMP (REAL, "REAL", ,,, "RC:0:A=N*")
-DEFIMP (SIGN, "SIGN", ,SIGN,, "S=:*:A=S*,B=S*")
-DEFIMP (SIN, "SIN", L_SIN,SIN,, "F=:0:X=F*")
-DEFIMP (SINH, "SINH", L_SINH,SINH,, "R=:0:X=R*")
-DEFIMP (SNGL, "SNGL", ,,, "R1:-:A=R2")
-DEFIMP (SQRT, "SQRT", L_SQRT,SQRT,, "F=:0:X=F*")
-DEFIMP (TAN, "TAN", L_TAN,TAN,, "R=:0:X=R*")
-DEFIMP (TANH, "TANH", L_TANH,TANH,, "R=:0:X=R*")
-
-DEFIMP (ABORT, "ABORT", ABORT,,, "--:-:")
-DEFIMP (ACCESS, "ACCESS", ACCESS,,, "I1:-:Name=A1,Mode=A1")
-DEFIMP (ACHAR, "ACHAR", ,,, "A1:-:I=I*")
-DEFIMP (ALARM, "ALARM", ALARM,,, "--:-:Seconds=I*,Handler=s*,Status=?I1w")
-DEFIMP (AND, "AND", ,,, "B=:*:I=B*,J=B*")
-DEFIMP (BESJ0, "BESJ0", L_BESJ0,,, "R=:0:X=R*")
-DEFIMP (BESJ1, "BESJ1", L_BESJ1,,, "R=:0:X=R*")
-DEFIMP (BESJN, "BESJN", L_BESJN,,, "R=:1:N=IN,X=R*")
-DEFIMP (BESY0, "BESY0", L_BESY0,,, "R=:0:X=R*")
-DEFIMP (BESY1, "BESY1", L_BESY1,,, "R=:0:X=R*")
-DEFIMP (BESYN, "BESYN", L_BESYN,,, "R=:1:N=IN,X=R*")
-DEFIMP (BIT_SIZE, "BIT_SIZE", ,,, "I=:0:I=I*i")
-DEFIMP (BTEST, "BTEST", ,,, "L1:*:I=I*,Pos=I*")
-DEFIMP (CDABS, "CDABS", ,CDABS,, "R2:-:A=C2")
-DEFIMP (CDCOS, "CDCOS", ,CDCOS,, "C2:-:X=C2")
-DEFIMP (CDEXP, "CDEXP", ,CDEXP,, "C2:-:X=C2")
-DEFIMP (CDLOG, "CDLOG", ,CDLOG,, "C2:-:X=C2")
-DEFIMP (CDSIN, "CDSIN", ,CDSIN,, "C2:-:X=C2")
-DEFIMP (CDSQRT, "CDSQRT", ,CDSQRT,, "C2:-:X=C2")
-DEFIMP (CHDIR_func, "CHDIR_func", CHDIR,,, "I1:-:Dir=A1")
-DEFIMP (CHDIR_subr, "CHDIR_subr", CHDIR,,, "--:-:Dir=A1,Status=?I1w")
-DEFIMP (CHMOD_func, "CHMOD_func", CHMOD,,, "I1:-:Name=A1,Mode=A1")
-DEFIMP (CHMOD_subr, "CHMOD_subr", CHMOD,,, "--:-:Name=A1,Mode=A1,Status=?I1w")
-DEFIMP (COMPLEX, "COMPLEX", ,,, "C=:*:Real=S*,Imag=S*")
-DEFIMP (CPU_TIME, "CPU_TIME", SECOND,,, "--:-:Seconds=R*w")
-DEFIMP (CTIME_func, "CTIME_func", CTIME,,, "A1*:-:STime=I*")
-DEFIMP (CTIME_subr, "CTIME_subr", CTIME,,, "--:-:STime=I*,Result=A1w")
-DEFIMPY (DATE, "DATE", DATE,,, "--:-:Date=A1w", TRUE)
-DEFIMP (DATE_AND_TIME, "DATE_AND_TIME", DATE_AND_TIME,,, "--:-:Date=A1w,Time=?A1w,Zone=?A1w,Values=?I1(8)w")
-DEFIMP (DBESJ0, "DBESJ0", L_BESJ0,,, "R2:-:X=R2")
-DEFIMP (DBESJ1, "DBESJ1", L_BESJ1,,, "R2:-:X=R2")
-DEFIMP (DBESJN, "DBESJN", L_BESJN,,, "R2:-:N=IN,X=R2")
-DEFIMP (DBESY0, "DBESY0", L_BESY0,,, "R2:-:X=R2")
-DEFIMP (DBESY1, "DBESY1", L_BESY1,,, "R2:-:X=R2")
-DEFIMP (DBESYN, "DBESYN", L_BESYN,,, "R2:-:N=IN,X=R2")
-DEFIMP (DCONJG, "DCONJG", ,DCONJG,, "C2:-:Z=C2")
-DEFIMP (DERF, "DERF", L_ERF,DERF,, "R2:-:X=R2")
-DEFIMP (DERFC, "DERFC", L_ERFC,DERFC,, "R2:-:X=R2")
-DEFIMP (DFLOAT, "DFLOAT", ,,, "R2:-:A=I*")
-DEFIMP (DIMAG, "DIMAG", ,DIMAG,, "R2:-:Z=C2")
-DEFIMP (DREAL, "DREAL", ,,, "R2:-:A=N*")
-DEFIMP (DTIME_func, "DTIME_func", DTIME,,, "R1:-:TArray=R1(2)w")
-DEFIMP (DTIME_subr, "DTIME_subr", DTIME,,, "--:-:TArray=R1(2)w,Result=R1w")
-DEFIMP (ERF, "ERF", L_ERF,ERF,, "R=:0:X=R*")
-DEFIMP (ERFC, "ERFC", L_ERFC,ERFC,, "R=:0:X=R*")
-DEFIMP (ETIME_func, "ETIME_func", ETIME,,, "R1:-:TArray=R1(2)w")
-DEFIMP (ETIME_subr, "ETIME_subr", ETIME,,, "--:-:TArray=R1(2)w,Result=R1w")
-DEFIMP (EXIT, "EXIT", EXIT,,, "--:-:Status=?IN")
-DEFIMP (FDATE_func, "FDATE_func", FDATE,,, "A1*:-:")
-DEFIMP (FDATE_subr, "FDATE_subr", FDATE,,, "--:-:Date=A1w")
-DEFIMP (FGET_func, "FGET_func", FGET,,, "I1:-:C=A1w")
-DEFIMP (FGET_subr, "FGET_subr", FGET,,, "--:-:C=A1w,Status=?I1w")
-DEFIMP (FGETC_func, "FGETC_func", FGETC,,, "I1:-:Unit=I*,C=A1w")
-DEFIMP (FGETC_subr, "FGETC_subr", FGETC,,, "--:-:Unit=I*,C=A1w,Status=?I1w")
-DEFIMP (FLUSH, "FLUSH", ,,, "--:-:Unit=?I*")
-DEFIMP (FNUM, "FNUM", FNUM,,, "I1:-:Unit=I*")
-DEFIMP (FPUT_func, "FPUT_func", FPUT,,, "I1:-:C=A1")
-DEFIMP (FPUT_subr, "FPUT_subr", FPUT,,, "--:-:C=A1,Status=?I1w")
-DEFIMP (FPUTC_func, "FPUTC_func", FPUTC,,, "I1:-:Unit=I*,C=A1")
-DEFIMP (FPUTC_subr, "FPUTC_subr", FPUTC,,, "--:-:Unit=I*,C=A1,Status=?I1w")
-DEFIMP (FSEEK, "FSEEK", FSEEK,,, "--:-:Unit=I*,Offset=I*,Whence=I*,ErrLab=?g*")
-DEFIMP (FSTAT_func, "FSTAT_func", FSTAT,,, "I1:-:Unit=I*,SArray=I1(13)w")
-DEFIMP (FSTAT_subr, "FSTAT_subr", FSTAT,,, "--:-:Unit=I*,SArray=I1(13)w,Status=?I1w")
-DEFIMP (FTELL_func, "FTELL_func", FTELL,,, "I1:-:Unit=I*")
-DEFIMP (FTELL_subr, "FTELL_subr", FTELL,,, "--:-:Unit=I*,Offset=I1w")
-DEFIMP (GERROR, "GERROR", GERROR,,, "--:-:Message=A1w")
-DEFIMP (GETARG, "GETARG", GETARG,,, "--:-:Pos=IN,Value=A1w")
-DEFIMP (GETCWD_func, "GETCWD_func", GETCWD,,, "I1:-:Name=A1w")
-DEFIMP (GETCWD_subr, "GETCWD_subr", GETCWD,,, "--:-:Name=A1w,Status=?I1w")
-DEFIMP (GETGID, "GETGID", GETGID,,, "I1:-:")
-DEFIMP (GETLOG, "GETLOG", GETLOG,,, "--:-:Login=A1w")
-DEFIMP (GETPID, "GETPID", GETPID,,, "I1:-:")
-DEFIMP (GETUID, "GETUID", GETUID,,, "I1:-:")
-DEFIMP (GETENV, "GETENV", GETENV,,, "--:-:Name=A1,Value=A1w")
-DEFIMP (GMTIME, "GMTIME", GMTIME,,, "--:-:STime=I1,TArray=I1(9)w")
-DEFIMP (HOSTNM_func, "HOSTNM_func", HOSTNM,,, "I1:-:Name=A1w")
-DEFIMP (HOSTNM_subr, "HOSTNM_subr", HOSTNM,,, "--:-:Name=A1w,Status=?I1w")
-DEFIMP (IACHAR, "IACHAR", ,,, "I1:-:C=A*")
-DEFIMP (IAND, "IAND", ,,, "I=:*:I=I*,J=I*")
-DEFIMP (IARGC, "IARGC", IARGC,,, "I1:-:")
-DEFIMP (IBCLR, "IBCLR", ,,, "I=:0:I=I*,Pos=I*")
-DEFIMP (IBITS, "IBITS", ,,, "I=:0:I=I*,Pos=I*,Len=I*")
-DEFIMP (IBSET, "IBSET", ,,, "I=:0:I=I*,Pos=I*")
-DEFIMP (IDATE_unix, "IDATE_unix", IDATE,,, "--:-:TArray=I1(3)w")
-DEFIMPY (IDATE_vxt, "IDATE_vxt", VXTIDATE,,, "--:-:M=I1w,D=I1w,Y=I1w", TRUE)
-DEFIMP (IEOR, "IEOR", ,,, "I=:*:I=I*,J=I*")
-DEFIMP (IOR, "IOR", ,,, "I=:*:I=I*,J=I*")
-DEFIMP (IERRNO, "IERRNO", IERRNO,,, "I1:-:")
-DEFIMP (IMAGPART, "IMAGPART", ,,, "R=:0:Z=C*")
-DEFIMP (INT2, "INT2", ,,, "I6:-:A=N*")
-DEFIMP (INT8, "INT8", ,,, "I2:-:A=N*")
-DEFIMP (IRAND, "IRAND", IRAND,,, "I1:-:Flag=?I*")
-DEFIMP (ISATTY, "ISATTY", ISATTY,,, "L1:-:Unit=I*")
-DEFIMP (ISHFT, "ISHFT", ,,, "I=:0:I=I*,Shift=I*")
-DEFIMP (ISHFTC, "ISHFTC", ,,, "I=:0:I=I*,Shift=I*,Size=I*")
-DEFIMP (ITIME, "ITIME", ITIME,,, "--:-:TArray=I1(3)w")
-DEFIMP (KILL_func, "KILL_func", KILL,,, "I1:-:Pid=I*,Signal=I*")
-DEFIMP (KILL_subr, "KILL_subr", KILL,,, "--:-:Pid=I*,Signal=I*,Status=?I1w")
-DEFIMP (LINK_func, "LINK_func", LINK,,, "I1:-:Path1=A1,Path2=A1")
-DEFIMP (LINK_subr, "LINK_subr", LINK,,, "--:-:Path1=A1,Path2=A1,Status=?I1w")
-DEFIMP (LNBLNK, "LNBLNK", LNBLNK,,, "I1:-:String=A1")
-DEFIMP (LONG, "LONG", ,,, "I1:-:A=I6")
-DEFIMP (LSTAT_func, "LSTAT_func", LSTAT,,, "I1:-:File=A1,SArray=I1(13)w")
-DEFIMP (LSTAT_subr, "LSTAT_subr", LSTAT,,, "--:-:File=A1,SArray=I1(13)w,Status=?I1w")
-DEFIMP (LTIME, "LTIME", LTIME,,, "--:-:STime=I1,TArray=I1(9)w")
-DEFIMP (LOC, "LOC", ,,, "I7:-:Entity=-*&&")
-DEFIMP (LSHIFT, "LSHIFT", ,,, "I=:0:I=I*,Shift=I*")
-DEFIMP (MCLOCK, "MCLOCK", MCLOCK,,, "I1:-:")
-DEFIMP (MCLOCK8, "MCLOCK8", MCLOCK,,, "I2:-:")
-DEFIMP (MVBITS, "MVBITS", ,,, "--:-:From=I*,FromPos=I*,Len=I*,TO=IAx,ToPos=I*")
-DEFIMP (NOT, "NOT", ,,, "I=:0:I=I*")
-DEFIMP (OR, "OR", ,,, "B=:*:I=B*,J=B*")
-DEFIMP (PERROR, "PERROR", PERROR,,, "--:-:String=A1")
-DEFIMP (RAND, "RAND", RAND,,, "R1:-:Flag=?I*")
-DEFIMP (REALPART, "REALPART", ,,, "R=:0:Z=C*")
-DEFIMP (RENAME_func, "RENAME_func", RENAME,,, "I1:-:Path1=A1,Path2=A1")
-DEFIMP (RENAME_subr, "RENAME_subr", RENAME,,, "--:-:Path1=A1,Path2=A1,Status=?I1w")
-DEFIMP (RSHIFT, "RSHIFT", ,,, "I=:0:I=I*,Shift=I*")
-DEFIMP (SECNDS, "SECNDS", SECNDS,,, "R1:-:T=R1")
-DEFIMP (SECOND_func, "SECOND_func", SECOND,SECOND,, "R1:-:")
-DEFIMP (SECOND_subr, "SECOND_subr", SECOND,,, "--:-:Seconds=R*w")
-DEFIMP (SHORT, "SHORT", ,,, "I6:-:A=I*")
-DEFIMP (SIGNAL_func, "SIGNAL_func", L_SIGNAL,,, "I7:-:Number=I*,Handler=s*")
-DEFIMP (SIGNAL_subr, "SIGNAL_subr", L_SIGNAL,,, "--:-:Number=I*,Handler=s*,Status=?I7w")
-DEFIMP (SLEEP, "SLEEP", SLEEP,,, "--:-:Seconds=I1")
-DEFIMP (SRAND, "SRAND", SRAND,,, "--:-:Seed=I*")
-DEFIMP (STAT_func, "STAT_func", STAT,,, "I1:-:File=A1,SArray=I1(13)w")
-DEFIMP (STAT_subr, "STAT_subr", STAT,,, "--:-:File=A1,SArray=I1(13)w,Status=?I1w")
-DEFIMP (SYMLNK_func, "SYMLNK_func", SYMLNK,,, "I1:-:Path1=A1,Path2=A1")
-DEFIMP (SYMLNK_subr, "SYMLNK_subr", SYMLNK,,, "--:-:Path1=A1,Path2=A1,Status=?I1w")
-DEFIMP (SYSTEM_func, "SYSTEM_func", SYSTEM,SYSTEM,SYSTEM,"I1:-:Command=A1")
-DEFIMP (SYSTEM_subr, "SYSTEM_subr", SYSTEM,,, "--:-:Command=A1,Status=?I1w")
-DEFIMP (SYSTEM_CLOCK, "SYSTEM_CLOCK", SYSTEM_CLOCK,,, "--:-:Count=I1w,Rate=?I1w,Max=?I1w")
-DEFIMP (TIME8, "TIME8", TIME,,, "I2:-:")
-DEFIMP (TIME_unix, "TIME_unix", TIME,,, "I1:-:")
-DEFIMP (TIME_vxt, "TIME_vxt", VXTTIME,,, "--:-:Time=A1[8]w")
-DEFIMP (TTYNAM_func, "TTYNAM_func", TTYNAM,,, "A1*:-:Unit=I*")
-DEFIMP (TTYNAM_subr, "TTYNAM_subr", TTYNAM,,, "--:-:Unit=I*,Name=A1w")
-DEFIMP (UMASK_func, "UMASK_func", UMASK,,, "I1:-:Mask=I*")
-DEFIMP (UMASK_subr, "UMASK_subr", UMASK,,, "--:-:Mask=I*,Old=?I1w")
-DEFIMP (UNLINK_func, "UNLINK_func", UNLINK,,, "I1:-:File=A1")
-DEFIMP (UNLINK_subr, "UNLINK_subr", UNLINK,,, "--:-:File=A1,Status=?I1w")
-DEFIMP (XOR, "XOR", ,,, "B=:*:I=B*,J=B*")
-DEFIMP (NONE, "none", ,,, "")
+++ /dev/null
-/* intrin.h -- Public interface for intrin.c
- Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
-*/
-
-#ifndef GCC_F_INTRIN_H
-#define GCC_F_INTRIN_H
-
-#ifndef FFEINTRIN_DOC
-#define FFEINTRIN_DOC 0 /* 1 means intrinsic documentation only (intdoc.c). */
-#endif
-
-typedef enum
- {
- FFEINTRIN_familyNONE, /* Not in any family. */
- FFEINTRIN_familyF77, /* ANSI FORTRAN 77. */
- FFEINTRIN_familyGNU, /* GNU Fortran intrinsics. */
- FFEINTRIN_familyF2C, /* f2c intrinsics. */
- FFEINTRIN_familyF90, /* Fortran 90. */
- FFEINTRIN_familyF95 = FFEINTRIN_familyF90,
- FFEINTRIN_familyVXT, /* VAX/VMS FORTRAN. */
- FFEINTRIN_familyMIL, /* MIL STD 1753 (MVBITS, etc), in mil, vxt, and f90. */
- FFEINTRIN_familyASC, /* ASCII-related (ACHAR, IACHAR), both f2c and f90. */
- FFEINTRIN_familyFVZ, /* in both f2c and VAX/VMS FORTRAN. */
- FFEINTRIN_familyF2U, /* libf2c/libU77 UNIX system intrinsics. */
- FFEINTRIN_familyBADU77, /* libU77 UNIX system intrinsics with bad form. */
- FFEINTRIN_family
- } ffeintrinFamily;
-
-typedef enum
- {
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2) FFEINTRIN_gen ## CODE,
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
- FFEINTRIN_gen
- } ffeintrinGen;
-
-typedef enum
- {
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) FFEINTRIN_spec ## CODE,
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
- FFEINTRIN_spec
- } ffeintrinSpec;
-
-typedef enum
- {
-#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
-#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
-#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
- FFEINTRIN_imp ## CODE,
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
- FFEINTRIN_imp ## CODE,
-#include "intrin.def"
-#undef DEFNAME
-#undef DEFGEN
-#undef DEFSPEC
-#undef DEFIMP
-#undef DEFIMPY
- FFEINTRIN_imp
- } ffeintrinImp;
-
-#if !FFEINTRIN_DOC
-
-#include "bld.h"
-#include "info.h"
-
-ffeinfoBasictype ffeintrin_basictype (ffeintrinSpec spec);
-ffeintrinFamily ffeintrin_family (ffeintrinSpec spec);
-void ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t);
-void ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
- bool *check_intrin, ffelexToken t);
-ffecomGfrt ffeintrin_gfrt_direct (ffeintrinImp imp);
-ffecomGfrt ffeintrin_gfrt_indirect (ffeintrinImp imp);
-void ffeintrin_init_0 (void);
-#define ffeintrin_init_1()
-#define ffeintrin_init_2()
-#define ffeintrin_init_3()
-#define ffeintrin_init_4()
-bool ffeintrin_is_actualarg (ffeintrinSpec spec);
-bool ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
- ffeintrinGen *gen, ffeintrinSpec *spec,
- ffeintrinImp *imp);
-bool ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec);
-ffeinfoKindtype ffeintrin_kindtype (ffeintrinSpec spec);
-const char *ffeintrin_name_generic (ffeintrinGen gen);
-const char *ffeintrin_name_implementation (ffeintrinImp imp);
-const char *ffeintrin_name_specific (ffeintrinSpec spec);
-ffeIntrinsicState ffeintrin_state_family (ffeintrinFamily family);
-#define ffeintrin_terminate_0()
-#define ffeintrin_terminate_1()
-#define ffeintrin_terminate_2()
-#define ffeintrin_terminate_3()
-#define ffeintrin_terminate_4()
-
-#endif /* !FFEINTRIN_DOC */
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_INTRIN_H */
+++ /dev/null
-@c Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004
-@c Free Software Foundation, Inc.
-@c This is part of the G77 manual.
-@c For copying conditions, see the file g77.texi.
-
-@ignore
-@c man begin COPYRIGHT
-Copyright @copyright{} 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004
-Free Software Foundation, Inc.
-
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.2 or
-any later version published by the Free Software Foundation; with the
-Invariant Sections being ``GNU General Public License'' and ``Funding
-Free Software'', the Front-Cover texts being (a) (see below), and with
-the Back-Cover Texts being (b) (see below). A copy of the license is
-included in the gfdl(7) man page.
-
-(a) The FSF's Front-Cover Text is:
-
- A GNU Manual
-
-(b) The FSF's Back-Cover Text is:
-
- You have freedom to copy and modify this GNU Manual, like GNU
- software. Copies published by the Free Software Foundation raise
- funds for GNU development.
-@c man end
-@c Set file name and title for the man page.
-@setfilename g77
-@settitle GNU project Fortran 77 compiler.
-@c man begin SYNOPSIS
-g77 [@option{-c}|@option{-S}|@option{-E}]
- [@option{-g}] [@option{-pg}] [@option{-O}@var{level}]
- [@option{-W}@var{warn}@dots{}] [@option{-pedantic}]
- [@option{-I}@var{dir}@dots{}] [@option{-L}@var{dir}@dots{}]
- [@option{-D}@var{macro}[=@var{defn}]@dots{}] [@option{-U}@var{macro}]
- [@option{-f}@var{option}@dots{}] [@option{-m}@var{machine-option}@dots{}]
- [@option{-o} @var{outfile}] @var{infile}@dots{}
-
-Only the most useful options are listed here; see below for the
-remainder.
-@c man end
-@c man begin SEEALSO
-gpl(7), gfdl(7), fsf-funding(7),
-cpp(1), gcov(1), gcc(1), as(1), ld(1), gdb(1), adb(1), dbx(1), sdb(1)
-and the Info entries for @file{gcc}, @file{cpp}, @file{g77}, @file{as},
-@file{ld}, @file{binutils} and @file{gdb}.
-@c man end
-@c man begin BUGS
-For instructions on reporting bugs, see
-@w{@uref{http://gcc.gnu.org/bugs.html}}. Use of the @command{gccbug}
-script to report bugs is recommended.
-@c man end
-@c man begin AUTHOR
-See the Info entry for @command{g77} for contributors to GCC and G77@.
-@c man end
-@end ignore
-
-@node Invoking G77
-@chapter GNU Fortran Command Options
-@cindex GNU Fortran command options
-@cindex command options
-@cindex options, GNU Fortran command
-
-@c man begin DESCRIPTION
-
-The @command{g77} command supports all the options supported by the
-@command{gcc} command.
-@xref{Invoking GCC,,GCC Command Options,gcc,Using the GNU Compiler
-Collection (GCC)}, for information
-on the non-Fortran-specific aspects of the @command{gcc} command (and,
-therefore, the @command{g77} command).
-
-@cindex options, negative forms
-@cindex negative forms of options
-All @command{gcc} and @command{g77} options
-are accepted both by @command{g77} and by @command{gcc}
-(as well as any other drivers built at the same time,
-such as @command{g++}),
-since adding @command{g77} to the @command{gcc} distribution
-enables acceptance of @command{g77} options
-by all of the relevant drivers.
-
-In some cases, options have positive and negative forms;
-the negative form of @option{-ffoo} would be @option{-fno-foo}.
-This manual documents only one of these two forms, whichever
-one is not the default.
-
-@c man end
-
-@menu
-* Option Summary:: Brief list of all @command{g77} options,
- without explanations.
-* Overall Options:: Controlling the kind of output:
- an executable, object files, assembler files,
- or preprocessed source.
-* Shorthand Options:: Options that are shorthand for other options.
-* Fortran Dialect Options:: Controlling the variant of Fortran language
- compiled.
-* Warning Options:: How picky should the compiler be?
-* Debugging Options:: Symbol tables, measurements, and debugging dumps.
-* Optimize Options:: How much optimization?
-* Preprocessor Options:: Controlling header files and macro definitions.
- Also, getting dependency information for Make.
-* Directory Options:: Where to find header files and libraries.
- Where to find the compiler executable files.
-* Code Gen Options:: Specifying conventions for function calls, data layout
- and register usage.
-* Environment Variables:: Env vars that affect GNU Fortran.
-@end menu
-
-@node Option Summary
-@section Option Summary
-
-@c man begin OPTIONS
-
-Here is a summary of all the options specific to GNU Fortran, grouped
-by type. Explanations are in the following sections.
-
-@table @emph
-@item Overall Options
-@xref{Overall Options,,Options Controlling the Kind of Output}.
-@gccoptlist{
--fversion -fset-g77-defaults -fno-silent}
-
-@item Shorthand Options
-@xref{Shorthand Options}.
-@gccoptlist{
--ff66 -fno-f66 -ff77 -fno-f77 -fno-ugly}
-
-@item Fortran Language Options
-@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect}.
-@gccoptlist{
--ffree-form -fno-fixed-form -ff90 @gol
--fvxt -fdollar-ok -fno-backslash @gol
--fno-ugly-args -fno-ugly-assign -fno-ugly-assumed @gol
--fugly-comma -fugly-complex -fugly-init -fugly-logint @gol
--fonetrip -ftypeless-boz @gol
--fintrin-case-initcap -fintrin-case-upper @gol
--fintrin-case-lower -fintrin-case-any @gol
--fmatch-case-initcap -fmatch-case-upper @gol
--fmatch-case-lower -fmatch-case-any @gol
--fsource-case-upper -fsource-case-lower @gol
--fsource-case-preserve @gol
--fsymbol-case-initcap -fsymbol-case-upper @gol
--fsymbol-case-lower -fsymbol-case-any @gol
--fcase-strict-upper -fcase-strict-lower @gol
--fcase-initcap -fcase-upper -fcase-lower -fcase-preserve @gol
--ff2c-intrinsics-delete -ff2c-intrinsics-hide @gol
--ff2c-intrinsics-disable -ff2c-intrinsics-enable @gol
--fbadu77-intrinsics-delete -fbadu77-intrinsics-hide @gol
--fbadu77-intrinsics-disable -fbadu77-intrinsics-enable @gol
--ff90-intrinsics-delete -ff90-intrinsics-hide @gol
--ff90-intrinsics-disable -ff90-intrinsics-enable @gol
--fgnu-intrinsics-delete -fgnu-intrinsics-hide @gol
--fgnu-intrinsics-disable -fgnu-intrinsics-enable @gol
--fmil-intrinsics-delete -fmil-intrinsics-hide @gol
--fmil-intrinsics-disable -fmil-intrinsics-enable @gol
--funix-intrinsics-delete -funix-intrinsics-hide @gol
--funix-intrinsics-disable -funix-intrinsics-enable @gol
--fvxt-intrinsics-delete -fvxt-intrinsics-hide @gol
--fvxt-intrinsics-disable -fvxt-intrinsics-enable @gol
--ffixed-line-length-@var{n} -ffixed-line-length-none}
-
-@item Warning Options
-@xref{Warning Options,,Options to Request or Suppress Warnings}.
-@gccoptlist{
--fsyntax-only -pedantic -pedantic-errors -fpedantic @gol
--w -Wno-globals -Wimplicit -Wunused -Wuninitialized @gol
--Wall -Wsurprising @gol
--Werror -W}
-
-@item Debugging Options
-@xref{Debugging Options,,Options for Debugging Your Program or GCC}.
-@gccoptlist{
--g}
-
-@item Optimization Options
-@xref{Optimize Options,,Options that Control Optimization}.
-@gccoptlist{
--malign-double @gol
--ffloat-store -fforce-mem -fforce-addr -fno-inline @gol
--ffast-math -fstrength-reduce -frerun-cse-after-loop @gol
--funsafe-math-optimizations -ffinite-math-only -fno-trapping-math @gol
--fexpensive-optimizations -fdelayed-branch @gol
--fschedule-insns -fschedule-insn2 -fcaller-saves @gol
--funroll-loops -funroll-all-loops @gol
--fno-move-all-movables -fno-reduce-all-givs @gol
--fno-rerun-loop-opt}
-
-@item Directory Options
-@xref{Directory Options,,Options for Directory Search}.
-@gccoptlist{
--I@var{dir} -I-}
-
-@item Code Generation Options
-@xref{Code Gen Options,,Options for Code Generation Conventions}.
-@gccoptlist{
--fno-automatic -finit-local-zero -fno-f2c @gol
--ff2c-library -fno-underscoring -fno-ident @gol
--fpcc-struct-return -freg-struct-return @gol
--fshort-double -fno-common -fpack-struct @gol
--fzeros -fno-second-underscore @gol
--femulate-complex @gol
--falias-check -fargument-alias @gol
--fargument-noalias -fno-argument-noalias-global @gol
--fno-globals -fflatten-arrays @gol
--fbounds-check -ffortran-bounds-check}
-@end table
-
-@c man end
-
-@menu
-* Overall Options:: Controlling the kind of output:
- an executable, object files, assembler files,
- or preprocessed source.
-* Shorthand Options:: Options that are shorthand for other options.
-* Fortran Dialect Options:: Controlling the variant of Fortran language
- compiled.
-* Warning Options:: How picky should the compiler be?
-* Debugging Options:: Symbol tables, measurements, and debugging dumps.
-* Optimize Options:: How much optimization?
-* Preprocessor Options:: Controlling header files and macro definitions.
- Also, getting dependency information for Make.
-* Directory Options:: Where to find header files and libraries.
- Where to find the compiler executable files.
-* Code Gen Options:: Specifying conventions for function calls, data layout
- and register usage.
-@end menu
-
-@node Overall Options
-@section Options Controlling the Kind of Output
-@cindex overall options
-@cindex options, overall
-
-@c man begin OPTIONS
-
-Compilation can involve as many as four stages: preprocessing, code
-generation (often what is really meant by the term ``compilation''),
-assembly, and linking, always in that order. The first three
-stages apply to an individual source file, and end by producing an
-object file; linking combines all the object files (those newly
-compiled, and those specified as input) into an executable file.
-
-@cindex file name suffix
-@cindex suffixes, file name
-@cindex file name extension
-@cindex extensions, file name
-@cindex file type
-@cindex types, file
-For any given input file, the file name suffix determines what kind of
-program is contained in the file---that is, the language in which the
-program is written is generally indicated by the suffix.
-Suffixes specific to GNU Fortran are listed below.
-@xref{Overall Options,,Options Controlling the Kind of
-Output,gcc,Using the GNU Compiler Collection (GCC)}, for
-information on suffixes recognized by GCC.
-
-@table @gcctabopt
-@cindex .f filename suffix
-@cindex .for filename suffix
-@cindex .FOR filename suffix
-@item @var{file}.f
-@item @var{file}.for
-@item @var{file}.FOR
-Fortran source code that should not be preprocessed.
-
-Such source code cannot contain any preprocessor directives, such
-as @code{#include}, @code{#define}, @code{#if}, and so on.
-
-You can force @samp{.f} files to be preprocessed by @command{cpp} by using
-@option{-x f77-cpp-input}.
-@xref{LEX}.
-
-@cindex preprocessor
-@cindex C preprocessor
-@cindex cpp preprocessor
-@cindex Fortran preprocessor
-@cindex cpp program
-@cindex programs, cpp
-@cindex .F filename suffix
-@cindex .fpp filename suffix
-@cindex .FPP filename suffix
-@item @var{file}.F
-@item @var{file}.fpp
-@item @var{file}.FPP
-Fortran source code that must be preprocessed (by the C preprocessor
-@command{cpp}, which is part of GCC).
-
-Note that preprocessing is not extended to the contents of
-files included by the @code{INCLUDE} directive---the @code{#include}
-preprocessor directive must be used instead.
-
-@cindex Ratfor preprocessor
-@cindex programs, @command{ratfor}
-@cindex @samp{.r} filename suffix
-@cindex @command{ratfor}
-@item @var{file}.r
-Ratfor source code, which must be preprocessed by the @command{ratfor}
-command, which is available separately (as it is not yet part of the GNU
-Fortran distribution).
-A public domain version in C is at
-@uref{http://sepwww.stanford.edu/sep/prof/ratfor.shar.2}.
-@end table
-
-UNIX users typically use the @file{@var{file}.f} and @file{@var{file}.F}
-nomenclature.
-Users of other operating systems, especially those that cannot
-distinguish upper-case
-letters from lower-case letters in their file names, typically use
-the @file{@var{file}.for} and @file{@var{file}.fpp} nomenclature.
-
-@cindex #define
-@cindex #include
-@cindex #if
-Use of the preprocessor @command{cpp} allows use of C-like
-constructs such as @code{#define} and @code{#include}, but can
-lead to unexpected, even mistaken, results due to Fortran's source file
-format.
-It is recommended that use of the C preprocessor
-be limited to @code{#include} and, in
-conjunction with @code{#define}, only @code{#if} and related directives,
-thus avoiding in-line macro expansion entirely.
-This recommendation applies especially
-when using the traditional fixed source form.
-With free source form,
-fewer unexpected transformations are likely to happen, but use of
-constructs such as Hollerith and character constants can nevertheless
-present problems, especially when these are continued across multiple
-source lines.
-These problems result, primarily, from differences between the way
-such constants are interpreted by the C preprocessor and by a Fortran
-compiler.
-
-Another example of a problem that results from using the C preprocessor
-is that a Fortran comment line that happens to contain any
-characters ``interesting'' to the C preprocessor,
-such as a backslash at the end of the line,
-is not recognized by the preprocessor as a comment line,
-so instead of being passed through ``raw'',
-the line is edited according to the rules for the preprocessor.
-For example, the backslash at the end of the line is removed,
-along with the subsequent newline, resulting in the next
-line being effectively commented out---unfortunate if that
-line is a non-comment line of important code!
-
-@emph{Note:} The @option{-traditional} and @option{-undef} flags are supplied
-to @command{cpp} by default, to help avoid unpleasant surprises.
-@xref{Preprocessor Options,,Options Controlling the Preprocessor,
-gcc,Using the GNU Compiler Collection (GCC)}.
-This means that ANSI C preprocessor features (such as the @samp{#}
-operator) aren't available, and only variables in the C reserved
-namespace (generally, names with a leading underscore) are liable to
-substitution by C predefines.
-Thus, if you want to do system-specific
-tests, use, for example, @samp{#ifdef __linux__} rather than @samp{#ifdef linux}.
-Use the @option{-v} option to see exactly how the preprocessor is invoked.
-
-@cindex /*
-Unfortunately, the @option{-traditional} flag will not avoid an error from
-anything that @command{cpp} sees as an unterminated C comment, such as:
-@smallexample
-C Some Fortran compilers accept /* as starting
-C an inline comment.
-@end smallexample
-@xref{Trailing Comment}.
-
-The following options that affect overall processing are recognized
-by the @command{g77} and @command{gcc} commands in a GNU Fortran installation:
-
-@table @gcctabopt
-@cindex -fversion option
-@cindex options, -fversion
-@cindex printing version information
-@cindex version information, printing
-@cindex consistency checks
-@cindex internal consistency checks
-@cindex checks, of internal consistency
-@item -fversion
-Ensure that the @command{g77} version of the compiler phase is reported,
-if run,
-and, starting in @code{egcs} version 1.1,
-that internal consistency checks in the @file{f771} program are run.
-
-This option is supplied automatically when @option{-v} or @option{--verbose}
-is specified as a command-line option for @command{g77} or @command{gcc}
-and when the resulting commands compile Fortran source files.
-
-In GCC 3.1, this is changed back to the behavior @command{gcc} displays
-for @samp{.c} files.
-
-@cindex -fset-g77-defaults option
-@cindex options, -fset-g77-defaults
-@item -fset-g77-defaults
-@emph{Version info:}
-This option was obsolete as of @code{egcs}
-version 1.1.
-The effect is instead achieved
-by the @code{lang_init_options} routine
-in @file{gcc/gcc/f/com.c}.
-
-@cindex consistency checks
-@cindex internal consistency checks
-@cindex checks, of internal consistency
-Set up whatever @command{gcc} options are to apply to Fortran
-compilations, and avoid running internal consistency checks
-that might take some time.
-
-This option is supplied automatically when compiling Fortran code
-via the @command{g77} or @command{gcc} command.
-The description of this option is provided so that users seeing
-it in the output of, say, @samp{g77 -v} understand why it is
-there.
-
-@cindex modifying @command{g77}
-@cindex @command{g77}, modifying
-Also, developers who run @code{f771} directly might want to specify it
-by hand to get the same defaults as they would running @code{f771}
-via @command{g77} or @command{gcc}
-However, such developers should, after linking a new @code{f771}
-executable, invoke it without this option once,
-e.g. via @kbd{./f771 -quiet < /dev/null},
-to ensure that they have not introduced any
-internal inconsistencies (such as in the table of
-intrinsics) before proceeding---@command{g77} will crash
-with a diagnostic if it detects an inconsistency.
-
-@cindex -fno-silent option
-@cindex options, -fno-silent
-@cindex f2c compatibility
-@cindex compatibility, f2c
-@cindex status, compilation
-@cindex compilation, status
-@cindex reporting compilation status
-@cindex printing compilation status
-@item -fno-silent
-Print (to @code{stderr}) the names of the program units as
-they are compiled, in a form similar to that used by popular
-UNIX @command{f77} implementations and @command{f2c}
-@end table
-
-@xref{Overall Options,,Options Controlling the Kind of Output,
-gcc,Using the GNU Compiler Collection (GCC)}, for information
-on more options that control the overall operation of the @command{gcc} command
-(and, by extension, the @command{g77} command).
-
-@node Shorthand Options
-@section Shorthand Options
-@cindex shorthand options
-@cindex options, shorthand
-@cindex macro options
-@cindex options, macro
-
-The following options serve as ``shorthand''
-for other options accepted by the compiler:
-
-@table @gcctabopt
-@cindex -fugly option
-@cindex options, -fugly
-@item -fugly
-@cindex ugly features
-@cindex features, ugly
-@emph{Note:} This option is no longer supported.
-The information, below, is provided to aid
-in the conversion of old scripts.
-
-Specify that certain ``ugly'' constructs are to be quietly accepted.
-Same as:
-
-@smallexample
--fugly-args -fugly-assign -fugly-assumed
--fugly-comma -fugly-complex -fugly-init
--fugly-logint
-@end smallexample
-
-These constructs are considered inappropriate to use in new
-or well-maintained portable Fortran code, but widely used
-in old code.
-@xref{Distensions}, for more information.
-
-@cindex -fno-ugly option
-@cindex options, -fno-ugly
-@item -fno-ugly
-@cindex ugly features
-@cindex features, ugly
-Specify that all ``ugly'' constructs are to be noisily rejected.
-Same as:
-
-@smallexample
--fno-ugly-args -fno-ugly-assign -fno-ugly-assumed
--fno-ugly-comma -fno-ugly-complex -fno-ugly-init
--fno-ugly-logint
-@end smallexample
-
-@xref{Distensions}, for more information.
-
-@cindex -ff66 option
-@cindex options, -ff66
-@item -ff66
-@cindex FORTRAN 66
-@cindex compatibility, FORTRAN 66
-Specify that the program is written in idiomatic FORTRAN 66.
-Same as @samp{-fonetrip -fugly-assumed}.
-
-The @option{-fno-f66} option is the inverse of @option{-ff66}.
-As such, it is the same as @samp{-fno-onetrip -fno-ugly-assumed}.
-
-The meaning of this option is likely to be refined as future
-versions of @command{g77} provide more compatibility with other
-existing and obsolete Fortran implementations.
-
-@cindex -ff77 option
-@cindex options, -ff77
-@item -ff77
-@cindex UNIX f77
-@cindex f2c compatibility
-@cindex compatibility, f2c
-@cindex f77 compatibility
-@cindex compatibility, f77
-Specify that the program is written in idiomatic UNIX FORTRAN 77
-and/or the dialect accepted by the @command{f2c} product.
-Same as @samp{-fbackslash -fno-typeless-boz}.
-
-The meaning of this option is likely to be refined as future
-versions of @command{g77} provide more compatibility with other
-existing and obsolete Fortran implementations.
-
-@cindex -fno-f77 option
-@cindex options, -fno-f77
-@item -fno-f77
-@cindex UNIX f77
-The @option{-fno-f77} option is @emph{not} the inverse
-of @option{-ff77}.
-It specifies that the program is not written in idiomatic UNIX
-FORTRAN 77 or @command{f2c} but in a more widely portable dialect.
-@option{-fno-f77} is the same as @option{-fno-backslash}.
-
-The meaning of this option is likely to be refined as future
-versions of @command{g77} provide more compatibility with other
-existing and obsolete Fortran implementations.
-@end table
-
-@node Fortran Dialect Options
-@section Options Controlling Fortran Dialect
-@cindex dialect options
-@cindex language, dialect options
-@cindex options, dialect
-
-The following options control the dialect of Fortran
-that the compiler accepts:
-
-@table @gcctabopt
-@cindex -ffree-form option
-@cindex options, -ffree-form
-@cindex -fno-fixed-form option
-@cindex options, -fno-fixed-form
-@cindex source file format
-@cindex free form
-@cindex fixed form
-@cindex Fortran 90, features
-@item -ffree-form
-@item -fno-fixed-form
-Specify that the source file is written in free form
-(introduced in Fortran 90) instead of the more-traditional fixed form.
-
-@cindex -ff90 option
-@cindex options, -ff90
-@cindex Fortran 90, features
-@item -ff90
-Allow certain Fortran-90 constructs.
-
-This option controls whether certain
-Fortran 90 constructs are recognized.
-(Other Fortran 90 constructs
-might or might not be recognized depending on other options such as
-@option{-fvxt}, @option{-ff90-intrinsics-enable}, and the
-current level of support for Fortran 90.)
-
-@xref{Fortran 90}, for more information.
-
-@cindex -fvxt option
-@cindex options, -fvxt
-@item -fvxt
-@cindex Fortran 90, features
-@cindex VXT extensions
-Specify the treatment of certain constructs that have different
-meanings depending on whether the code is written in
-GNU Fortran (based on FORTRAN 77 and akin to Fortran 90)
-or VXT Fortran (more like VAX FORTRAN).
-
-The default is @option{-fno-vxt}.
-@option{-fvxt} specifies that the VXT Fortran interpretations
-for those constructs are to be chosen.
-
-@xref{VXT Fortran}, for more information.
-
-@cindex -fdollar-ok option
-@cindex options, -fdollar-ok
-@item -fdollar-ok
-@cindex dollar sign
-@cindex symbol names
-@cindex character set
-Allow @samp{$} as a valid character in a symbol name.
-
-@cindex -fno-backslash option
-@cindex options, -fno-backslash
-@item -fno-backslash
-@cindex backslash
-@cindex character constants
-@cindex Hollerith constants
-Specify that @samp{\} is not to be specially interpreted in character
-and Hollerith constants a la C and many UNIX Fortran compilers.
-
-For example, with @option{-fbackslash} in effect, @samp{A\nB} specifies
-three characters, with the second one being newline.
-With @option{-fno-backslash}, it specifies four characters,
-@samp{A}, @samp{\}, @samp{n}, and @samp{B}.
-
-Note that @command{g77} implements a fairly general form of backslash
-processing that is incompatible with the narrower forms supported
-by some other compilers.
-For example, @samp{'A\003B'} is a three-character string in @command{g77}
-whereas other compilers that support backslash might not support
-the three-octal-digit form, and thus treat that string as longer
-than three characters.
-
-@xref{Backslash in Constants}, for
-information on why @option{-fbackslash} is the default
-instead of @option{-fno-backslash}.
-
-@cindex -fno-ugly-args option
-@cindex options, -fno-ugly-args
-@item -fno-ugly-args
-Disallow passing Hollerith and typeless constants as actual
-arguments (for example, @samp{CALL FOO(4HABCD)}).
-
-@xref{Ugly Implicit Argument Conversion}, for more information.
-
-@cindex -fugly-assign option
-@cindex options, -fugly-assign
-@item -fugly-assign
-Use the same storage for a given variable regardless of
-whether it is used to hold an assigned-statement label
-(as in @samp{ASSIGN 10 TO I}) or used to hold numeric data
-(as in @samp{I = 3}).
-
-@xref{Ugly Assigned Labels}, for more information.
-
-@cindex -fugly-assumed option
-@cindex options, -fugly-assumed
-@item -fugly-assumed
-Assume any dummy array with a final dimension specified as @samp{1}
-is really an assumed-size array, as if @samp{*} had been specified
-for the final dimension instead of @samp{1}.
-
-For example, @samp{DIMENSION X(1)} is treated as if it
-had read @samp{DIMENSION X(*)}.
-
-@xref{Ugly Assumed-Size Arrays}, for more information.
-
-@cindex -fugly-comma option
-@cindex options, -fugly-comma
-@item -fugly-comma
-In an external-procedure invocation,
-treat a trailing comma in the argument list
-as specification of a trailing null argument,
-and treat an empty argument list
-as specification of a single null argument.
-
-For example, @samp{CALL FOO(,)} is treated as
-@samp{CALL FOO(%VAL(0), %VAL(0))}.
-That is, @emph{two} null arguments are specified
-by the procedure call when @option{-fugly-comma} is in force.
-And @samp{F = FUNC()} is treated as @samp{F = FUNC(%VAL(0))}.
-
-The default behavior, @option{-fno-ugly-comma}, is to ignore
-a single trailing comma in an argument list.
-So, by default, @samp{CALL FOO(X,)} is treated
-exactly the same as @samp{CALL FOO(X)}.
-
-@xref{Ugly Null Arguments}, for more information.
-
-@cindex -fugly-complex option
-@cindex options, -fugly-complex
-@item -fugly-complex
-Do not complain about @samp{REAL(@var{expr})} or
-@samp{AIMAG(@var{expr})} when @var{expr} is a @code{COMPLEX}
-type other than @code{COMPLEX(KIND=1)}---usually
-this is used to permit @code{COMPLEX(KIND=2)}
-(@code{DOUBLE COMPLEX}) operands.
-
-The @option{-ff90} option controls the interpretation
-of this construct.
-
-@xref{Ugly Complex Part Extraction}, for more information.
-
-@cindex -fno-ugly-init option
-@cindex options, -fno-ugly-init
-@item -fno-ugly-init
-Disallow use of Hollerith and typeless constants as initial
-values (in @code{PARAMETER} and @code{DATA} statements), and
-use of character constants to
-initialize numeric types and vice versa.
-
-For example, @samp{DATA I/'F'/, CHRVAR/65/, J/4HABCD/} is disallowed by
-@option{-fno-ugly-init}.
-
-@xref{Ugly Conversion of Initializers}, for more information.
-
-@cindex -fugly-logint option
-@cindex options, -fugly-logint
-@item -fugly-logint
-Treat @code{INTEGER} and @code{LOGICAL} variables and
-expressions as potential stand-ins for each other.
-
-For example, automatic conversion between @code{INTEGER} and
-@code{LOGICAL} is enabled, for many contexts, via this option.
-
-@xref{Ugly Integer Conversions}, for more information.
-
-@cindex -fonetrip option
-@cindex options, -fonetrip
-@item -fonetrip
-@cindex FORTRAN 66
-@cindex @code{DO} loops, one-trip
-@cindex one-trip @code{DO} loops
-@cindex @code{DO} loops, zero-trip
-@cindex zero-trip @code{DO} loops
-@cindex compatibility, FORTRAN 66
-Executable iterative @code{DO} loops are to be executed at
-least once each time they are reached.
-
-ANSI FORTRAN 77 and more recent versions of the Fortran standard
-specify that the body of an iterative @code{DO} loop is not executed
-if the number of iterations calculated from the parameters of the
-loop is less than 1.
-(For example, @samp{DO 10 I = 1, 0}.)
-Such a loop is called a @dfn{zero-trip loop}.
-
-Prior to ANSI FORTRAN 77, many compilers implemented @code{DO} loops
-such that the body of a loop would be executed at least once, even
-if the iteration count was zero.
-Fortran code written assuming this behavior is said to require
-@dfn{one-trip loops}.
-For example, some code written to the FORTRAN 66 standard
-expects this behavior from its @code{DO} loops, although that
-standard did not specify this behavior.
-
-The @option{-fonetrip} option specifies that the source file(s) being
-compiled require one-trip loops.
-
-This option affects only those loops specified by the (iterative) @code{DO}
-statement and by implied-@code{DO} lists in I/O statements.
-Loops specified by implied-@code{DO} lists in @code{DATA} and
-specification (non-executable) statements are not affected.
-
-@cindex -ftypeless-boz option
-@cindex options, -ftypeless-boz
-@cindex prefix-radix constants
-@cindex constants, prefix-radix
-@cindex constants, types
-@cindex types, constants
-@item -ftypeless-boz
-Specifies that prefix-radix non-decimal constants, such as
-@samp{Z'ABCD'}, are typeless instead of @code{INTEGER(KIND=1)}.
-
-You can test for yourself whether a particular compiler treats
-the prefix form as @code{INTEGER(KIND=1)} or typeless by running the
-following program:
-
-@smallexample
-EQUIVALENCE (I, R)
-R = Z'ABCD1234'
-J = Z'ABCD1234'
-IF (J .EQ. I) PRINT *, 'Prefix form is TYPELESS'
-IF (J .NE. I) PRINT *, 'Prefix form is INTEGER'
-END
-@end smallexample
-
-Reports indicate that many compilers process this form as
-@code{INTEGER(KIND=1)}, though a few as typeless, and at least one
-based on a command-line option specifying some kind of
-compatibility.
-
-@cindex -fintrin-case-initcap option
-@cindex options, -fintrin-case-initcap
-@item -fintrin-case-initcap
-@cindex -fintrin-case-upper option
-@cindex options, -fintrin-case-upper
-@item -fintrin-case-upper
-@cindex -fintrin-case-lower option
-@cindex options, -fintrin-case-lower
-@item -fintrin-case-lower
-@cindex -fintrin-case-any option
-@cindex options, -fintrin-case-any
-@item -fintrin-case-any
-Specify expected case for intrinsic names.
-@option{-fintrin-case-lower} is the default.
-
-@cindex -fmatch-case-initcap option
-@cindex options, -fmatch-case-initcap
-@item -fmatch-case-initcap
-@cindex -fmatch-case-upper option
-@cindex options, -fmatch-case-upper
-@item -fmatch-case-upper
-@cindex -fmatch-case-lower option
-@cindex options, -fmatch-case-lower
-@item -fmatch-case-lower
-@cindex -fmatch-case-any option
-@cindex options, -fmatch-case-any
-@item -fmatch-case-any
-Specify expected case for keywords.
-@option{-fmatch-case-lower} is the default.
-
-@cindex -fsource-case-upper option
-@cindex options, -fsource-case-upper
-@item -fsource-case-upper
-@cindex -fsource-case-lower option
-@cindex options, -fsource-case-lower
-@item -fsource-case-lower
-@cindex -fsource-case-preserve option
-@cindex options, -fsource-case-preserve
-@item -fsource-case-preserve
-Specify whether source text other than character and Hollerith constants
-is to be translated to uppercase, to lowercase, or preserved as is.
-@option{-fsource-case-lower} is the default.
-
-@cindex -fsymbol-case-initcap option
-@cindex options, -fsymbol-case-initcap
-@item -fsymbol-case-initcap
-@cindex -fsymbol-case-upper option
-@cindex options, -fsymbol-case-upper
-@item -fsymbol-case-upper
-@cindex -fsymbol-case-lower option
-@cindex options, -fsymbol-case-lower
-@item -fsymbol-case-lower
-@cindex -fsymbol-case-any option
-@cindex options, -fsymbol-case-any
-@item -fsymbol-case-any
-Specify valid cases for user-defined symbol names.
-@option{-fsymbol-case-any} is the default.
-
-@cindex -fcase-strict-upper option
-@cindex options, -fcase-strict-upper
-@item -fcase-strict-upper
-Same as @samp{-fintrin-case-upper -fmatch-case-upper -fsource-case-preserve
--fsymbol-case-upper}.
-(Requires all pertinent source to be in uppercase.)
-
-@cindex -fcase-strict-lower option
-@cindex options, -fcase-strict-lower
-@item -fcase-strict-lower
-Same as @samp{-fintrin-case-lower -fmatch-case-lower -fsource-case-preserve
--fsymbol-case-lower}.
-(Requires all pertinent source to be in lowercase.)
-
-@cindex -fcase-initcap option
-@cindex options, -fcase-initcap
-@item -fcase-initcap
-Same as @samp{-fintrin-case-initcap -fmatch-case-initcap -fsource-case-preserve
--fsymbol-case-initcap}.
-(Requires all pertinent source to be in initial capitals,
-as in @samp{Print *,SqRt(Value)}.)
-
-@cindex -fcase-upper option
-@cindex options, -fcase-upper
-@item -fcase-upper
-Same as @samp{-fintrin-case-any -fmatch-case-any -fsource-case-upper
--fsymbol-case-any}.
-(Maps all pertinent source to uppercase.)
-
-@cindex -fcase-lower option
-@cindex options, -fcase-lower
-@item -fcase-lower
-Same as @samp{-fintrin-case-any -fmatch-case-any -fsource-case-lower
--fsymbol-case-any}.
-(Maps all pertinent source to lowercase.)
-
-@cindex -fcase-preserve option
-@cindex options, -fcase-preserve
-@item -fcase-preserve
-Same as @samp{-fintrin-case-any -fmatch-case-any -fsource-case-preserve
--fsymbol-case-any}.
-(Preserves all case in user-defined symbols,
-while allowing any-case matching of intrinsics and keywords.
-For example, @samp{call Foo(i,I)} would pass two @emph{different}
-variables named @samp{i} and @samp{I} to a procedure named @samp{Foo}.)
-
-@cindex -fbadu77-intrinsics-delete option
-@cindex options, -fbadu77-intrinsics-delete
-@item -fbadu77-intrinsics-delete
-@cindex -fbadu77-intrinsics-hide option
-@cindex options, -fbadu77-intrinsics-hide
-@item -fbadu77-intrinsics-hide
-@cindex -fbadu77-intrinsics-disable option
-@cindex options, -fbadu77-intrinsics-disable
-@item -fbadu77-intrinsics-disable
-@cindex -fbadu77-intrinsics-enable option
-@cindex options, -fbadu77-intrinsics-enable
-@item -fbadu77-intrinsics-enable
-@cindex @code{badu77} intrinsics
-@cindex intrinsics, @code{badu77}
-Specify status of UNIX intrinsics having inappropriate forms.
-@option{-fbadu77-intrinsics-enable} is the default.
-@xref{Intrinsic Groups}.
-
-@cindex -ff2c-intrinsics-delete option
-@cindex options, -ff2c-intrinsics-delete
-@item -ff2c-intrinsics-delete
-@cindex -ff2c-intrinsics-hide option
-@cindex options, -ff2c-intrinsics-hide
-@item -ff2c-intrinsics-hide
-@cindex -ff2c-intrinsics-disable option
-@cindex options, -ff2c-intrinsics-disable
-@item -ff2c-intrinsics-disable
-@cindex -ff2c-intrinsics-enable option
-@cindex options, -ff2c-intrinsics-enable
-@item -ff2c-intrinsics-enable
-@cindex @command{f2c} intrinsics
-@cindex intrinsics, @command{f2c}
-Specify status of f2c-specific intrinsics.
-@option{-ff2c-intrinsics-enable} is the default.
-@xref{Intrinsic Groups}.
-
-@cindex -ff90-intrinsics-delete option
-@cindex options, -ff90-intrinsics-delete
-@item -ff90-intrinsics-delete
-@cindex -ff90-intrinsics-hide option
-@cindex options, -ff90-intrinsics-hide
-@item -ff90-intrinsics-hide
-@cindex -ff90-intrinsics-disable option
-@cindex options, -ff90-intrinsics-disable
-@item -ff90-intrinsics-disable
-@cindex -ff90-intrinsics-enable option
-@cindex options, -ff90-intrinsics-enable
-@item -ff90-intrinsics-enable
-@cindex Fortran 90, intrinsics
-@cindex intrinsics, Fortran 90
-Specify status of F90-specific intrinsics.
-@option{-ff90-intrinsics-enable} is the default.
-@xref{Intrinsic Groups}.
-
-@cindex -fgnu-intrinsics-delete option
-@cindex options, -fgnu-intrinsics-delete
-@item -fgnu-intrinsics-delete
-@cindex -fgnu-intrinsics-hide option
-@cindex options, -fgnu-intrinsics-hide
-@item -fgnu-intrinsics-hide
-@cindex -fgnu-intrinsics-disable option
-@cindex options, -fgnu-intrinsics-disable
-@item -fgnu-intrinsics-disable
-@cindex -fgnu-intrinsics-enable option
-@cindex options, -fgnu-intrinsics-enable
-@item -fgnu-intrinsics-enable
-@cindex Digital Fortran features
-@cindex @code{COMPLEX} intrinsics
-@cindex intrinsics, @code{COMPLEX}
-Specify status of Digital's COMPLEX-related intrinsics.
-@option{-fgnu-intrinsics-enable} is the default.
-@xref{Intrinsic Groups}.
-
-@cindex -fmil-intrinsics-delete option
-@cindex options, -fmil-intrinsics-delete
-@item -fmil-intrinsics-delete
-@cindex -fmil-intrinsics-hide option
-@cindex options, -fmil-intrinsics-hide
-@item -fmil-intrinsics-hide
-@cindex -fmil-intrinsics-disable option
-@cindex options, -fmil-intrinsics-disable
-@item -fmil-intrinsics-disable
-@cindex -fmil-intrinsics-enable option
-@cindex options, -fmil-intrinsics-enable
-@item -fmil-intrinsics-enable
-@cindex MIL-STD 1753
-@cindex intrinsics, MIL-STD 1753
-Specify status of MIL-STD-1753-specific intrinsics.
-@option{-fmil-intrinsics-enable} is the default.
-@xref{Intrinsic Groups}.
-
-@cindex -funix-intrinsics-delete option
-@cindex options, -funix-intrinsics-delete
-@item -funix-intrinsics-delete
-@cindex -funix-intrinsics-hide option
-@cindex options, -funix-intrinsics-hide
-@item -funix-intrinsics-hide
-@cindex -funix-intrinsics-disable option
-@cindex options, -funix-intrinsics-disable
-@item -funix-intrinsics-disable
-@cindex -funix-intrinsics-enable option
-@cindex options, -funix-intrinsics-enable
-@item -funix-intrinsics-enable
-@cindex UNIX intrinsics
-@cindex intrinsics, UNIX
-Specify status of UNIX intrinsics.
-@option{-funix-intrinsics-enable} is the default.
-@xref{Intrinsic Groups}.
-
-@cindex -fvxt-intrinsics-delete option
-@cindex options, -fvxt-intrinsics-delete
-@item -fvxt-intrinsics-delete
-@cindex -fvxt-intrinsics-hide option
-@cindex options, -fvxt-intrinsics-hide
-@item -fvxt-intrinsics-hide
-@cindex -fvxt-intrinsics-disable option
-@cindex options, -fvxt-intrinsics-disable
-@item -fvxt-intrinsics-disable
-@cindex -fvxt-intrinsics-enable option
-@cindex options, -fvxt-intrinsics-enable
-@item -fvxt-intrinsics-enable
-@cindex VXT intrinsics
-@cindex intrinsics, VXT
-Specify status of VXT intrinsics.
-@option{-fvxt-intrinsics-enable} is the default.
-@xref{Intrinsic Groups}.
-
-@cindex -ffixed-line-length-@var{n} option
-@cindex options, -ffixed-line-length-@var{n}
-@item -ffixed-line-length-@var{n}
-@cindex source file format
-@cindex lines, length
-@cindex length of source lines
-@cindex fixed form
-@cindex limits, lengths of source lines
-Set column after which characters are ignored in typical fixed-form
-lines in the source file, and through which spaces are assumed (as
-if padded to that length) after the ends of short fixed-form lines.
-
-@cindex card image
-@cindex extended-source option
-Popular values for @var{n} include 72 (the
-standard and the default), 80 (card image), and 132 (corresponds
-to ``extended-source'' options in some popular compilers).
-@var{n} may be @samp{none}, meaning that the entire line is meaningful
-and that continued character constants never have implicit spaces appended
-to them to fill out the line.
-@option{-ffixed-line-length-0} means the same thing as
-@option{-ffixed-line-length-none}.
-
-@xref{Source Form}, for more information.
-@end table
-
-@node Warning Options
-@section Options to Request or Suppress Warnings
-@cindex options, warnings
-@cindex warnings, suppressing
-@cindex messages, warning
-@cindex suppressing warnings
-
-Warnings are diagnostic messages that report constructions which
-are not inherently erroneous but which are risky or suggest there
-might have been an error.
-
-You can request many specific warnings with options beginning @option{-W},
-for example @option{-Wimplicit} to request warnings on implicit
-declarations. Each of these specific warning options also has a
-negative form beginning @option{-Wno-} to turn off warnings;
-for example, @option{-Wno-implicit}. This manual lists only one of the
-two forms, whichever is not the default.
-
-These options control the amount and kinds of warnings produced by GNU
-Fortran:
-
-@table @gcctabopt
-@cindex syntax checking
-@cindex -fsyntax-only option
-@cindex options, -fsyntax-only
-@item -fsyntax-only
-Check the code for syntax errors, but don't do anything beyond that.
-
-@cindex -pedantic option
-@cindex options, -pedantic
-@item -pedantic
-Issue warnings for uses of extensions to ANSI FORTRAN 77.
-@option{-pedantic} also applies to C-language constructs where they
-occur in GNU Fortran source files, such as use of @samp{\e} in a
-character constant within a directive like @samp{#include}.
-
-Valid ANSI FORTRAN 77 programs should compile properly with or without
-this option.
-However, without this option, certain GNU extensions and traditional
-Fortran features are supported as well.
-With this option, many of them are rejected.
-
-Some users try to use @option{-pedantic} to check programs for strict ANSI
-conformance.
-They soon find that it does not do quite what they want---it finds some
-non-ANSI practices, but not all.
-However, improvements to @command{g77} in this area are welcome.
-
-@cindex -pedantic-errors option
-@cindex options, -pedantic-errors
-@item -pedantic-errors
-Like @option{-pedantic}, except that errors are produced rather than
-warnings.
-
-@cindex -fpedantic option
-@cindex options, -fpedantic
-@item -fpedantic
-Like @option{-pedantic}, but applies only to Fortran constructs.
-
-@cindex -w option
-@cindex options, -w
-@item -w
-Inhibit all warning messages.
-
-@cindex -Wno-globals option
-@cindex options, -Wno-globals
-@item -Wno-globals
-@cindex global names, warning
-@cindex warnings, global names
-Inhibit warnings about use of a name as both a global name
-(a subroutine, function, or block data program unit, or a
-common block) and implicitly as the name of an intrinsic
-in a source file.
-
-Also inhibit warnings about inconsistent invocations and/or
-definitions of global procedures (function and subroutines).
-Such inconsistencies include different numbers of arguments
-and different types of arguments.
-
-@cindex -Wimplicit option
-@cindex options, -Wimplicit
-@item -Wimplicit
-@cindex implicit declaration, warning
-@cindex warnings, implicit declaration
-@cindex -u option
-@cindex /WARNINGS=DECLARATIONS switch
-@cindex IMPLICIT NONE, similar effect
-@cindex effecting IMPLICIT NONE
-Warn whenever a variable, array, or function is implicitly
-declared.
-Has an effect similar to using the @code{IMPLICIT NONE} statement
-in every program unit.
-(Some Fortran compilers provide this feature by an option
-named @option{-u} or @samp{/WARNINGS=DECLARATIONS}.)
-
-@cindex -Wunused option
-@cindex options, -Wunused
-@item -Wunused
-@cindex unused variables
-@cindex variables, unused
-Warn whenever a variable is unused aside from its declaration.
-
-@cindex -Wuninitialized option
-@cindex options, -Wuninitialized
-@item -Wuninitialized
-@cindex uninitialized variables
-@cindex variables, uninitialized
-Warn whenever an automatic variable is used without first being initialized.
-
-These warnings are possible only in optimizing compilation,
-because they require data-flow information that is computed only
-when optimizing. If you don't specify @option{-O}, you simply won't
-get these warnings.
-
-These warnings occur only for variables that are candidates for
-register allocation. Therefore, they do not occur for a variable
-@c that is declared @code{VOLATILE}, or
-whose address is taken, or whose size
-is other than 1, 2, 4 or 8 bytes. Also, they do not occur for
-arrays, even when they are in registers.
-
-Note that there might be no warning about a variable that is used only
-to compute a value that itself is never used, because such
-computations may be deleted by data-flow analysis before the warnings
-are printed.
-
-These warnings are made optional because GNU Fortran is not smart
-enough to see all the reasons why the code might be correct
-despite appearing to have an error. Here is one example of how
-this can happen:
-
-@example
-SUBROUTINE DISPAT(J)
-IF (J.EQ.1) I=1
-IF (J.EQ.2) I=4
-IF (J.EQ.3) I=5
-CALL FOO(I)
-END
-@end example
-
-@noindent
-If the value of @code{J} is always 1, 2 or 3, then @code{I} is
-always initialized, but GNU Fortran doesn't know this. Here is
-another common case:
-
-@example
-SUBROUTINE MAYBE(FLAG)
-LOGICAL FLAG
-IF (FLAG) VALUE = 9.4
-@dots{}
-IF (FLAG) PRINT *, VALUE
-END
-@end example
-
-@noindent
-This has no bug because @code{VALUE} is used only if it is set.
-
-@cindex -Wall option
-@cindex options, -Wall
-@item -Wall
-@cindex all warnings
-@cindex warnings, all
-The @option{-Wunused} and @option{-Wuninitialized} options combined.
-These are all the
-options which pertain to usage that we recommend avoiding and that we
-believe is easy to avoid.
-(As more warnings are added to @command{g77} some might
-be added to the list enabled by @option{-Wall}.)
-@end table
-
-The remaining @option{-W@dots{}} options are not implied by @option{-Wall}
-because they warn about constructions that we consider reasonable to
-use, on occasion, in clean programs.
-
-@table @gcctabopt
-@c @item -W
-@c Print extra warning messages for these events:
-@c
-@c @itemize @bullet
-@c @item
-@c If @option{-Wall} or @option{-Wunused} is also specified, warn about unused
-@c arguments.
-@c
-@c @end itemize
-@c
-@cindex -Wsurprising option
-@cindex options, -Wsurprising
-@item -Wsurprising
-Warn about ``suspicious'' constructs that are interpreted
-by the compiler in a way that might well be surprising to
-someone reading the code.
-These differences can result in subtle, compiler-dependent
-(even machine-dependent) behavioral differences.
-The constructs warned about include:
-
-@itemize @bullet
-@item
-Expressions having two arithmetic operators in a row, such
-as @samp{X*-Y}.
-Such a construct is nonstandard, and can produce
-unexpected results in more complicated situations such
-as @samp{X**-Y*Z}.
-@command{g77} along with many other compilers, interprets
-this example differently than many programmers, and a few
-other compilers.
-Specifically, @command{g77} interprets @samp{X**-Y*Z} as
-@samp{(X**(-Y))*Z}, while others might think it should
-be interpreted as @samp{X**(-(Y*Z))}.
-
-A revealing example is the constant expression @samp{2**-2*1.},
-which @command{g77} evaluates to .25, while others might evaluate
-it to 0., the difference resulting from the way precedence affects
-type promotion.
-
-(The @option{-fpedantic} option also warns about expressions
-having two arithmetic operators in a row.)
-
-@item
-Expressions with a unary minus followed by an operand and then
-a binary operator other than plus or minus.
-For example, @samp{-2**2} produces a warning, because
-the precedence is @samp{-(2**2)}, yielding -4, not
-@samp{(-2)**2}, which yields 4, and which might represent
-what a programmer expects.
-
-An example of an expression producing different results
-in a surprising way is @samp{-I*S}, where @var{I} holds
-the value @samp{-2147483648} and @var{S} holds @samp{0.5}.
-On many systems, negating @var{I} results in the same
-value, not a positive number, because it is already the
-lower bound of what an @code{INTEGER(KIND=1)} variable can hold.
-So, the expression evaluates to a positive number, while
-the ``expected'' interpretation, @samp{(-I)*S}, would
-evaluate to a negative number.
-
-Even cases such as @samp{-I*J} produce warnings,
-even though, in most configurations and situations,
-there is no computational difference between the
-results of the two interpretations---the purpose
-of this warning is to warn about differing interpretations
-and encourage a better style of coding, not to identify
-only those places where bugs might exist in the user's
-code.
-
-@cindex DO statement
-@cindex statements, DO
-@item
-@code{DO} loops with @code{DO} variables that are not
-of integral type---that is, using @code{REAL}
-variables as loop control variables.
-Although such loops can be written to work in the
-``obvious'' way, the way @command{g77} is required by the
-Fortran standard to interpret such code is likely to
-be quite different from the way many programmers expect.
-(This is true of all @code{DO} loops, but the differences
-are pronounced for non-integral loop control variables.)
-
-@xref{Loops}, for more information.
-@end itemize
-
-@cindex -Werror option
-@cindex options, -Werror
-@item -Werror
-Make all warnings into errors.
-
-@cindex -W option
-@cindex options, -W
-@item -W
-@cindex extra warnings
-@cindex warnings, extra
-Turns on ``extra warnings'' and, if optimization is specified
-via @option{-O}, the @option{-Wuninitialized} option.
-(This might change in future versions of @command{g77}
-
-``Extra warnings'' are issued for:
-
-@itemize @bullet
-@item
-@cindex unused parameters
-@cindex parameters, unused
-@cindex unused arguments
-@cindex arguments, unused
-@cindex unused dummies
-@cindex dummies, unused
-Unused parameters to a procedure (when @option{-Wunused} also is
-specified).
-
-@item
-@cindex overflow
-Overflows involving floating-point constants (not available
-for certain configurations).
-@end itemize
-@end table
-
-@xref{Warning Options,,Options to Request or Suppress Warnings,
-gcc,Using the GNU Compiler Collection (GCC)}, for information on more
-options offered
-by the GBE shared by @command{g77} @command{gcc} and other GNU compilers.
-
-Some of these have no effect when compiling programs written in Fortran:
-
-@table @gcctabopt
-@cindex -Wcomment option
-@cindex options, -Wcomment
-@item -Wcomment
-@cindex -Wformat option
-@cindex options, -Wformat
-@item -Wformat
-@cindex -Wparentheses option
-@cindex options, -Wparentheses
-@item -Wparentheses
-@cindex -Wswitch option
-@cindex options, -Wswitch
-@item -Wswitch
-@cindex -Wswitch-default option
-@cindex options, -Wswitch-default
-@item -Wswitch-default
-@cindex -Wswitch-enum option
-@cindex options, -Wswitch-enum
-@item -Wswitch-enum
-@cindex -Wtraditional option
-@cindex options, -Wtraditional
-@item -Wtraditional
-@cindex -Wshadow option
-@cindex options, -Wshadow
-@item -Wshadow
-@cindex -Wid-clash-@var{len} option
-@cindex options, -Wid-clash-@var{len}
-@item -Wid-clash-@var{len}
-@cindex -Wlarger-than-@var{len} option
-@cindex options, -Wlarger-than-@var{len}
-@item -Wlarger-than-@var{len}
-@cindex -Wconversion option
-@cindex options, -Wconversion
-@item -Wconversion
-@cindex -Waggregate-return option
-@cindex options, -Waggregate-return
-@item -Waggregate-return
-@cindex -Wredundant-decls option
-@cindex options, -Wredundant-decls
-@item -Wredundant-decls
-@cindex unsupported warnings
-@cindex warnings, unsupported
-These options all could have some relevant meaning for
-GNU Fortran programs, but are not yet supported.
-@end table
-
-@node Debugging Options
-@section Options for Debugging Your Program or GNU Fortran
-@cindex options, debugging
-@cindex debugging information options
-
-GNU Fortran has various special options that are used for debugging
-either your program or @command{g77}
-
-@table @gcctabopt
-@cindex -g option
-@cindex options, -g
-@item -g
-Produce debugging information in the operating system's native format
-(stabs, COFF, XCOFF, or DWARF). GDB can work with this debugging
-information.
-
-A sample debugging session looks like this (note the use of the breakpoint):
-@smallexample
-$ cat gdb.f
- PROGRAM PROG
- DIMENSION A(10)
- DATA A /1.,2.,3.,4.,5.,6.,7.,8.,9.,10./
- A(5) = 4.
- PRINT*,A
- END
-$ g77 -g -O gdb.f
-$ gdb a.out
-...
-(gdb) break MAIN__
-Breakpoint 1 at 0x8048e96: file gdb.f, line 4.
-(gdb) run
-Starting program: /home/toon/g77-bugs/./a.out
-Breakpoint 1, MAIN__ () at gdb.f:4
-4 A(5) = 4.
-Current language: auto; currently fortran
-(gdb) print a(5)
-$1 = 5
-(gdb) step
-5 PRINT*,A
-(gdb) print a(5)
-$2 = 4
-...
-@end smallexample
-One could also add the setting of the breakpoint and the first run command
-to the file @file{.gdbinit} in the current directory, to simplify the debugging
-session.
-@end table
-
-@xref{Debugging Options,,Options for Debugging Your Program or GCC,
-gcc,Using the GNU Compiler Collection (GCC)}, for more information on
-debugging options.
-
-@node Optimize Options
-@section Options That Control Optimization
-@cindex optimize options
-@cindex options, optimization
-
-Most Fortran users will want to use no optimization when
-developing and testing programs, and use @option{-O} or @option{-O2} when
-compiling programs for late-cycle testing and for production use.
-However, note that certain diagnostics---such as for uninitialized
-variables---depend on the flow analysis done by @option{-O}, i.e.@: you
-must use @option{-O} or @option{-O2} to get such diagnostics.
-
-The following flags have particular applicability when
-compiling Fortran programs:
-
-@table @gcctabopt
-@cindex -malign-double option
-@cindex options, -malign-double
-@item -malign-double
-(Intel x86 architecture only.)
-
-Noticeably improves performance of @command{g77} programs making
-heavy use of @code{REAL(KIND=2)} (@code{DOUBLE PRECISION}) data
-on some systems.
-In particular, systems using Pentium, Pentium Pro, 586, and
-686 implementations
-of the i386 architecture execute programs faster when
-@code{REAL(KIND=2)} (@code{DOUBLE PRECISION}) data are
-aligned on 64-bit boundaries
-in memory.
-
-This option can, at least, make benchmark results more consistent
-across various system configurations, versions of the program,
-and data sets.
-
-@emph{Note:} The warning in the @command{gcc} documentation about
-this option does not apply, generally speaking, to Fortran
-code compiled by @command{g77}
-
-@xref{Aligned Data}, for more information on alignment issues.
-
-@emph{Also also note:} The negative form of @option{-malign-double}
-is @option{-mno-align-double}, not @option{-benign-double}.
-
-@cindex -ffloat-store option
-@cindex options, -ffloat-store
-@item -ffloat-store
-@cindex IEEE 754 conformance
-@cindex conformance, IEEE 754
-@cindex floating-point, precision
-Might help a Fortran program that depends on exact IEEE conformance on
-some machines, but might slow down a program that doesn't.
-
-This option is effective when the floating-point unit is set to work in
-IEEE 854 `extended precision'---as it typically is on x86 and m68k GNU
-systems---rather than IEEE 754 double precision. @option{-ffloat-store}
-tries to remove the extra precision by spilling data from floating-point
-registers into memory and this typically involves a big performance
-hit. However, it doesn't affect intermediate results, so that it is
-only partially effective. `Excess precision' is avoided in code like:
-@smallexample
-a = b + c
-d = a * e
-@end smallexample
-but not in code like:
-@smallexample
- d = (b + c) * e
-@end smallexample
-
-For another, potentially better, way of controlling the precision,
-see @ref{Floating-point precision}.
-
-@cindex -fforce-mem option
-@cindex options, -fforce-mem
-@item -fforce-mem
-@cindex -fforce-addr option
-@cindex options, -fforce-addr
-@item -fforce-addr
-@cindex loops, speeding up
-@cindex speed, of loops
-Might improve optimization of loops.
-
-@cindex -fno-inline option
-@cindex options, -fno-inline
-@item -fno-inline
-@cindex in-line code
-@cindex compilation, in-line
-@c DL: Only relevant for -O3? TM: No, statement functions are
-@c inlined even at -O1.
-Don't compile statement functions inline.
-Might reduce the size of a program unit---which might be at
-expense of some speed (though it should compile faster).
-Note that if you are not optimizing, no functions can be expanded inline.
-
-@cindex -ffast-math option
-@cindex options, -ffast-math
-@item -ffast-math
-@cindex IEEE 754 conformance
-@cindex conformance, IEEE 754
-Might allow some programs designed to not be too dependent
-on IEEE behavior for floating-point to run faster, or die trying.
-Sets @option{-funsafe-math-optimizations}, @option{-ffinite-math-only},
-and @option{-fno-trapping-math}.
-
-@cindex -funsafe-math-optimizations option
-@cindex options, -funsafe-math-optimizations
-@item -funsafe-math-optimizations
-Allow optimizations that may be give incorrect results
-for certain IEEE inputs.
-
-@cindex -ffinite-math-only option
-@cindex options, -ffinite-math-only
-@item -ffinite-math-only
-Allow optimizations for floating-point arithmetic that assume
-that arguments and results are not NaNs or +-Infs.
-
-This option should never be turned on by any @option{-O} option since
-it can result in incorrect output for programs which depend on
-an exact implementation of IEEE or ISO rules/specifications.
-
-The default is @option{-fno-finite-math-only}.
-
-@cindex -fno-trapping-math option
-@cindex options, -fno-trapping-math
-@item -fno-trapping-math
-Allow the compiler to assume that floating-point arithmetic
-will not generate traps on any inputs. This is useful, for
-example, when running a program using IEEE "non-stop"
-floating-point arithmetic.
-
-@cindex -fstrength-reduce option
-@cindex options, -fstrength-reduce
-@item -fstrength-reduce
-@cindex loops, speeding up
-@cindex speed, of loops
-@c DL: normally defaulted?
-Might make some loops run faster.
-
-@cindex -frerun-cse-after-loop option
-@cindex options, -frerun-cse-after-loop
-@item -frerun-cse-after-loop
-@cindex -fexpensive-optimizations option
-@cindex options, -fexpensive-optimizations
-@c DL: This is -O2?
-@item -fexpensive-optimizations
-@cindex -fdelayed-branch option
-@cindex options, -fdelayed-branch
-@item -fdelayed-branch
-@cindex -fschedule-insns option
-@cindex options, -fschedule-insns
-@item -fschedule-insns
-@cindex -fschedule-insns2 option
-@cindex options, -fschedule-insns2
-@item -fschedule-insns2
-@cindex -fcaller-saves option
-@cindex options, -fcaller-saves
-@item -fcaller-saves
-Might improve performance on some code.
-
-@cindex -funroll-loops option
-@cindex options, -funroll-loops
-@item -funroll-loops
-@cindex loops, unrolling
-@cindex unrolling loops
-@cindex loops, optimizing
-@cindex indexed (iterative) @code{DO}
-@cindex iterative @code{DO}
-@c DL: fixme: Craig doesn't like `indexed' but f95 doesn't seem to
-@c provide a suitable term
-@c CB: I've decided on `iterative', for the time being, and changed
-@c my previous, rather bizarre, use of `imperative' to that
-@c (though `precomputed-trip' would be a more precise adjective)
-Typically improves performance on code using iterative @code{DO} loops by
-unrolling them and is probably generally appropriate for Fortran, though
-it is not turned on at any optimization level.
-Note that outer loop unrolling isn't done specifically; decisions about
-whether to unroll a loop are made on the basis of its instruction count.
-
-@c DL: Fixme: This should obviously go somewhere else...
-Also, no `loop discovery'@footnote{@dfn{loop discovery} refers to the
-process by which a compiler, or indeed any reader of a program,
-determines which portions of the program are more likely to be executed
-repeatedly as it is being run. Such discovery typically is done early
-when compiling using optimization techniques, so the ``discovered''
-loops get more attention---and more run-time resources, such as
-registers---from the compiler. It is easy to ``discover'' loops that are
-constructed out of looping constructs in the language
-(such as Fortran's @code{DO}). For some programs, ``discovering'' loops
-constructed out of lower-level constructs (such as @code{IF} and
-@code{GOTO}) can lead to generation of more optimal code
-than otherwise.} is done, so only loops written with @code{DO}
-benefit from loop optimizations, including---but not limited
-to---unrolling. Loops written with @code{IF} and @code{GOTO} are not
-currently recognized as such. This option unrolls only iterative
-@code{DO} loops, not @code{DO WHILE} loops.
-
-@cindex -funroll-all-loops option
-@cindex options, -funroll-all-loops
-@cindex DO WHILE
-@item -funroll-all-loops
-@c DL: Check my understanding of -funroll-all-loops v. -funroll-loops is correct.
-Probably improves performance on code using @code{DO WHILE} loops by
-unrolling them in addition to iterative @code{DO} loops. In the absence
-of @code{DO WHILE}, this option is equivalent to @option{-funroll-loops}
-but possibly slower.
-
-@item -fno-move-all-movables
-@cindex -fno-move-all-movables option
-@cindex options, -fno-move-all-movables
-@item -fno-reduce-all-givs
-@cindex -fno-reduce-all-givs option
-@cindex options, -fno-reduce-all-givs
-@item -fno-rerun-loop-opt
-@cindex -fno-rerun-loop-opt option
-@cindex options, -fno-rerun-loop-opt
-In general, the optimizations enabled with these options will lead to
-faster code being generated by GNU Fortran; hence they are enabled by default
-when issuing the @command{g77} command.
-
-@option{-fmove-all-movables} and @option{-freduce-all-givs} will enable
-loop optimization to move all loop-invariant index computations in nested
-loops over multi-rank array dummy arguments out of these loops.
-
-@option{-frerun-loop-opt} will move offset calculations resulting
-from the fact that Fortran arrays by default have a lower bound of 1
-out of the loops.
-
-These three options are intended to be removed someday, once
-loop optimization is sufficiently advanced to perform all those
-transformations without help from these options.
-@end table
-
-@xref{Optimize Options,,Options That Control Optimization,
-gcc,Using the GNU Compiler Collection (GCC)}, for more information on options
-to optimize the generated machine code.
-
-@node Preprocessor Options
-@section Options Controlling the Preprocessor
-@cindex preprocessor options
-@cindex options, preprocessor
-@cindex cpp program
-@cindex programs, cpp
-
-These options control the C preprocessor, which is run on each C source
-file before actual compilation.
-
-@xref{Preprocessor Options,,Options Controlling the Preprocessor,
-gcc,Using the GNU Compiler Collection (GCC)}, for information on C
-preprocessor options.
-
-@cindex INCLUDE directive
-@cindex directive, INCLUDE
-Some of these options also affect how @command{g77} processes the
-@code{INCLUDE} directive.
-Since this directive is processed even when preprocessing
-is not requested, it is not described in this section.
-@xref{Directory Options,,Options for Directory Search}, for
-information on how @command{g77} processes the @code{INCLUDE} directive.
-
-However, the @code{INCLUDE} directive does not apply
-preprocessing to the contents of the included file itself.
-
-Therefore, any file that contains preprocessor directives
-(such as @code{#include}, @code{#define}, and @code{#if})
-must be included via the @code{#include} directive, not
-via the @code{INCLUDE} directive.
-Therefore, any file containing preprocessor directives,
-if included, is necessarily included by a file that itself
-contains preprocessor directives.
-
-@node Directory Options
-@section Options for Directory Search
-@cindex directory, options
-@cindex options, directory search
-@cindex search path
-
-These options affect how the @command{cpp} preprocessor searches
-for files specified via the @code{#include} directive.
-Therefore, when compiling Fortran programs, they are meaningful
-when the preprocessor is used.
-
-@cindex INCLUDE directive
-@cindex directive, INCLUDE
-Some of these options also affect how @command{g77} searches
-for files specified via the @code{INCLUDE} directive,
-although files included by that directive are not,
-themselves, preprocessed.
-These options are:
-
-@table @gcctabopt
-@cindex -I- option
-@cindex options, -I-
-@item -I-
-@cindex -Idir option
-@cindex options, -Idir
-@item -I@var{dir}
-@cindex directory, search paths for inclusion
-@cindex inclusion, directory search paths for
-@cindex search paths, for included files
-@cindex paths, search
-These affect interpretation of the @code{INCLUDE} directive
-(as well as of the @code{#include} directive of the @command{cpp}
-preprocessor).
-
-Note that @option{-I@var{dir}} must be specified @emph{without} any
-spaces between @option{-I} and the directory name---that is,
-@option{-Ifoo/bar} is valid, but @option{-I foo/bar}
-is rejected by the @command{g77} compiler (though the preprocessor supports
-the latter form).
-@c this is due to toplev.c's inflexible option processing
-Also note that the general behavior of @option{-I} and
-@code{INCLUDE} is pretty much the same as of @option{-I} with
-@code{#include} in the @command{cpp} preprocessor, with regard to
-looking for @file{header.gcc} files and other such things.
-
-@xref{Directory Options,,Options for Directory Search,
-gcc,Using the GNU Compiler Collection (GCC)}, for information on the
-@option{-I} option.
-@end table
-
-@node Code Gen Options
-@section Options for Code Generation Conventions
-@cindex code generation, conventions
-@cindex options, code generation
-@cindex run-time, options
-
-These machine-independent options control the interface conventions
-used in code generation.
-
-Most of them have both positive and negative forms; the negative form
-of @option{-ffoo} would be @option{-fno-foo}. In the table below, only
-one of the forms is listed---the one which is not the default. You
-can figure out the other form by either removing @option{no-} or adding
-it.
-
-@table @gcctabopt
-@cindex -fno-automatic option
-@cindex options, -fno-automatic
-@item -fno-automatic
-@cindex SAVE statement
-@cindex statements, SAVE
-Treat each program unit as if the @code{SAVE} statement was specified
-for every local variable and array referenced in it.
-Does not affect common blocks.
-(Some Fortran compilers provide this option under
-the name @option{-static}.)
-
-@cindex -finit-local-zero option
-@cindex options, -finit-local-zero
-@item -finit-local-zero
-@cindex DATA statement
-@cindex statements, DATA
-@cindex initialization, of local variables
-@cindex variables, initialization of
-@cindex uninitialized variables
-@cindex variables, uninitialized
-Specify that variables and arrays that are local to a program unit
-(not in a common block and not passed as an argument) are to be initialized
-to binary zeros.
-
-Since there is a run-time penalty for initialization of variables
-that are not given the @code{SAVE} attribute, it might be a
-good idea to also use @option{-fno-automatic} with @option{-finit-local-zero}.
-
-@cindex -fno-f2c option
-@cindex options, -fno-f2c
-@item -fno-f2c
-@cindex @command{f2c} compatibility
-@cindex compatibility, @command{f2c}
-Do not generate code designed to be compatible with code generated
-by @command{f2c} use the GNU calling conventions instead.
-
-The @command{f2c} calling conventions require functions that return
-type @code{REAL(KIND=1)} to actually return the C type @code{double},
-and functions that return type @code{COMPLEX} to return the
-values via an extra argument in the calling sequence that points
-to where to store the return value.
-Under the GNU calling conventions, such functions simply return
-their results as they would in GNU C---@code{REAL(KIND=1)} functions
-return the C type @code{float}, and @code{COMPLEX} functions
-return the GNU C type @code{complex} (or its @code{struct}
-equivalent).
-
-This does not affect the generation of code that interfaces with the
-@code{libg2c} library.
-
-However, because the @code{libg2c} library uses @command{f2c}
-calling conventions, @command{g77} rejects attempts to pass
-intrinsics implemented by routines in this library as actual
-arguments when @option{-fno-f2c} is used, to avoid bugs when
-they are actually called by code expecting the GNU calling
-conventions to work.
-
-For example, @samp{INTRINSIC ABS;CALL FOO(ABS)} is
-rejected when @option{-fno-f2c} is in force.
-(Future versions of the @command{g77} run-time library might
-offer routines that provide GNU-callable versions of the
-routines that implement the @command{f2c} intrinsics
-that may be passed as actual arguments, so that
-valid programs need not be rejected when @option{-fno-f2c}
-is used.)
-
-@strong{Caution:} If @option{-fno-f2c} is used when compiling any
-source file used in a program, it must be used when compiling
-@emph{all} Fortran source files used in that program.
-
-@c seems kinda dumb to tell people about an option they can't use -- jcb
-@c then again, we want users building future-compatible libraries with it.
-@cindex -ff2c-library option
-@cindex options, -ff2c-library
-@item -ff2c-library
-Specify that use of @code{libg2c} (or the original @code{libf2c})
-is required.
-This is the default for the current version of @command{g77}
-
-Currently it is not
-valid to specify @option{-fno-f2c-library}.
-This option is provided so users can specify it in shell
-scripts that build programs and libraries that require the
-@code{libf2c} library, even when being compiled by future
-versions of @command{g77} that might otherwise default to
-generating code for an incompatible library.
-
-@cindex -fno-underscoring option
-@cindex options, -fno-underscoring
-@item -fno-underscoring
-@cindex underscore
-@cindex symbol names, underscores
-@cindex transforming symbol names
-@cindex symbol names, transforming
-Do not transform names of entities specified in the Fortran
-source file by appending underscores to them.
-
-With @option{-funderscoring} in effect, @command{g77} appends two underscores
-to names with underscores and one underscore to external names with
-no underscores. (@command{g77} also appends two underscores to internal
-names with underscores to avoid naming collisions with external names.
-The @option{-fno-second-underscore} option disables appending of the
-second underscore in all cases.)
-
-This is done to ensure compatibility with code produced by many
-UNIX Fortran compilers, including @command{f2c} which perform the
-same transformations.
-
-Use of @option{-fno-underscoring} is not recommended unless you are
-experimenting with issues such as integration of (GNU) Fortran into
-existing system environments (vis-a-vis existing libraries, tools, and
-so on).
-
-For example, with @option{-funderscoring}, and assuming other defaults like
-@option{-fcase-lower} and that @samp{j()} and @samp{max_count()} are
-external functions while @samp{my_var} and @samp{lvar} are local variables,
-a statement like
-
-@smallexample
-I = J() + MAX_COUNT (MY_VAR, LVAR)
-@end smallexample
-
-@noindent
-is implemented as something akin to:
-
-@smallexample
-i = j_() + max_count__(&my_var__, &lvar);
-@end smallexample
-
-With @option{-fno-underscoring}, the same statement is implemented as:
-
-@smallexample
-i = j() + max_count(&my_var, &lvar);
-@end smallexample
-
-Use of @option{-fno-underscoring} allows direct specification of
-user-defined names while debugging and when interfacing @command{g77}
-code with other languages.
-
-Note that just because the names match does @emph{not} mean that the
-interface implemented by @command{g77} for an external name matches the
-interface implemented by some other language for that same name.
-That is, getting code produced by @command{g77} to link to code produced
-by some other compiler using this or any other method can be only a
-small part of the overall solution---getting the code generated by
-both compilers to agree on issues other than naming can require
-significant effort, and, unlike naming disagreements, linkers normally
-cannot detect disagreements in these other areas.
-
-Also, note that with @option{-fno-underscoring}, the lack of appended
-underscores introduces the very real possibility that a user-defined
-external name will conflict with a name in a system library, which
-could make finding unresolved-reference bugs quite difficult in some
-cases---they might occur at program run time, and show up only as
-buggy behavior at run time.
-
-In future versions of @command{g77} we hope to improve naming and linking
-issues so that debugging always involves using the names as they appear
-in the source, even if the names as seen by the linker are mangled to
-prevent accidental linking between procedures with incompatible
-interfaces.
-
-@cindex -fno-second-underscore option
-@cindex options, -fno-second-underscore
-@item -fno-second-underscore
-@cindex underscore
-@cindex symbol names, underscores
-@cindex transforming symbol names
-@cindex symbol names, transforming
-Do not append a second underscore to names of entities specified
-in the Fortran source file.
-
-This option has no effect if @option{-fno-underscoring} is
-in effect.
-
-Otherwise, with this option, an external name such as @samp{MAX_COUNT}
-is implemented as a reference to the link-time external symbol
-@samp{max_count_}, instead of @samp{max_count__}.
-
-@cindex -fno-ident option
-@cindex options, -fno-ident
-@item -fno-ident
-Ignore the @samp{#ident} directive.
-
-@cindex -fzeros option
-@cindex options, -fzeros
-@item -fzeros
-Treat initial values of zero as if they were any other value.
-
-As of version 0.5.18, @command{g77} normally treats @code{DATA} and
-other statements that are used to specify initial values of zero
-for variables and arrays as if no values were actually specified,
-in the sense that no diagnostics regarding multiple initializations
-are produced.
-
-This is done to speed up compiling of programs that initialize
-large arrays to zeros.
-
-Use @option{-fzeros} to revert to the simpler, slower behavior
-that can catch multiple initializations by keeping track of
-all initializations, zero or otherwise.
-
-@emph{Caution:} Future versions of @command{g77} might disregard this option
-(and its negative form, the default) or interpret it somewhat
-differently.
-The interpretation changes will affect only non-standard
-programs; standard-conforming programs should not be affected.
-
-@cindex -femulate-complex option
-@cindex options, -femulate-complex
-@item -femulate-complex
-Implement @code{COMPLEX} arithmetic via emulation,
-instead of using the facilities of
-the @command{gcc} back end that provide direct support of
-@code{complex} arithmetic.
-
-(@command{gcc} had some bugs in its back-end support
-for @code{complex} arithmetic, due primarily to the support not being
-completed as of version 2.8.1 and @code{egcs} 1.1.2.)
-
-Use @option{-femulate-complex} if you suspect code-generation bugs,
-or experience compiler crashes,
-that might result from @command{g77} using the @code{COMPLEX} support
-in the @command{gcc} back end.
-If using that option fixes the bugs or crashes you are seeing,
-that indicates a likely @command{g77} bugs
-(though, all compiler crashes are considered bugs),
-so, please report it.
-(Note that the known bugs, now believed fixed, produced compiler crashes
-rather than causing the generation of incorrect code.)
-
-Use of this option should not affect how Fortran code compiled
-by @command{g77} works in terms of its interfaces to other code,
-e.g. that compiled by @command{f2c}
-
-As of GCC version 3.0, this option is not necessary anymore.
-
-@emph{Caution:} Future versions of @command{g77} might ignore both forms
-of this option.
-
-@cindex -falias-check option
-@cindex options, -falias-check
-@cindex -fargument-alias option
-@cindex options, -fargument-alias
-@cindex -fargument-noalias option
-@cindex options, -fargument-noalias
-@cindex -fno-argument-noalias-global option
-@cindex options, -fno-argument-noalias-global
-@item -falias-check
-@item -fargument-alias
-@item -fargument-noalias
-@item -fno-argument-noalias-global
-@emph{Version info:}
-These options are not supported by
-versions of @command{g77} based on @command{gcc} version 2.8.
-
-These options specify to what degree aliasing
-(overlap)
-is permitted between
-arguments (passed as pointers) and @code{COMMON} (external, or
-public) storage.
-
-The default for Fortran code, as mandated by the FORTRAN 77 and
-Fortran 90 standards, is @option{-fargument-noalias-global}.
-The default for code written in the C language family is
-@option{-fargument-alias}.
-
-Note that, on some systems, compiling with @option{-fforce-addr} in
-effect can produce more optimal code when the default aliasing
-options are in effect (and when optimization is enabled).
-
-@xref{Aliasing Assumed To Work}, for detailed information on the implications
-of compiling Fortran code that depends on the ability to alias dummy
-arguments.
-
-@cindex -fno-globals option
-@cindex options, -fno-globals
-@item -fno-globals
-@cindex global names, warning
-@cindex warnings, global names
-@cindex in-line code
-@cindex compilation, in-line
-Disable diagnostics about inter-procedural
-analysis problems, such as disagreements about the
-type of a function or a procedure's argument,
-that might cause a compiler crash when attempting
-to inline a reference to a procedure within a
-program unit.
-(The diagnostics themselves are still produced, but
-as warnings, unless @option{-Wno-globals} is specified,
-in which case no relevant diagnostics are produced.)
-
-Further, this option disables such inlining, to
-avoid compiler crashes resulting from incorrect
-code that would otherwise be diagnosed.
-
-As such, this option might be quite useful when
-compiling existing, ``working'' code that happens
-to have a few bugs that do not generally show themselves,
-but which @command{g77} diagnoses.
-
-Use of this option therefore has the effect of
-instructing @command{g77} to behave more like it did
-up through version 0.5.19.1, when it paid little or
-no attention to disagreements between program units
-about a procedure's type and argument information,
-and when it performed no inlining of procedures
-(except statement functions).
-
-Without this option, @command{g77} defaults to performing
-the potentially inlining procedures as it started doing
-in version 0.5.20, but as of version 0.5.21, it also
-diagnoses disagreements that might cause such inlining
-to crash the compiler as (fatal) errors,
-and warns about similar disagreements
-that are currently believed to not
-likely to result in the compiler later crashing
-or producing incorrect code.
-
-@cindex -fflatten-arrays option
-@item -fflatten-arrays
-@cindex array performance
-@cindex arrays, flattening
-Use back end's C-like constructs
-(pointer plus offset)
-instead of its @code{ARRAY_REF} construct
-to handle all array references.
-
-@emph{Note:} This option is not supported.
-It is intended for use only by @command{g77} developers,
-to evaluate code-generation issues.
-It might be removed at any time.
-
-@cindex -fbounds-check option
-@cindex -ffortran-bounds-check option
-@item -fbounds-check
-@itemx -ffortran-bounds-check
-@cindex bounds checking
-@cindex range checking
-@cindex array bounds checking
-@cindex subscript checking
-@cindex substring checking
-@cindex checking subscripts
-@cindex checking substrings
-Enable generation of run-time checks for array subscripts
-and substring start and end points
-against the (locally) declared minimum and maximum values.
-
-The current implementation uses the @code{libf2c}
-library routine @code{s_rnge} to print the diagnostic.
-
-However, whereas @command{f2c} generates a single check per
-reference for a multi-dimensional array, of the computed
-offset against the valid offset range (0 through the size of the array),
-@command{g77} generates a single check per @emph{subscript} expression.
-This catches some cases of potential bugs that @command{f2c} does not,
-such as references to below the beginning of an assumed-size array.
-
-@command{g77} also generates checks for @code{CHARACTER} substring references,
-something @command{f2c} currently does not do.
-
-Use the new @option{-ffortran-bounds-check} option
-to specify bounds-checking for only the Fortran code you are compiling,
-not necessarily for code written in other languages.
-
-@emph{Note:} To provide more detailed information on the offending subscript,
-@command{g77} provides the @code{libg2c} run-time library routine @code{s_rnge}
-with somewhat differently-formatted information.
-Here's a sample diagnostic:
-
-@smallexample
-Subscript out of range on file line 4, procedure rnge.f/bf.
-Attempt to access the -6-th element of variable b[subscript-2-of-2].
-Aborted
-@end smallexample
-
-The above message indicates that the offending source line is
-line 4 of the file @file{rnge.f},
-within the program unit (or statement function) named @samp{bf}.
-The offended array is named @samp{b}.
-The offended array dimension is the second for a two-dimensional array,
-and the offending, computed subscript expression was @samp{-6}.
-
-For a @code{CHARACTER} substring reference, the second line has
-this appearance:
-
-@smallexample
-Attempt to access the 11-th element of variable a[start-substring].
-@end smallexample
-
-This indicates that the offended @code{CHARACTER} variable or array
-is named @samp{a},
-the offended substring position is the starting (leftmost) position,
-and the offending substring expression is @samp{11}.
-
-(Though the verbage of @code{s_rnge} is not ideal
-for the purpose of the @command{g77} compiler,
-the above information should provide adequate diagnostic abilities
-to it users.)
-@end table
-
-@xref{Code Gen Options,,Options for Code Generation Conventions,
-gcc,Using the GNU Compiler Collection (GCC)}, for information on more options
-offered by the GBE
-shared by @command{g77} @command{gcc} and other GNU compilers.
-
-Some of these do @emph{not} work when compiling programs written in Fortran:
-
-@table @gcctabopt
-@cindex -fpcc-struct-return option
-@cindex options, -fpcc-struct-return
-@item -fpcc-struct-return
-@cindex -freg-struct-return option
-@cindex options, -freg-struct-return
-@item -freg-struct-return
-You should not use these except strictly the same way as you
-used them to build the version of @code{libg2c} with which
-you will be linking all code compiled by @command{g77} with the
-same option.
-
-@cindex -fshort-double option
-@cindex options, -fshort-double
-@item -fshort-double
-This probably either has no effect on Fortran programs, or
-makes them act loopy.
-
-@cindex -fno-common option
-@cindex options, -fno-common
-@item -fno-common
-Do not use this when compiling Fortran programs,
-or there will be Trouble.
-
-@cindex -fpack-struct option
-@cindex options, -fpack-struct
-@item -fpack-struct
-This probably will break any calls to the @code{libg2c} library,
-at the very least, even if it is built with the same option.
-@end table
-
-@c man end
-
-@node Environment Variables
-@section Environment Variables Affecting GNU Fortran
-@cindex environment variables
-
-@c man begin ENVIRONMENT
-
-GNU Fortran currently does not make use of any environment
-variables to control its operation above and beyond those
-that affect the operation of @command{gcc}.
-
-@xref{Environment Variables,,Environment Variables Affecting GCC,
-gcc,Using the GNU Compiler Collection (GCC)}, for information on environment
-variables.
-
-@c man end
+++ /dev/null
-/* lab.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
-
- Description:
- Complex data abstraction for Fortran labels. Maintains a single master
- list for all labels; it is expected initialization and termination of
- this list will occur on program-unit boundaries.
-
- Modifications:
- 22-Aug-89 JCB 1.1
- Change ffelab_new for new ffewhere interface.
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "lab.h"
-#include "malloc.h"
-
-/* Externals defined here. */
-
-ffelab ffelab_list_;
-ffelabNumber ffelab_num_news_;
-
-/* Simple definitions and enumerations. */
-
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-
-/* Static objects accessed by functions in this module. */
-
-
-/* Static functions (internal). */
-
-
-/* Internal macros. */
-\f
-
-/* ffelab_find -- Find the ffelab object having the desired label value
-
- ffelab l;
- ffelabValue v;
- l = ffelab_find(v);
-
- If the desired ffelab object doesn't exist, returns NULL.
-
- Straightforward search of list of ffelabs. */
-
-ffelab
-ffelab_find (ffelabValue v)
-{
- ffelab l;
-
- for (l = ffelab_list_; (l != NULL) && (ffelab_value (l) != v); l = l->next)
- ;
-
- return l;
-}
-
-/* ffelab_finish -- Shut down label management
-
- ffelab_finish();
-
- At the end of processing a program unit, call this routine to shut down
- label management.
-
- Kill all the labels on the list. */
-
-void
-ffelab_finish (void)
-{
- ffelab l;
- ffelab pl;
-
- for (pl = NULL, l = ffelab_list_; l != NULL; pl = l, l = l->next)
- if (pl != NULL)
- malloc_kill_ks (ffe_pool_any_unit (), pl, sizeof (*pl));
-
- if (pl != NULL)
- malloc_kill_ks (ffe_pool_any_unit (), pl, sizeof (*pl));
-}
-
-/* ffelab_init_3 -- Initialize label management system
-
- ffelab_init_3();
-
- Initialize the label management system. Do this before a new program
- unit is going to be processed. */
-
-void
-ffelab_init_3 (void)
-{
- ffelab_list_ = NULL;
- ffelab_num_news_ = 0;
-}
-
-/* ffelab_new -- Create an ffelab object.
-
- ffelab l;
- ffelabValue v;
- l = ffelab_new(v);
-
- Create a label having a given value. If the value isn't known, pass
- FFELAB_valueNONE, and set it later with ffelab_set_value.
-
- Allocate, initialize, and stick at top of label list.
-
- 22-Aug-89 JCB 1.1
- Change for new ffewhere interface. */
-
-ffelab
-ffelab_new (ffelabValue v)
-{
- ffelab l;
-
- ++ffelab_num_news_;
- l = malloc_new_ks (ffe_pool_any_unit (), "FFELAB label", sizeof (*l));
- l->next = ffelab_list_;
- l->hook = FFECOM_labelNULL;
- l->value = v;
- l->firstref_line = ffewhere_line_unknown ();
- l->firstref_col = ffewhere_column_unknown ();
- l->doref_line = ffewhere_line_unknown ();
- l->doref_col = ffewhere_column_unknown ();
- l->definition_line = ffewhere_line_unknown ();
- l->definition_col = ffewhere_column_unknown ();
- l->type = FFELAB_typeUNKNOWN;
- ffelab_list_ = l;
- return l;
-}
+++ /dev/null
-/* lab.h -- Public #include File (module.h template V1.0)
- Copyright (C) 1995, 2003 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Owning Modules:
- lab.c
-
- Modifications:
- 22-Aug-89 JCB 1.1
- Change for new ffewhere interface.
-*/
-
-/* Allow multiple inclusion to work. */
-
-#ifndef GCC_F_LAB_H
-#define GCC_F_LAB_H
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFELAB_typeUNKNOWN, /* No info yet on label. */
- FFELAB_typeANY, /* Label valid for anything, no msgs. */
- FFELAB_typeUSELESS, /* No valid way to reference this label. */
- FFELAB_typeASSIGNABLE, /* Target of ASSIGN: so FORMAT or BRANCH. */
- FFELAB_typeFORMAT, /* FORMAT label. */
- FFELAB_typeLOOPEND, /* Target of a labeled DO statement. */
- FFELAB_typeNOTLOOP, /* Branch target statement not valid DO
- target. */
- FFELAB_typeENDIF, /* END IF label. */
- FFELAB_type
- } ffelabType;
-
-#define FFELAB_valueNONE 0
-#define FFELAB_valueMAX 99999
-
-/* Typedefs. */
-
-typedef struct _ffelab_ *ffelab;
-typedef ffelab ffelabHandle;
-typedef unsigned long ffelabNumber; /* Count of new labels. */
-#define ffelabNumber_f "l"
-typedef unsigned long ffelabValue;
-#define ffelabValue_f "l"
-
-/* Include files needed by this one. */
-
-#include "com.h"
-#include "where.h"
-
-/* Structure definitions. */
-
-struct _ffelab_
- {
- ffelab next;
- ffecomLabel hook;
- ffelabValue value; /* 1 through 99999, or 100000+ for temp
- labels. */
- unsigned long blocknum; /* Managed entirely by user of module. */
- ffewhereLine firstref_line;
- ffewhereColumn firstref_col;
- ffewhereLine doref_line;
- ffewhereColumn doref_col;
- ffewhereLine definition_line; /* ffewhere_line_unknown() if not
- defined. */
- ffewhereColumn definition_col;
- ffelabType type;
- };
-
-/* Global objects accessed by users of this module. */
-
-extern ffelab ffelab_list_;
-extern ffelabNumber ffelab_num_news_;
-
-/* Declare functions with prototypes. */
-
-ffelab ffelab_find (ffelabValue v);
-void ffelab_finish (void);
-void ffelab_init_3 (void);
-ffelab ffelab_new (ffelabValue v);
-
-/* Define macros. */
-
-#define ffelab_blocknum(l) ((l)->blocknum)
-#define ffelab_definition_column(l) ((l)->definition_col)
-#define ffelab_definition_filename(l) \
- ffewhere_line_filename((l)->definition_line)
-#define ffelab_definition_filelinenum(l) \
- ffewhere_line_filelinenum((l)->definition_line)
-#define ffelab_definition_line(l) ((l)->definition_line)
-#define ffelab_definition_line_number(l) \
- ffewhere_line_number((l)->definition_line)
-#define ffelab_doref_column(l) ((l)->doref_col)
-#define ffelab_doref_filename(l) ffewhere_line_filename((l)->doref_line)
-#define ffelab_doref_filelinenum(l) ffewhere_line_filelinenum((l)->doref_line)
-#define ffelab_doref_line(l) ((l)->doref_line)
-#define ffelab_doref_line_number(l) ffewhere_line_number((l)->doref_line)
-#define ffelab_firstref_column(l) ((l)->firstref_col)
-#define ffelab_firstref_filename(l) ffewhere_line_filename((l)->firstref_line)
-#define ffelab_firstref_filelinenum(l) \
- ffewhere_line_filelinenum((l)->firstref_line)
-#define ffelab_firstref_line(l) ((l)->firstref_line)
-#define ffelab_firstref_line_number(l) ffewhere_line_number((l)->firstref_line)
-#define ffelab_handle_done(h)
-#define ffelab_handle_first() ((ffelabHandle) ffelab_list_)
-#define ffelab_handle_next(h) ((ffelabHandle) (((ffelab) h)->next))
-#define ffelab_handle_target(h) ((ffelab) h)
-#define ffelab_hook(l) ((l)->hook)
-#define ffelab_init_0()
-#define ffelab_init_1()
-#define ffelab_init_2()
-#define ffelab_init_4()
-#define ffelab_kill(l) ffelab_set_value(l,FFELAB_valueNONE);
-#define ffelab_new_generated() (ffelab_new(ffelab_generated_++))
-#define ffelab_number() (ffelab_num_news_)
-#define ffelab_set_blocknum(l,b) ((l)->blocknum = (b))
-#define ffelab_set_definition_column(l,cn) ((l)->definition_col = (cn))
-#define ffelab_set_definition_line(l,ln) ((l)->definition_line = (ln))
-#define ffelab_set_doref_column(l,cn) ((l)->doref_col = (cn))
-#define ffelab_set_doref_line(l,ln) ((l)->doref_line = (ln))
-#define ffelab_set_firstref_column(l,cn) ((l)->firstref_col = (cn))
-#define ffelab_set_firstref_line(l,ln) ((l)->firstref_line = (ln))
-#define ffelab_set_hook(l,h) ((l)->hook = (h))
-#define ffelab_set_type(l,t) ((l)->type = (t))
-#define ffelab_terminate_0()
-#define ffelab_terminate_1()
-#define ffelab_terminate_2()
-#define ffelab_terminate_3()
-#define ffelab_terminate_4()
-#define ffelab_type(l) ((l)->type)
-#define ffelab_value(l) ((l)->value)
-
-/* End of #include file. */
-
-#endif /* ! GCC_F_LAB_H */
+++ /dev/null
-/* lang-specs.h file for Fortran
- Copyright (C) 1995, 1996, 1997, 1999, 2000, 2002, 2003
- Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
-*/
-
-/* This is the contribution to the `default_compilers' array in gcc.c for
- g77. */
-
- {".F", "@f77-cpp-input", 0},
- {".fpp", "@f77-cpp-input", 0},
- {".FPP", "@f77-cpp-input", 0},
- {"@f77-cpp-input",
- "cc1 -E -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \
- %{E|M|MM:%(cpp_debug_options)}\
- %{!M:%{!MM:%{!E: -o %|.f |\n\
- f771 %|.f %(cc1_options) %{I*} %{!fsyntax-only:%(invoke_as)}}}}", 0},
- {".r", "@ratfor", 0},
- {"@ratfor",
- "%{C:%{!E:%eGCC does not support -C without using -E}}\
- %{CC:%{!E:%eGCC does not support -CC without using -E}}\
- ratfor %{C} %{CC} %{v} %{E:%W{o*}} %{!E: %{!pipe:-o %g.f} %i |\n\
- f771 %m.f %(cc1_options) %{I*} %{!fsyntax-only:%(invoke_as)}}", 0},
- {".f", "@f77", 0},
- {".for", "@f77", 0},
- {".FOR", "@f77", 0},
- {"@f77",
- "%{!M:%{!MM:%{!E:f771 %i %(cc1_options) %{I*}\
- %{!fsyntax-only:%(invoke_as)}}}}", 0},
+++ /dev/null
-; Options for the Fortran 77 front end.
-; Copyright (C) 2003 Free Software Foundation, Inc.
-;
-; This file is part of GCC.
-;
-; GCC is free software; you can redistribute it and/or modify it under
-; the terms of the GNU General Public License as published by the Free
-; Software Foundation; either version 2, or (at your option) any later
-; version.
-;
-; GCC is distributed in the hope that it will be useful, but WITHOUT ANY
-; WARRANTY; without even the implied warranty of MERCHANTABILITY or
-; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-; for more details.
-;
-; You should have received a copy of the GNU General Public License
-; along with GCC; see the file COPYING. If not, write to the Free
-; Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-; 02111-1307, USA.
-
-; See c.opt for a description of this file's format.
-
-; Please try to keep this file in ASCII collating order.
-
-Language
-F77
-
-I
-F77 Joined
-Add a directory for INCLUDE searching
-
-Wall
-F77
-; Documented in C
-
-Wcomment
-F77
-
-Wcomments
-F77
-
-Wglobals
-F77
-Enable warnings about inter-procedural problems
-
-Wimplicit
-F77
-
-Wimport
-F77
-
-Wsurprising
-F77
-Warn about constructs with surprising meanings
-
-Wtrigraphs
-F77
-
-fautomatic
-F77
-Do not treat local variables and COMMON blocks as if they were named in SAVE statements
-
-fbackslash
-F77
-Backslashes in character and hollerith constants are special (not C-style)
-
-fbadu77-intrinsics-delete
-F77 RejectNegative
-Delete libU77 intrinsics with bad interfaces
-
-fbadu77-intrinsics-disable
-F77 RejectNegative
-Disable libU77 intrinsics with bad interfaces
-
-fbadu77-intrinsics-enable
-F77 RejectNegative
-Enable libU77 intrinsics with bad interfaces
-
-fbadu77-intrinsics-hide
-F77 RejectNegative
-Hide libU77 intrinsics with bad interfaces
-
-fcase-initcap
-F77 RejectNegative
-Program written in strict mixed-case
-
-fcase-lower
-F77 RejectNegative
-Compile as if program written in lowercase
-
-fcase-preserve
-F77 RejectNegative
-Preserve case used in program
-
-fcase-strict-lower
-F77 RejectNegative
-Program written in lowercase
-
-fcase-strict-upper
-F77 RejectNegative
-Program written in uppercase
-
-fcase-upper
-F77 RejectNegative
-Compile as if program written in uppercase
-
-fdebug-kludge
-F77
-Emit special debugging information for COMMON and EQUIVALENCE (disabled)
-
-fdollar-ok
-F77
-Allow '$' in symbol names
-
-femulate-complex
-F77
-Have front end emulate COMPLEX arithmetic to avoid bugs
-
-ff2c
-F77
-f2c-compatible code can be generated
-
-ff2c-intrinsics-delete
-F77 RejectNegative
-Delete non-FORTRAN-77 intrinsics f2c supports
-
-ff2c-intrinsics-disable
-F77 RejectNegative
-Disable non-FORTRAN-77 intrinsics f2c supports
-
-ff2c-intrinsics-enable
-F77 RejectNegative
-Enable non-FORTRAN-77 intrinsics f2c supports
-
-ff2c-intrinsics-hide
-F77 RejectNegative
-Hide non-FORTRAN-77 intrinsics f2c supports
-
-ff2c-library
-F77
-Unsupported; generate libf2c-calling code
-
-ff66
-F77
-Program is written in typical FORTRAN 66 dialect
-
-ff77
-F77
-Program is written in typical Unix-f77 dialect
-
-ff90
-F77
-Program is written in Fortran-90-ish dialect
-
-ff90-intrinsics-delete
-F77 RejectNegative
-Delete non-FORTRAN-77 intrinsics F90 supports
-
-ff90-intrinsics-disable
-F77 RejectNegative
-Disable non-FORTRAN-77 intrinsics F90 supports
-
-ff90-intrinsics-enable
-F77 RejectNegative
-Enable non-FORTRAN-77 intrinsics F90 supports
-
-ff90-intrinsics-hide
-F77 RejectNegative
-Hide non-FORTRAN-77 intrinsics F90 supports
-
-ff90-not-vxt
-F77 RejectNegative
-
-ffixed-form
-F77
-
-ffixed-line-length-
-F77 Joined
-ffixed-line-length-<number> Set the maximum line length to <number>
-
-fflatten-arrays
-F77
-Unsupported; affects code generation of arrays
-
-ffortran-bounds-check
-F77
-Generate code to check subscript and substring bounds
-
-ffree-form
-F77
-Program is written in Fortran-90-ish free form
-
-fglobals
-F77
-Enable fatal diagnostics about inter-procedural problems
-
-fgnu-intrinsics-delete
-F77 RejectNegative
-Delete non-FORTRAN-77 intrinsics g77 supports
-
-fgnu-intrinsics-disable
-F77 RejectNegative
-Disable non-FORTRAN 77 intrinsics F90 supports
-
-fgnu-intrinsics-enable
-F77 RejectNegative
-Enable non-FORTRAN 77 intrinsics F90 supports
-
-fgnu-intrinsics-hide
-F77 RejectNegative
-Hide non-FORTRAN 77 intrinsics F90 supports
-
-finit-local-zero
-F77
-Initialize local vars and arrays to zero
-
-fintrin-case-any
-F77 RejectNegative
-Intrinsics letters in arbitrary cases
-
-fintrin-case-initcap
-F77 RejectNegative
-Intrinsics spelled as e.g. SqRt
-
-fintrin-case-lower
-F77 RejectNegative
-Intrinsics in lowercase
-
-fintrin-case-upper
-F77 RejectNegative
-Intrinsics in uppercase
-
-fmatch-case-any
-F77 RejectNegative
-Language keyword letters in arbitrary cases
-
-fmatch-case-initcap
-F77 RejectNegative
-Language keywords spelled as e.g. IOStat
-
-fmatch-case-lower
-F77 RejectNegative
-Language keywords in lowercase
-
-fmatch-case-upper
-F77 RejectNegative
-Language keywords in uppercase
-
-fmil-intrinsics-delete
-F77 RejectNegative
-Delete MIL-STD 1753 intrinsics
-
-fmil-intrinsics-disable
-F77 RejectNegative
-Disable MIL-STD 1753 intrinsics
-
-fmil-intrinsics-enable
-F77 RejectNegative
-Enable MIL-STD 1753 intrinsics
-
-fmil-intrinsics-hide
-F77 RejectNegative
-Hide MIL-STD 1753 intrinsics
-
-fonetrip
-F77
-Take at least one trip through each iterative DO loop
-
-fpedantic
-F77
-Warn about use of (only a few for now) Fortran extensions
-
-fpreprocessed
-F77
-
-fsecond-underscore
-F77
-Allow appending a second underscore to externals
-
-fsilent
-F77
-Do not print names of program units as they are compiled
-
-fsource-case-lower
-F77 RejectNegative
-Internally convert most source to lowercase
-
-fsource-case-preserve
-F77 RejectNegative
-Internally preserve source case
-
-fsource-case-upper
-F77 RejectNegative
-Internally convert most source to uppercase
-
-fsymbol-case-any
-F77 RejectNegative
-
-fsymbol-case-initcap
-F77 RejectNegative
-Symbol names spelled in mixed case
-
-fsymbol-case-lower
-F77 RejectNegative
-Symbol names in lowercase
-
-fsymbol-case-upper
-F77 RejectNegative
-Symbol names in uppercase
-
-ftypeless-boz
-F77
-Make prefix-radix non-decimal constants be typeless
-
-fugly
-F77
-Allow all ugly features
-
-fugly-args
-F77
-Hollerith and typeless can be passed as arguments
-
-fugly-assign
-F77
-Allow ordinary copying of ASSIGN'ed vars
-
-fugly-assumed
-F77
-Dummy array dimensioned to (1) is assumed-size
-
-fugly-comma
-F77
-Trailing comma in procedure call denotes null argument
-
-fugly-complex
-F77
-Allow REAL(Z) and AIMAG(Z) given DOUBLE COMPLEX Z
-
-fugly-init
-F77
-Initialization via DATA and PARAMETER is not type-compatible
-
-fugly-logint
-F77
-Allow INTEGER and LOGICAL interchangeability
-
-funderscoring
-F77
-Append underscores to externals
-
-funix-intrinsics-delete
-F77 RejectNegative
-Delete libU77 intrinsics
-
-funix-intrinsics-disable
-F77 RejectNegative
-Disable libU77 intrinsics
-
-funix-intrinsics-enable
-F77 RejectNegative
-Enable libU77 intrinsics
-
-funix-intrinsics-hide
-F77 RejectNegative
-Hide libU77 intrinsics
-
-fversion
-F77 RejectNegative
-Print g77-specific version information and run internal tests
-
-fvxt
-F77
-Program is written in VXT (Digital-like) FORTRAN
-
-fvxt-intrinsics-delete
-F77 RejectNegative
-Delete non-FORTRAN-77 intrinsics VXT FORTRAN supports
-
-fvxt-intrinsics-disable
-F77 RejectNegative
-Disable non-FORTRAN-77 intrinsics VXT FORTRAN supports
-
-fvxt-intrinsics-enable
-F77 RejectNegative
-Enable non-FORTRAN-77 intrinsics VXT FORTRAN supports
-
-fvxt-intrinsics-hide
-F77 RejectNegative
-Hide non-FORTRAN-77 intrinsics VXT FORTRAN supports
-
-fvxt-not-f90
-F77 RejectNegative
-
-fxyzzy
-F77
-Print internal debugging-related information
-
-fzeros
-F77
-Treat initial values of 0 like non-zero values
-
-; This comment is to ensure we retain the blank line above.
+++ /dev/null
-* Fixed by 1998-09-28 libI77/open.c change.
- open(90,status='scratch')
- write(90, '(1X, I1 / 1X, I1)') 1, 2
- rewind 90
- write(90, '(1X, I1)') 1
- rewind 90 ! implicit ENDFILE expected
- read(90, *) i
- read(90, *, end=10) j
- call abort()
- 10 end
+++ /dev/null
-# Scratch files aren't implemented for mmixware
-# (_stat is a stub and files can't be deleted).
-# Similar restrictions exist for most simulators.
-
-if { [istarget "mmix-knuth-mmixware"]
- || [istarget "arm*-*-elf"]
- || [istarget "strongarm*-*-elf"]
- || [istarget "xscale*-*-elf"]
- || [istarget "cris-*-elf"] } {
- set torture_execute_xfail [istarget]
-}
-
-return 0
+++ /dev/null
- PROGRAM LABUG1
-
-* This program core dumps on mips-sgi-irix6.2 when compiled
-* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots
-* with -O2
-*
-* Originally derived from LAPACK test suite.
-* Almost any change allows it to run.
-*
-* David Billinghurst, (David.Billinghurst@riotinto.com.au)
-* 25 November 1998
-*
-* .. Parameters ..
- INTEGER LDA, LDE
- PARAMETER ( LDA = 2500, LDE = 50 )
- COMPLEX CZERO
- PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
-
- INTEGER I, J, M, N
- REAL V
- COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE)
- COMPLEX Z
-
- N=2
- M=1
-*
- do i = 1, m
- do j = 1, n
- e(i,j) = czero
- f(i,j) = czero
- end do
- end do
-*
- DO J = 1, N
- DO I = 1, M
- V = ABS( E(I,J) - F(I,J) )
- END DO
- END DO
-
- CALL SUB2(M,Z)
-
- END
-
- subroutine SUB2(I,A)
- integer i
- complex a
- end
-
-
-
-
-
-
-
-
-
-
+++ /dev/null
- parameter (nmax=165000)
- double precision x(nmax)
- end
+++ /dev/null
- program fool
-
- real foo
- integer n
- logical t
-
- foo = 2.5
- n = 5
-
- t = (n > foo)
- if (t .neqv. .true.) call abort
- t = (n >= foo)
- if (t .neqv. .true.) call abort
- t = (n < foo)
- if (t .neqv. .false.) call abort
- t = (n <= 5)
- if (t .neqv. .true.) call abort
- t = (n >= 5 )
- if (t .neqv. .true.) call abort
- t = (n == 5)
- if (t .neqv. .true.) call abort
- t = (n /= 5)
- if (t .neqv. .false.) call abort
- t = (n /= foo)
- if (t .neqv. .true.) call abort
- t = (n == foo)
- if (t .neqv. .false.) call abort
-
- end
+++ /dev/null
-C integer byte case with integer byte parameters as case(s)
- subroutine ib
- integer *1 a /1/
- integer *1 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal ib'
- end
-C integer halfword case with integer halfword parameters
- subroutine ih
- integer *2 a /1/
- integer *2 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal ih'
- end
-C integer case with integer parameters
- subroutine iw
- integer *4 a /1/
- integer *4 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal iw'
- end
-C integer double case with integer double parameters
- subroutine id
- integer *8 a /1/
- integer *8 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal id'
- end
-C integer byte select with integer case
- subroutine ib_mixed
- integer*1 s /1/
- select case (s)
- case (1)
- case (2)
- call abort
- end select
- print*,'ib ok'
- end
-C integer halfword with integer case
- subroutine ih_mixed
- integer*2 s /1/
- select case (s)
- case (1)
- case default
- call abort
- end select
- print*,'ih ok'
- end
-C integer word with integer case
- subroutine iw_mixed
- integer s /5/
- select case (s)
- case (1)
- call abort
- case (2)
- call abort
- case (3)
- call abort
- case (4)
- call abort
- case (5)
-C
- case (6)
- call abort
- case default
- call abort
- end select
- print*,'iw ok'
- end
-C integer doubleword with integer case
- subroutine id_mixed
- integer *8 s /1024/
- select case (s)
- case (1)
- call abort
- case (1023)
- call abort
- case (1025)
- call abort
- case (1024)
-C
- end select
- print*,'i8 ok'
- end
- subroutine l1_mixed
- logical*1 s /.TRUE./
- select case (s)
- case (.TRUE.)
- case (.FALSE.)
- call abort
- end select
- print*,'l1 ok'
- end
- subroutine l2_mixed
- logical*2 s /.FALSE./
- select case (s)
- case (.TRUE.)
- call abort
- case (.FALSE.)
- end select
- print*,'lh ok'
- end
- subroutine l4_mixed
- logical*4 s /.TRUE./
- select case (s)
- case (.FALSE.)
- call abort
- case (.TRUE.)
- end select
- print*,'lw ok'
- end
- subroutine l8_mixed
- logical*8 s /.TRUE./
- select case (s)
- case (.TRUE.)
- case (.FALSE.)
- call abort
- end select
- print*,'ld ok'
- end
-C main
-C -- regression cases
- call ib
- call ih
- call iw
- call id
-C -- new functionality
- call ib_mixed
- call ih_mixed
- call iw_mixed
- call id_mixed
- end
-
-
-
-
-
+++ /dev/null
- program short
-
- parameter ( N=2 )
- common /chb/ pi,sig(0:N)
- common /parm/ h(2,2)
-
-c initialize some variables
- h(2,2) = 1117
- h(2,1) = 1178
- h(1,2) = 1568
- h(1,1) = 1621
- sig(0) = -1.
- sig(1) = 0.
- sig(2) = 1.
-
- call printout
- stop
- end
-
-c ******************************************************************
-
- subroutine printout
- parameter ( N=2 )
- common /chb/ pi,sig(0:N)
- common /parm/ h(2,2)
- dimension yzin1(0:N), yzin2(0:N)
-
-c function subprograms
- z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.)
-
-c a four-way average of rhobar
- do 260 k=0,N
- yzin1(k) = 0.25 *
- & ( z(2,2,k) + z(1,2,k) +
- & z(2,1,k) + z(1,1,k) )
- 260 continue
-
-c another four-way average of rhobar
- do 270 k=0,N
- rtmp1 = z(2,2,k)
- rtmp2 = z(1,2,k)
- rtmp3 = z(2,1,k)
- rtmp4 = z(1,1,k)
- yzin2(k) = 0.25 *
- & ( rtmp1 + rtmp2 + rtmp3 + rtmp4 )
- 270 continue
-
- do k=0,N
- if (yzin1(k) .ne. yzin2(k)) call abort
- enddo
- if (yzin1(0) .ne. -1371.) call abort
- if (yzin1(1) .ne. -685.5) call abort
- if (yzin1(2) .ne. 0.) call abort
-
- return
- end
-
+++ /dev/null
-*** Some random stuff for testing libU77. Should be done better. It's
-* hard to test things where you can't guarantee the result. Have a
-* good squint at what it prints, though detected errors will cause
-* starred messages.
-*
-* Currently not tested:
-* ALARM
-* CHDIR (func)
-* CHMOD (func)
-* FGET (func/subr)
-* FGETC (func)
-* FPUT (func/subr)
-* FPUTC (func)
-* FSTAT (subr)
-* GETCWD (subr)
-* HOSTNM (subr)
-* IRAND
-* KILL
-* LINK (func)
-* LSTAT (subr)
-* RENAME (func/subr)
-* SIGNAL (subr)
-* SRAND
-* STAT (subr)
-* SYMLNK (func/subr)
-* UMASK (func)
-* UNLINK (func)
-*
-* NOTE! This is the testsuite version, so it should compile and
-* execute on all targets, and either run to completion (with
-* success status) or fail (by calling abort). The *other* version,
-* which is a bit more interactive and tests a couple of things
-* this one cannot, should be generally the same, and is in
-* libf2c/libU77/u77-test.f. Please keep it up-to-date.
-
- implicit none
-
- external hostnm
-* intrinsic hostnm
- integer hostnm
-
- integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
- + pid, mask
- real tarray1(2), tarray2(2), r1, r2
- double precision d1
- integer(kind=2) bigi
- logical issum
- intrinsic getpid, getuid, getgid, ierrno, gerror, time8,
- + fnum, isatty, getarg, access, unlink, fstat, iargc,
- + stat, lstat, getcwd, gmtime, etime, chmod, itime, date,
- + chdir, fgetc, fputc, system_clock, second, idate, secnds,
- + time, ctime, fdate, ttynam, date_and_time, mclock, mclock8,
- + cpu_time, dtime, ftell, abort
- external lenstr, ctrlc
- integer lenstr
- logical l
- character gerr*80, c*1
- character ctim*25, line*80, lognam*20, wd*1000, line2*80,
- + ddate*8, ttime*10, zone*5, ctim2*25
- integer fstatb (13), statb (13)
- integer *2 i2zero
- integer values(8)
- integer(kind=7) sigret
-
- i = time ()
- ctim = ctime (i)
- WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim))
- write (6,'(A,I3,'', '',I3)')
- + ' Logical units 5 and 6 correspond (FNUM) to'
- + // ' Unix i/o units ', fnum(5), fnum(6)
- if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then
- print *, 'LNBLNK or LEN_TRIM failed'
- call abort
- end if
-
- bigi = time8 ()
-
- call ctime (i, ctim2)
- if (ctim .ne. ctim2) then
- write (6, *) '*** CALL CTIME disagrees with CTIME(): ',
- + ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim))
- call doabort
- end if
-
- j = time ()
- if (i .gt. bigi .or. bigi .gt. j) then
- write (6, *) '*** TIME/TIME8/TIME sequence failures: ',
- + i, bigi, j
- call doabort
- end if
-
- print *, 'Command-line arguments: ', iargc ()
- do i = 0, iargc ()
- call getarg (i, line)
- print *, 'Arg ', i, ' is: ', line(:lenstr (line))
- end do
-
- l= isatty(6)
- line2 = ttynam(6)
- if (l) then
- line = 'and 6 is a tty device (ISATTY) named '//line2
- else
- line = 'and 6 isn''t a tty device (ISATTY)'
- end if
- write (6,'(1X,A)') line(:lenstr(line))
- call ttynam (6, line)
- if (line .ne. line2) then
- print *, '*** CALL TTYNAM disagrees with TTYNAM: ',
- + line(:lenstr (line))
- call doabort
- end if
-
-* regression test for compiler crash fixed by JCB 1998-08-04 com.c
- sigret = signal(2, ctrlc)
-
- pid = getpid()
- WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid
- WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID ()
- WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID ()
- WRITE (6, *) 'If you have the `id'' program, the following call'
- write (6, *) 'of SYSTEM should agree with the above:'
- call flush(6)
- CALL SYSTEM ('echo " " `id`')
- call flush
-
- lognam = 'blahblahblah'
- call getlog (lognam)
- write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam))
-
- wd = 'blahblahblah'
- call getenv ('LOGNAME', wd)
- write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd))
-
- call umask(0, mask)
- write(6,*) 'UMASK returns', mask
- call umask(mask)
-
- ctim = fdate()
- write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim))
- call fdate (ctim)
- write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim))
-
- j=time()
- call ltime (j, ltarray)
- write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray
- call gmtime (j, ltarray)
- write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray
-
- call system_clock(count) ! omitting optional args
- call system_clock(count, rate, count_max)
- write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max
-
- call date_and_time(ddate) ! omitting optional args
- call date_and_time(ddate, ttime, zone, values)
- write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ',
- + zone, ' ', values
-
- write (6,*) 'Sleeping for 1 second (SLEEP) ...'
- call sleep (1)
-
-c consistency-check etime vs. dtime for first call
- r1 = etime (tarray1)
- r2 = dtime (tarray2)
- if (abs (r1-r2).gt.1.0) then
- write (6,*)
- + 'Results of ETIME and DTIME differ by more than a second:',
- + r1, r2
- call doabort
- end if
- if (.not. issum (r1, tarray1(1), tarray1(2))) then
- write (6,*) '*** ETIME didn''t return sum of the array: ',
- + r1, ' /= ', tarray1(1), '+', tarray1(2)
- call doabort
- end if
- if (.not. issum (r2, tarray2(1), tarray2(2))) then
- write (6,*) '*** DTIME didn''t return sum of the array: ',
- + r2, ' /= ', tarray2(1), '+', tarray2(2)
- call doabort
- end if
- write (6, '(A,3F10.3)')
- + ' Elapsed total, user, system time (ETIME): ',
- + r1, tarray1
-
-c now try to get times to change enough to see in etime/dtime
- write (6,*) 'Looping until clock ticks at least once...'
- do i = 1,1000
- do j = 1,1000
- end do
- call dtime (tarray2, r2)
- if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
- end do
- call etime (tarray1, r1)
- if (.not. issum (r1, tarray1(1), tarray1(2))) then
- write (6,*) '*** ETIME didn''t return sum of the array: ',
- + r1, ' /= ', tarray1(1), '+', tarray1(2)
- call doabort
- end if
- if (.not. issum (r2, tarray2(1), tarray2(2))) then
- write (6,*) '*** DTIME didn''t return sum of the array: ',
- + r2, ' /= ', tarray2(1), '+', tarray2(2)
- call doabort
- end if
- write (6, '(A,3F10.3)')
- + ' Differences in total, user, system time (DTIME): ',
- + r2, tarray2
- write (6, '(A,3F10.3)')
- + ' Elapsed total, user, system time (ETIME): ',
- + r1, tarray1
- write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
-
- call idate (i,j,k)
- call idate (idat)
- write (6,*) 'IDATE (date,month,year): ',idat
- print *, '... and the VXT version (month,date,year): ', i,j,k
- if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then
- print *, '*** VXT and U77 versions don''t agree'
- call doabort
- end if
-
- call date (ctim)
- write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim))
-
- call itime (idat)
- write (6,*) 'ITIME (hour,minutes,seconds): ', idat
-
- call time(line(:8))
- print *, 'TIME: ', line(:8)
-
- write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0)
-
- write (6,*) 'SECOND returns: ', second()
- call dumdum(r1)
- call second(r1)
- write (6,*) 'CALL SECOND returns: ', r1
-
-* compiler crash fixed by 1998-10-01 com.c change
- if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then
- write (6,*) '*** rand(0) error'
- call doabort()
- end if
-
- i = getcwd(wd)
- if (i.ne.0) then
- call perror ('*** getcwd')
- call doabort
- else
- write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"'
- end if
- call chdir ('.',i)
- if (i.ne.0) then
- write (6,*) '***CHDIR to ".": ', i
- call doabort
- end if
-
- i=hostnm(wd)
- if(i.ne.0) then
- call perror ('*** hostnm')
- call doabort
- else
- write (6,*) 'Host name is ', wd(:lenstr(wd))
- end if
-
- i = access('/dev/null ', 'rw')
- if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i
- write (6,*) 'Creating file "foo" for testing...'
- open (3,file='foo',status='UNKNOWN')
- rewind 3
- call fputc(3, 'c',i)
- call fputc(3, 'd',j)
- if (i+j.ne.0) write(6,*) '***FPUTC: ', i
-C why is it necessary to reopen? (who wrote this?)
-C the better to test with, my dear! (-- burley)
- close(3)
- open(3,file='foo',status='old')
- call fseek(3,0,0,*10)
- go to 20
- 10 write(6,*) '***FSEEK failed'
- call doabort
- 20 call fgetc(3, c,i)
- if (i.ne.0) then
- write(6,*) '***FGETC: ', i
- call doabort
- end if
- if (c.ne.'c') then
- write(6,*) '***FGETC read the wrong thing: ', ichar(c)
- call doabort
- end if
- i= ftell(3)
- if (i.ne.1) then
- write(6,*) '***FTELL offset: ', i
- call doabort
- end if
- call ftell(3, i)
- if (i.ne.1) then
- write(6,*) '***CALL FTELL offset: ', i
- call doabort
- end if
- call chmod ('foo', 'a+w',i)
- if (i.ne.0) then
- write (6,*) '***CHMOD of "foo": ', i
- call doabort
- end if
- i = fstat (3, fstatb)
- if (i.ne.0) then
- write (6,*) '***FSTAT of "foo": ', i
- call doabort
- end if
- i = stat ('foo', statb)
- if (i.ne.0) then
- write (6,*) '***STAT of "foo": ', i
- call doabort
- end if
- write (6,*) ' with stat array ', statb
- if (statb(6) .ne. getgid ()) then
- write (6,*) 'Note: FSTAT gid wrong (happens on some systems).'
- end if
- if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then
- write (6,*) '*** FSTAT uid or nlink is wrong'
- call doabort
- end if
- do i=1,13
- if (fstatb (i) .ne. statb (i)) then
- write (6,*) '*** FSTAT and STAT don''t agree on '// '
- + array element ', i, ' value ', fstatb (i), statb (i)
- call abort
- end if
- end do
- i = lstat ('foo', fstatb)
- do i=1,13
- if (fstatb (i) .ne. statb (i)) then
- write (6,*) '*** LSTAT and STAT don''t agree on '//
- + 'array element ', i, ' value ', fstatb (i), statb (i)
- call abort
- end if
- end do
-
-C in case it exists already:
- call unlink ('bar',i)
- call link ('foo ', 'bar ',i)
- if (i.ne.0) then
- write (6,*) '***LINK "foo" to "bar" failed: ', i
- call doabort
- end if
- call unlink ('foo',i)
- if (i.ne.0) then
- write (6,*) '***UNLINK "foo" failed: ', i
- call doabort
- end if
- call unlink ('foo',i)
- if (i.eq.0) then
- write (6,*) '***UNLINK "foo" again: ', i
- call doabort
- end if
-
- call gerror (gerr)
- i = ierrno()
- write (6,'(A,I3,A/1X,A)') ' The current error number is: ',
- + i,
- + ' and the corresponding message is:', gerr(:lenstr(gerr))
- write (6,*) 'This is sent to stderr prefixed by the program name'
- call getarg (0, line)
- call perror (line (:lenstr (line)))
- call unlink ('bar')
-
- print *, 'MCLOCK returns ', mclock ()
- print *, 'MCLOCK8 returns ', mclock8 ()
-
- call cpu_time (d1)
- print *, 'CPU_TIME returns ', d1
-
-C WRITE (6,*) 'You should see exit status 1'
- CALL EXIT(0)
- 99 END
-
-* Return length of STR not including trailing blanks, but always > 0.
- integer function lenstr (str)
- character*(*) str
- if (str.eq.' ') then
- lenstr=1
- else
- lenstr = lnblnk (str)
- end if
- end
-
-* Just make sure SECOND() doesn't "magically" work the second time.
- subroutine dumdum(r)
- r = 3.14159
- end
-
-* Test whether sum is approximately left+right.
- logical function issum (sum, left, right)
- implicit none
- real sum, left, right
- real mysum, delta, width
- mysum = left + right
- delta = abs (mysum - sum)
- width = abs (left) + abs (right)
- issum = (delta .le. .0001 * width)
- end
-
-* Signal handler
- subroutine ctrlc
- print *, 'Got ^C'
- call doabort
- end
-
-* A problem has been noticed, so maybe abort the test.
- subroutine doabort
-* For this version, call the ABORT intrinsic.
- intrinsic abort
- call abort
- end
-
-* Testsuite version only.
-* Don't actually reference the HOSTNM intrinsic, because some targets
-* need -lsocket, which we don't have a mechanism for supplying.
- integer function hostnm(nm)
- character*(*) nm
- nm = 'not determined by this version of u77-test.f'
- hostnm = 0
- end
+++ /dev/null
-# Various intrinsics not implemented and not implementable; will fail at
-# link time.
-
-if { [istarget "mmix-knuth-mmixware"]
- || [istarget "arm*-*-elf"]
- || [istarget "strongarm*-*-elf"]
- || [istarget "xscale*-*-elf"]
- || [istarget "cris-*-elf"] } {
- set torture_compile_xfail [istarget]
-}
-
-return 0
+++ /dev/null
-* Resent-From: Craig Burley <burley@gnu.org>
-* Resent-To: craig@jcb-sc.com
-* X-Delivered: at request of burley on mescaline.gnu.org
-* Date: Wed, 16 Dec 1998 18:31:24 +0100
-* From: Dieter Stueken <stueken@conterra.de>
-* Organization: con terra GmbH
-* To: fortran@gnu.org
-* Subject: possible bug
-* Content-Type: text/plain; charset=iso-8859-1
-* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085
-* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2
-*
-* Hi,
-*
-* I'm about to compile a very old, very ugly Fortran program.
-* For one part I got:
-*
-* f77: Internal compiler error: program f771 got fatal signal 6
-*
-* instead of any detailed error message. I was able to break down the
-* problem to the following source fragment:
-*
-* -------------------------------------------
- PROGRAM WAP
-
- integer*2 ios
- character*80 name
-
- name = 'blah'
- open(unit=8,status='unknown',file=name,form='formatted',
- F iostat=ios)
-
- END
-* -------------------------------------------
-*
-* The problem seems to be caused by the "integer*2 ios" declaration.
-* So far I solved it by simply using a plain integer instead.
-*
-* I'm running gcc on a Linux system compiled/installed
-* with no special options:
-*
-* -> g77 -v
-* g77 version 0.5.23
-* Driving: g77 -v -c -xf77-version /dev/null -xnone
-* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs
-* gcc version 2.8.1
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef
-* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__
-* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional
-* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__
-* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null
-* /dev/null
-* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF)
-* #include "..." search starts here:
-* #include <...> search starts here:
-* /usr/local/include
-* /usr/i686-pc-linux-gnulibc1/include
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include
-* /usr/include
-* End of search list.
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version
-* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s
-* /dev/null
-* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version
-* 2.8.1.
-* GNU Fortran Front End version 0.5.23
-* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s
-* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1
-* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911
-* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o
-* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc
-* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o
-* /usr/lib/crtn.o
-* /tmp/cca24911
-* __G77_LIBF77_VERSION__: 0.5.23
-* @(#)LIBF77 VERSION 19970919
-* __G77_LIBI77_VERSION__: 0.5.23
-* @(#) LIBI77 VERSION pjw,dmg-mods 19980405
-* __G77_LIBU77_VERSION__: 0.5.23
-* @(#) LIBU77 VERSION 19970919
-*
-*
-* Regards, Dieter.
-* --
-* Dieter Stüken, con terra GmbH, Münster
-* stueken@conterra.de stueken@qgp.uni-muenster.de
-* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken
-* (0)251-980-2027 (0)251-83-334974
+++ /dev/null
- double precision function fun(a,b)
- double precision a,b
- print*,'in sub: a,b=',a,b
- fun=a*b
- print*,'in sub: fun=',fun
- return
- end
- program test
- double precision a,b,c
- data a,b/1.0d-46,1.0d0/
- c=fun(a,b)
- print*,'in main: fun=',c
- end
+++ /dev/null
-* Culled from 970528-1.f in Burley's g77 test suite. Copyright
-* status not clear. Feel free to chop down if the bug is still
-* reproducible (see end of test case for how bug shows up in gdb
-* run of f771). No particular reason it should be a noncompile
-* case, other than that I didn't want to spend time "fixing" it
-* to compile cleanly (with -O0, which works) while making sure the
-* ICE remained reproducible. -- burley 1999-08-26
-
-* Date: Mon, 26 May 1997 13:00:19 +0200 (GMT+0200)
-* From: "D. O'Donoghue" <dod@da.saao.ac.za>
-* To: Craig Burley <burley@gnu.ai.mit.edu>
-* Cc: fortran@gnu.ai.mit.edu
-* Subject: Re: g77 problems
-
- program dophot
- parameter (napple = 4)
- common /window/nwindo,ixwin(50),iywin(50),iboxwin(50),itype(50)
- common/io/luout,ludebg
- common/search/nstot,thresh
- common /fitparms / acc(npmax),alim(npmax),mit,mpar,mfit1,
- + mfit2,ind(npmax)
- common /starlist/ starpar(npmax,nsmax), imtype(nsmax),
- 1shadow(npmax,nsmax),shaderr(npmax,nsmax),idstr(nsmax)
- common /aperlist/ apple(napple ,nsmax)
- common /parpred / ava(npmax)
- common /unitize / ufactor
- common /undergnd/ nfast, nslow
- common/bzero/ scale,zero
- common /ctimes / chiimp, apertime, filltime, addtime
- common / drfake / needit
- common /mfit/ psfpar(npmax),starx(nfmax),stary(nfmax),xlim,ylim
- common /vers/ version
- logical needit,screen,isub,loop,comd,burn,wrtres,fixedxy
- logical fixed,piped,debug,ex,clinfo
- character header*5760,rhead*2880
- character yn*1,version*40,ccd*4,infile*20
- character*30 numf,odir,record*80
- integer*2 instr(8)
- character*800 line
- external pseud0d, pseud2d, pseud4d, pseudmd, shape
-C
-C Initialization
- data burn, fixedxy,fixed, piped
- + /.false.,.false.,.false.,.false./
- data needit,screen,comd,isub
- + /.true.,.false.,.true.,.false. /
- data acc / .01, -.03, -.03, .01, .03, .1, .03 /
- data alim / -1.0e8, 2*-1.0e3, -1.0e8, 3*-1.0e3 /
-C
- version = 'DoPHOT Version 1.0 LINUX May 97 '
- debug=.false.
- clinfo=.false.
- line(1:800) = ' '
- odir = ' '
-C
-C
-C Read default tuneable parameters
- call tuneup ( nccd, ccd, piped, debug )
- version(33:36) = ccd(1:4)
-C
-
- ludebg=6
- if(piped)then
- yn='n'
- else
- write(*,'(''****************************************'')')
- write(*,1000) version
- write(*,'(''****************************************''//)')
-C
- write(*,'(''Screen output (y/[n])? '',$)')
- read(*,1000) yn
- end if
- if(yn.eq.'y'.or.yn.eq.'Y') then
- screen=.true.
- luout=6
- else
- luout=2
- end if
-C
- if(piped)then
- yn='y'
- else
- write(*,'(''Batch mode ([y]/n)? '',$)')
- read(*,1000) yn
- end if
- if(yn.eq.'n'.or.yn.eq.'N') comd = .false.
-C
- if(.not.comd) then
- write(*,
- * '(''Do you want windowing ([y]/n)? '',$)')
- read(*,1000)yn
- iwindo=1
- if(yn.eq.'n'.or.yn.eq.'N')then
- nwindo=0
- iwindo=0
- end if
-C
- write(*,
- * '(''Star classification info (y/[n]) ?'',$)')
- read(*,1000)yn
- clinfo=.false.
- if(yn.eq.'y'.or.yn.eq.'Y')clinfo=.true.
-C
- write(*,
- * '(''Create a star-subtracted frame (y/[n])? '',$)')
- read(*,1000) yn
- if(yn.eq.'y'.or.yn.eq.'Y') isub = .true.
-C
- write(*,'(''Apply after-burner (y/[n])? '',$)')
- read(*,1000) yn
- if ( yn.eq.'y'.or.yn.eq.'Y' ) burn = .true.
- wrtres = burn
-C
- write(*,'(''Read from fixed (X,Y) list (y/[n])? '',$)')
- read(*,1000) yn
- if ( yn.eq.'y'.or.yn.eq.'Y' ) then
- fixedxy = .true.
- fixed = .true.
- burn = .true.
- wrtres = .true.
- endif
- endif
- iopen=0
-C
-C This is the start of the loop over the input files
-c
- iframe=0
- open(10,file='timing',status='unknown',access='append')
-
-1 ifit = 0
- iapr = 0
- itmn = 0
- model = 1
- xc = 0.0
- yc = 0.0
- rc = 0.0
- ibr = 0
- ixy = 0
-C
- iframe=iframe+1
- tgetpar=0.0
- tsearch=0.0
- tshape=0.0
- timprove=0.0
-C
-C Batch mode ...
-
- if ( comd ) then
- if(iopen.eq.0)then
- iopen=1
- open(11,file='dophot.bat',status='old',err=995)
- end if
- read(11,1000,end=999)infile
-c now read in the parameter instructions. these are:
-c instr(1) : if 1, specifies uncrowded field, otherwise crowded
-c instr(2) : if 1, specifies sequential frames of same field
-c with a window around the stars of interest -
-c all other objects are ignored
-c instr(3) : if 0, takes cmin from dophot.inp (via tuneup)
-c if>0, sets cmin=instr(3)
-c instr(4) : if 0, does nothing
-c if 1, then opens a file called classifications
-c sets clinfo to .true. and writes out the star
-c typing info to this file
-c instr(5) : Delete the shd.nnnnnnn file
-c instr(6) : Delete the out.nnnnnnn file
-c instr(7) : Delete the input frame
-c instr(8) : Create a star-subtracted frame
- read(11,*)instr
- read(11,*)ifit,iapr,tmn,model,xc,yc,rc,ibr,ixy
- nocrwd = instr(1)
- iwindo=instr(2)
- if(iwindo.eq.0)nwindo=0
- itmn=tmn
- if ( instr(3).gt.0 ) cmin=instr(3)
- clinfo=.false.
- if ( instr(4).gt.0 )then
- clinfo=.true.
- open(12,file='classifications',status='unknown')
- ludebg=12
- end if
- if ( instr(8).ne.0 ) then
- isub = .true.
- else
- isub = .false.
- endif
-C
- if(ibr.ne.0) burn = .true.
- if(ixy.ne.0) then
- fixedxy = .true.
- fixed = .true.
- burn = .true.
- goto 20
- endif
- if(iwindo.eq.0)then
- write(6,10)iframe,infile(1:15)
- 10 format(' ***** DoPHOT-ing frame ',i4,': ',a)
- if(ludebg.eq.12)write(ludebg,11)iframe,infile(1:15)
- 11 format(////' ',62('*')/
- * ' * DoPHOT-ing frame ',i4,': ',a,
- * ' *'/' ',62('*'))
- end if
- if(iwindo.eq.1)then
- write(6,12)iframe,infile(1:15)
- 12 format(' ***** DoPHOT-ing frame ',i4,': ',a,
- * ' - Windowed *****')
- if(ludebg.eq.12)write(ludebg,13)iframe,infile(1:15)
- 13 format(////' ',62('*')/
- * ' * DoPHOT-ing frame ',i4,': ',a,
- * ' - Windowed *'/2x,62('*'))
- end if
-C
-C Interactive...
- else
- write(*,'(''Image name: '',$)')
- read(*,1000) infile
- if(infile(1:1).eq.' ') goto 999
-1000 format(a)
- write(*,'(''Crowded field mode ([y]/n) ? '',$)')
- read(*,1000)yn
- nocrwd=0
- if(yn.eq.'n'.or.yn.eq.'N')nocrwd=1
- if(.not.fixed) then
- write(*,1001)
-1001 format('Sky model ([1]=Plane, 2=Power, 3=Hubble)? ',$)
- read(*,1000)record
- if(record.ne.' ')then
- read(record,*) model
- else
- model=1
- end if
- else
- burn=.true.
- goto 20
- endif
- endif
-C
-C if windowing, open the file and read the window
- if(iwindo.eq.1)then
- inquire(file='windows',exist=ex)
- if(.not.ex)go to 997
- if(iframe.eq.1)open(9,file='windows',status='old')
- nwindo=0
- 2 read(9,*,end=3)intype,inx,iny,inbox
- nwindo=nwindo+1
- if(nwindo.gt.50)then
- print *,'too many windows - max = 50'
- stop
- end if
- ixwin(nwindo)=inx
- iywin(nwindo)=iny
- iboxwin(nwindo)=inbox
- itype(nwindo)=intype
- go to 2
-
- 3 rewind 9
- if(screen)print 4,(itype(j),ixwin(j),iywin(j),iboxwin(j),
- * j=1,nwindo)
- 4 format(' Windows: Type X Y Size'/
- * (I13,i6,i5,i5))
- end if
-
- t1 = cputime(0.0)
-C
-C Read FITS frame.
- call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line,ccd)
-C
-C Ignore frame if not the correct chip
- if(nc.lt.0) goto 900
-C
-C Estimate starting PSF parameters.
- 15 call getparams(nfast,nslow,gxwid,gywid,skyval,tmin,tmax,
- * iframe)
- tgetpar = cputime(t1) + tgetpar
- if(debug)write(ludebg,16)iframe,skyval,gxwid,gywid,tmin,tmax
- 16 format(' Getparams on frame ',i4,' sky ',f6.1,' gxwid ',f5.1,
- * ' gywid ',f5.1,' tmin ',f5.1,' tmax ',f5.1)
-C
-C Initialize
- do j=1,nsmax
- imtype(j) = 0
- do i=1,npmax
- shadow(i,j)=0.
- shaderr(i,j)=0.
- enddo
- enddo
-C
- skyguess=skyval
- tfac = 1.0
-C Use 4.5 X SD as fitting width
- fitr=fitfac*(gxwid*asprat*gywid)**0.25 + 0.5
- i=fitr
- irect(1)=i
- irect(2)=fitr/asprat
-C Use 4/3 X FitFac X SD as aperture width
- gmax = asprat*gywid
- if(gxwid.gt.gmax) gmax=gxwid
- aprw = 1.33*fitfac*sqrt(gmax) + 0.5
- i = aprw
- arect(1) = i
- i = aprw/asprat + 0.1
- arect(2) = i
-C
- if(irect(1).gt.50) irect(1)=50
- if(irect(2).gt.50) irect(2)=50
- if(arect(1).gt.45.) arect(1)=45.
- if(arect(2).gt.45.) arect(2)=45.
-C
- if (screen) call htype(line,skyval,.false.,fitr,ngr,ncon)
-C
-C Prompt for further information
- if ( .not.comd ) then
- write(*,1002)
- 1002 format(/'The above are the inital parameters DoPHOT'/
- * 'has found. You can change them now or accept'/
- * 'the values in [ ] by pressing enter'/)
-
- write(*,1004)tmin
- 1004 format('Enter Tmin: threshold for star detection',
- * ' [',f5.1,'] ',$)
- read(*,1000)record
- if(record.ne.' ')read(record,*)tmin
-
- write(*,1005)cmin
- 1005 format('Enter Cmin: threshold for PSF stars',
- * ' [',f5.1,'] ',$)
- read(*,1000)record
- if(record.ne.' ')read(record,*)cmin
-
- write(*,1006)
- 1006 format('Do you want to fix the aperture mag size ?',
- * ' (y/[n]) ')
- read(*,1000)record
- if(record.eq.'y'.or.record.eq.'Y')then
- write(*,1007)
- 1007 format('Enter the size in pixels: ',$)
- read(*,*)iapr
- if(iapr.gt.0) then
- arect(1)=iapr
- i = iapr/asprat + 0.1
- arect(2)=i
- end if
- endif
-C
- write(*,1008)
- 1008 format('Satisfied with other input parameters ? ([y]/n)?',$)
- read(*,1000) yn
- if(yn.eq.'n'.or.yn.eq.'N')then
- yn='n'
- else
- yn='y'
- end if
- if(.not.(yn.eq.'y'.or.yn.eq.'Y') ) call input
- else
- if ( ifit.ne.0 ) then
- irect(1)=ifit
- irect(2)=(ifit/asprat + 0.1)
- endif
- if ( iapr.ne.0 ) then
- arect(1)=iapr
- i = iapr/asprat + 0.1
- arect(2)=i
- endif
- if ( itmn.ne.0 ) tmin = itmn
- if ( .not.(xc.eq.0.0.and.yc.eq.0.0) ) then
- xcen = xc
- ycen = yc
- endif
- endif
-C
-C--------------------------------
-C
-C
- call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
- +nfast, nslow )
-C
-C if the uncrowded field option has been chosen, jump
-C straight to the minimum threshold
-C
- if(nocrwd.eq.1)tmax=tmin
-C
-C Adjust tfac so that thresh ends precisely on Tmin.
- if(tmin/tmax .gt. 0.999) then
- thresh = tmin
- tfac = 1.
- else
- thresh = tmax
- xnum = alog10(tmax/tmin)/alog10(2.**tfac)
- if(xnum.gt.1.5) then
- xnum = float(nint(xnum))
- else if(xnum.ge.1) then
- xnum = 2.0
- else
- xnum = 1.0
- endif
- tfac = alog10(tmax/tmin)/alog10(2.)/xnum
- endif
-C
-C------------------------------------------------------------------------
-C
-C This is the BIG LOOP which searches the frame for stars
-C with intensities > thresh.
-C
-C-----------------------------------------------------------------------
-C
- loop = .true.
- nstot = 0
- do while ( loop )
- loop = thresh/tmin .ge. 1.01
- write(luout,1050) thresh
-1050 format(/20('-')/'THRESHOLD: ', f10.3)
- if(ludebg.eq.12)write(ludebg,1050) thresh
-C
-C Fit given model to sky values.
-C
- call varipar(nstot, nfast, nslow )
- t1 = cputime(0.0)
-C
-C Identifies potential objects in cleaned array IMG
- nstar = isearch( pseud2d, nfast, nslow , clinfo)
- tsearch = cputime(t1) + tsearch
-C
- if ( (nstar .ne. 0).or.(xnum.lt.1.5) ) then
-C
-C Performs 7-parameter PSF fit and determines nature of object.
- t1 = cputime(0.0)
- call shape(pseud2d,pseud4d,nfast,nslow,clinfo)
- tshape = cputime(t1) + tshape
-C
-C Computes average sky values etc from star list
- call paravg
- t1 = cputime(0.0)
-C
-C Computes 4-parameter fits for all stellar objects using
-C new average shape parameters.
- call improve(pseud2d,nfast,nslow,clinfo)
- timprove = cputime(t1) + timprove
- end if
-C
-C Calculate aperture photometry on last pass.
- if(.not.loop) call aper ( pseud2d, nstot, nfast, nslow )
-C
- totaltime = (tgetpar+tsearch+tshape+timprove)
- write(3,1060) totaltime
- write(4,1060) totaltime
- write(luout,1060) totaltime
-1060 format('Total CPU time consumed:',F10.2,' seconds.')
- write(10,1070)infile,tgetpar,tsearch,tshape,timprove,
- * totaltime
-1070 format(a20,' T(getp/f)',f5.1,' T(search)',f5.1,
- * ' T(shape)',f5.1,' T(improve)',f5.1,
- * ' Total',f6.1)
- call title (line,skyval,.false.,fitr,ngr,ncon,strint,ztot,nums)
- rewind(2)
- rewind(3)
- rewind(4)
-C
- call output ( line )
-C
-C Now reduce the threshold and loop back
-C
- thresh = thresh/2.**tfac
- end do
-C
-C--------- END OF BIG LOOP ---------------------------------------
-C
-C If after-burner required, residuals from analytic PSF are computed
-C and stored in RES.
-C
-20 if ( burn ) then
-C
-C If using a fixed (X,Y) coordinate list, read it.
- if (fixed) then
-C Read the image frame
- call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line)
-C
-C Initialize arrays, open files etc.
- call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
- +nfast, nslow )
-C
-C Read the XY list
- write(luout,'(''Reading XY list ...'')')
- call xylist(numf, nc, ios )
- if(ios.ne.0) then
- fixed = .false.
- write(luout,'(''SXY file absent or incorrect...'')')
- goto 15
- endif
-C
- call htype(line,skyval,.false.,fitr,ngr,ncon)
-C
-C Remove good stars
- write(luout,'(''Cleaning frame of stars: '',i8)') nstot
- call clean ( pseud2d, nstot, nfast, nslow, -1)
-C
-C Calculate aperture photometry
-C call aper ( pseud2d, nstot, nfast, nslow )
- else
- rewind(3)
- rewind(4)
- endif
-C
-C-----------------------
-C Flag all stars close together in groups. Keep making the distance
-C criterion FITR smaller until the maximum number in a group is less
-C than NFMAX
-C
- fitr = amax1(arect(1),arect(2))
- fitr = fitr + 2.0
- nmax = 10000
- write(*,'(''Regrouping ...'')')
-C
- do while ( nmax.gt.nfmax )
- fitr = fitr - 1.0
- write(luout,'(''Min distance ='',f8.1)') fitr
- call regroup( fitr, ngr, nmax )
- enddo
-C
- xlim = irect(1)/2
- ylim = irect(2)/2
-C
-C Calculate normalized PSF residual from PSEUD2D
- call getres (pseud0d,pseud2d,strint,rmn,rmx,nfast,nslow,irect,
- +arect,ztot,nums)
- if(nums.eq.0) then
- write(luout,'(''No suitable PSF stars!'')')
- goto 30
- endif
-C
- write(luout,'(/''AFTERBURNER tuned ON!'')')
-C
-C Fit multiple stars in a group with enhanced PSF using box size IRECT.
- call mulfit( pseud2d,pseudmd,ngr,ncon,nfast,nslow,irect )
-C
-C Re-calculate aperture photometry
- call aperm ( pseudmd, nstot, nfast, nslow )
-C
- call skyadj ( nstot )
-C
- call title (line,skyval,.true.,fitr,ngr,ncon,strint,ztot,nums)
- call output ( line )
- endif
-C---------------------
-C
-C----- This section skipped if PSF residual not written out ------
-C
-30 if( isub ) then
-C
-C Write final Cleaned array.
- infile = 'x'//numf(1:nc)//'.fits'
- call putfits(2,infile,header,nhead,nfast,nslow)
- close(2)
-C
-C If afterburner used, then residual array also written out.
-C Find suitable scale for writing residual PSF to FITS "R" file.
-C
- if ( wrtres ) then
- scale=20000.0/(rmx-rmn)
- zero=-scale*rmn
- do j=-nres,nres
- jj=nres+j+1
- do i=-nres,nres
- ii=nres+i+1
- big(ii,jj)=scale*res(i,j)+zero
- enddo
- enddo
- nx=2*nres+1
-C
- infile = 'r'//numf(1:nc)//'.fits'
- zer=-zero/scale
- scl=1.0/scale
-C
-C Create a FITS header for the normalized PSF residual image
- call sethead(rhead,numf,nx,nx,zer,scl)
- scale=1.0
- zero=0.0
-C Write the normalized PSF residual image
- call putfits(2,infile,rhead,1,nx,nx)
- close(2)
- endif
-C
- end if
-C
-C
-900 close(1)
- close(3)
- close(4)
- if ( .not.screen ) close(luout)
- if(comd) then
- if(instr(5).eq.1)call system('rm shd.'//numf(1:nc))
- if(instr(6).eq.1)call system('rm out.'//numf(1:nc))
- n=1
- do while(infile(n:n).ne.' ')
- n=n+1
- end do
- if(instr(7).eq.1)call system('rm '//infile(1:n-1))
- end if
- fixed = fixedxy
- goto 1
-C
-995 print 996
-996 format(/'*** Fatal error ***'/
- * 'You asked for batch processing but'/
- * 'I cant open the "dophot.bat" file.'/
- * 'Please make one (using batchdophot)'/
- * 'and restart DoPHOT'/)
- go to 999
-
-C
-997 print 998
-998 format(/'*** Fatal error ***'/
- * 'You asked for "windowed" processing'/
- * 'but I cant open the "windows" file.'/
- * 'Please make one and restart DoPHOT'/)
-
-999 call exit(0)
- end
-
-* (gdb) r
-* Starting program: /home3/craig/gnu/f77-e/gcc/f771 -quiet < ../../play/19990826-4.f -O
-* [...]
-* Breakpoint 2, fancy_abort (
-* file=0x8285220 "../../g77-e/gcc/config/i386/i386.c", line=4399,
-* function=0x82860df "output_fp_cc0_set") at ../../g77-e/gcc/rtl.c:1010
-* (gdb) up
-* #1 0x8222fab in output_fp_cc0_set (insn=0x8382324)
-* at ../../g77-e/gcc/config/i386/i386.c:4399
-* (gdb) p insn
-* $1 = 0x3a
-* (gdb) up
-* #2 0x8222b81 in output_float_compare (insn=0x8382324, operands=0x82acc60)
-* at ../../g77-e/gcc/config/i386/i386.c:4205
-* (gdb) p insn
-* $2 = 0x8382324
-* (gdb) whatis insn
-* type = rtx
-* (gdb) pr
-* (insn 2181 2180 2191 (parallel[
-* (set (cc0)
-* (compare (reg:SF 8 %st(0))
-* (mem:SF (plus:SI (reg:SI 6 %ebp)
-* (const_int -9948 [0xffffd924])) 0)))
-* (clobber (reg:HI 0 %ax))
-* ] ) 29 {*cmpsf_cc_1} (insn_list 2173 (insn_list 2173 (nil)))
-* (expr_list:REG_DEAD (reg:DF 8 %st(0))
-* (expr_list:REG_UNUSED (reg:HI 0 %ax)
-* (nil))))
-* (gdb)
+++ /dev/null
-* =foo7.f in Burley's g77 test suite.
- subroutine x
- real a(n)
- common /foo/n
- continue
- entry y(a)
- call foo(a(1))
- end
+++ /dev/null
- PARAMETER (Q=1)
- PARAMETER (P=10)
- INTEGER C(10),D(10),E(10),F(10)
- DATA (C(I),I=1,P) /10*10/ ! TERMINAL NOT INTEGER
- DATA (D(I),I=Q,10) /10*10/ ! START NOT INTEGER
- DATA (E(I),I=1,10,Q) /10*10/ ! INCREMENT NOT INTEGER
- END
+++ /dev/null
- SUBROUTINE A(A,ALPHA,IA)
- COMPLEX A(IA,*), ALPHA(*)
- ALPHA(I)=A(I,I).ZERO)
- END
+++ /dev/null
-* Fixed by JCB 1998-07-25 change to stc.c.
-
-* Date: Thu, 11 Jun 1998 22:35:20 -0500
-* From: Ian A Watson <WATSON_IAN_A@lilly.com>
-* Subject: crash
-*
- CaLL foo(W)
- END
- SUBROUTINE foo(W)
- yy(I)=A(I)Q(X)
+++ /dev/null
-* Fixed by 1998-07-11 equiv.c change.
-* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER'
-
-* Date: Mon, 15 Jun 1998 21:54:32 -0500
-* From: Ian A Watson <WATSON_IAN_A@lilly.com>
-* Subject: Mangler Crash
- EQUIVALENCE(I,glerf(P))
- COMMON /foo/ glerf(3)
+++ /dev/null
-CCC Abort fixed by:
-CCC1998-04-21 Jim Wilson <wilson@cygnus.com>
-CCC
-CCC * stmt.c (check_seenlabel): When search for line number note for
-CCC warning, handle case where there is no such note.
- logical l(10)
- integer i(10)
- goto (10,20),l
- goto (10,20),i
- 10 stop
- 20 end
+++ /dev/null
-# Copyright (C) 1988, 90, 91, 92, 97, 1998 Free Software Foundation, Inc.
-
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-# This file was written by Jeff Law. (law@cs.utah.edu)
-
-#
-# These tests come from Torbjorn Granlund (tege@cygnus.com)
-# C torture test suite.
-#
-
-load_lib mike-g77.exp
-
-# Test check0.f
-prebase
-
-set src_code check0.f
-# Not really sure what the error should be here...
-set compiler_output ".*:8.*:9"
-
-set groups {passed gcc-noncompile}
-
-postbase $src_code $run $groups
-
+++ /dev/null
- integer*1 one
- integer*2 two
- parameter (one=1)
- parameter (two=2)
- select case (I)
- case (one)
- case (two)
- end select
- end
-
+++ /dev/null
-<!DOCTYPE article PUBLIC "-//Davenport//DTD DocBook V3.0//EN">
-<article>
-<artheader>
-<title>The Cygnus Native Interface for C++/Java Integration</title>
-<subtitle>Writing native Java methods in natural C++</subtitle>
-<authorgroup>
-<corpauthor>Cygnus Solutions</corpauthor>
-</authorgroup>
-<date>March, 2000</date>
-</artheader>
-
-<abstract><para>
-This documents CNI, the Cygnus Native Interface,
-which is is a convenient way to write Java native methods using C++.
-This is a more efficient, more convenient, but less portable
-alternative to the standard JNI (Java Native Interface).</para>
-</abstract>
-
-<sect1><title>Basic Concepts</title>
-<para>
-In terms of languages features, Java is mostly a subset
-of C++. Java has a few important extensions, plus a powerful standard
-class library, but on the whole that does not change the basic similarity.
-Java is a hybrid object-oriented language, with a few native types,
-in addition to class types. It is class-based, where a class may have
-static as well as per-object fields, and static as well as instance methods.
-Non-static methods may be virtual, and may be overloaded. Overloading is
-resolved at compile time by matching the actual argument types against
-the parameter types. Virtual methods are implemented using indirect calls
-through a dispatch table (virtual function table). Objects are
-allocated on the heap, and initialized using a constructor method.
-Classes are organized in a package hierarchy.
-</para>
-<para>
-All of the listed attributes are also true of C++, though C++ has
-extra features (for example in C++ objects may be allocated not just
-on the heap, but also statically or in a local stack frame). Because
-<acronym>gcj</acronym> uses the same compiler technology as
-<acronym>g++</acronym> (the GNU C++ compiler), it is possible
-to make the intersection of the two languages use the same
-<acronym>ABI</acronym> (object representation and calling conventions).
-The key idea in <acronym>CNI</acronym> is that Java objects are C++ objects,
-and all Java classes are C++ classes (but not the other way around).
-So the most important task in integrating Java and C++ is to
-remove gratuitous incompatibilities.
-</para>
-<para>
-You write CNI code as a regular C++ source file. (You do have to use
-a Java/CNI-aware C++ compiler, specifically a recent version of G++.)</para>
-<para>
-You start with:
-<programlisting>
-#include <gcj/cni.h>
-</programlisting></para>
-
-<para>
-You then include header files for the various Java classes you need
-to use:
-<programlisting>
-#include <java/lang/Character.h>
-#include <java/util/Date.h>
-#include <java/lang/IndexOutOfBoundsException.h>
-</programlisting></para>
-
-<para>
-In general, <acronym>CNI</acronym> functions and macros start with the
-`<literal>Jv</literal>' prefix, for example the function
-`<literal>JvNewObjectArray</literal>'. This convention is used to
-avoid conflicts with other libraries.
-Internal functions in <acronym>CNI</acronym> start with the prefix
-`<literal>_Jv_</literal>'. You should not call these;
-if you find a need to, let us know and we will try to come up with an
-alternate solution. (This manual lists <literal>_Jv_AllocBytes</literal>
-as an example; <acronym>CNI</acronym> should instead provide
-a <literal>JvAllocBytes</literal> function.)</para>
-<para>
-These header files are automatically generated by <command>gcjh</command>.
-</para>
-</sect1>
-
-<sect1><title>Packages</title>
-<para>
-The only global names in Java are class names, and packages.
-A <firstterm>package</firstterm> can contain zero or more classes, and
-also zero or more sub-packages.
-Every class belongs to either an unnamed package or a package that
-has a hierarchical and globally unique name.
-</para>
-<para>
-A Java package is mapped to a C++ <firstterm>namespace</firstterm>.
-The Java class <literal>java.lang.String</literal>
-is in the package <literal>java.lang</literal>, which is a sub-package
-of <literal>java</literal>. The C++ equivalent is the
-class <literal>java::lang::String</literal>,
-which is in the namespace <literal>java::lang</literal>,
-which is in the namespace <literal>java</literal>.
-</para>
-<para>
-Here is how you could express this:
-<programlisting>
-// Declare the class(es), possibly in a header file:
-namespace java {
- namespace lang {
- class Object;
- class String;
- ...
- }
-}
-
-class java::lang::String : public java::lang::Object
-{
- ...
-};
-</programlisting>
-</para>
-<para>
-The <literal>gcjh</literal> tool automatically generates the
-nessary namespace declarations.</para>
-
-<sect2><title>Nested classes as a substitute for namespaces</title>
-<para>
-<!-- FIXME the next line reads poorly jsm -->
-It is not that long since g++ got complete namespace support,
-and it was very recent (end of February 1999) that <literal>libgcj</literal>
-was changed to uses namespaces. Releases before then used
-nested classes, which are the C++ equivalent of Java inner classes.
-They provide similar (though less convenient) functionality.
-The old syntax is:
-<programlisting>
-class java {
- class lang {
- class Object;
- class String;
- };
-};
-</programlisting>
-The obvious difference is the use of <literal>class</literal> instead
-of <literal>namespace</literal>. The more important difference is
-that all the members of a nested class have to be declared inside
-the parent class definition, while namespaces can be defined in
-multiple places in the source. This is more convenient, since it
-corresponds more closely to how Java packages are defined.
-The main difference is in the declarations; the syntax for
-using a nested class is the same as with namespaces:
-<programlisting>
-class java::lang::String : public java::lang::Object
-{ ... }
-</programlisting>
-Note that the generated code (including name mangling)
-using nested classes is the same as that using namespaces.</para>
-</sect2>
-
-<sect2><title>Leaving out package names</title>
-<para>
-<!-- FIXME next line reads poorly jsm -->
-Having to always type the fully-qualified class name is verbose.
-It also makes it more difficult to change the package containing a class.
-The Java <literal>package</literal> declaration specifies that the
-following class declarations are in the named package, without having
-to explicitly name the full package qualifiers.
-The <literal>package</literal> declaration can be followed by zero or
-more <literal>import</literal> declarations, which allows either
-a single class or all the classes in a package to be named by a simple
-identifier. C++ provides something similar
-with the <literal>using</literal> declaration and directive.
-</para>
-<para>
-A Java simple-type-import declaration:
-<programlisting>
-import <replaceable>PackageName</replaceable>.<replaceable>TypeName</replaceable>;
-</programlisting>
-allows using <replaceable>TypeName</replaceable> as a shorthand for
-<literal><replaceable>PackageName</replaceable>.<replaceable>TypeName</replaceable></literal>.
-The C++ (more-or-less) equivalent is a <literal>using</literal>-declaration:
-<programlisting>
-using <replaceable>PackageName</replaceable>::<replaceable>TypeName</replaceable>;
-</programlisting>
-</para>
-<para>
-A Java import-on-demand declaration:
-<programlisting>
-import <replaceable>PackageName</replaceable>.*;
-</programlisting>
-allows using <replaceable>TypeName</replaceable> as a shorthand for
-<literal><replaceable>PackageName</replaceable>.<replaceable>TypeName</replaceable></literal>
-The C++ (more-or-less) equivalent is a <literal>using</literal>-directive:
-<programlisting>
-using namespace <replaceable>PackageName</replaceable>;
-</programlisting>
-</para>
-</sect2>
-</sect1>
-
-<sect1><title>Primitive types</title>
-<para>
-Java provides 8 <quote>primitives</quote> types:
-<literal>byte</literal>, <literal>short</literal>, <literal>int</literal>,
-<literal>long</literal>, <literal>float</literal>, <literal>double</literal>,
-<literal>char</literal>, and <literal>boolean</literal>.
-These are the same as the following C++ <literal>typedef</literal>s
-(which are defined by <literal>gcj/cni.h</literal>):
-<literal>jbyte</literal>, <literal>jshort</literal>, <literal>jint</literal>,
-<literal>jlong</literal>, <literal>jfloat</literal>,
-<literal>jdouble</literal>,
-<literal>jchar</literal>, and <literal>jboolean</literal>.
-You should use the C++ typenames
-(<ForeignPhrase><Abbrev>e.g.</Abbrev></ForeignPhrase> <literal>jint</literal>),
-and not the Java types names
-(<ForeignPhrase><Abbrev>e.g.</Abbrev></ForeignPhrase> <literal>int</literal>),
-even if they are <quote>the same</quote>.
-This is because there is no guarantee that the C++ type
-<literal>int</literal> is a 32-bit type, but <literal>jint</literal>
-<emphasis>is</emphasis> guaranteed to be a 32-bit type.
-
-<informaltable frame="all" colsep="1" rowsep="0">
-<tgroup cols="3">
-<thead>
-<row>
-<entry>Java type</entry>
-<entry>C/C++ typename</entry>
-<entry>Description</entry>
-</thead>
-<tbody>
-<row>
-<entry>byte</entry>
-<entry>jbyte</entry>
-<entry>8-bit signed integer</entry>
-</row>
-<row>
-<entry>short</entry>
-<entry>jshort</entry>
-<entry>16-bit signed integer</entry>
-</row>
-<row>
-<entry>int</entry>
-<entry>jint</entry>
-<entry>32-bit signed integer</entry>
-</row>
-<row>
-<entry>long</entry>
-<entry>jlong</entry>
-<entry>64-bit signed integer</entry>
-</row>
-<row>
-<entry>float</entry>
-<entry>jfloat</entry>
-<entry>32-bit IEEE floating-point number</entry>
-</row>
-<row>
-<entry>double</entry>
-<entry>jdouble</entry>
-<entry>64-bit IEEE floating-point number</entry>
-</row>
-<row>
-<entry>char</entry>
-<entry>jchar</entry>
-<entry>16-bit Unicode character</entry>
-</row>
-<row>
-<entry>boolean</entry>
-<entry>jboolean</entry>
-<entry>logical (Boolean) values</entry>
-</row>
-<row>
-<entry>void</entry>
-<entry>void</entry>
-<entry>no value</entry>
-</row>
-</tbody></tgroup>
-</informaltable>
-</para>
-
-<para>
-<funcsynopsis>
-<funcdef><function>JvPrimClass</function></funcdef>
-<paramdef><parameter>primtype</parameter></paramdef>
-</funcsynopsis>
-This is a macro whose argument should be the name of a primitive
-type, <ForeignPhrase><Abbrev>e.g.</Abbrev></ForeignPhrase>
-<literal>byte</literal>.
-The macro expands to a pointer to the <literal>Class</literal> object
-corresponding to the primitive type.
-<ForeignPhrase><Abbrev>E.g.</Abbrev></ForeignPhrase>,
-<literal>JvPrimClass(void)</literal>
-has the same value as the Java expression
-<literal>Void.TYPE</literal> (or <literal>void.class</literal>).
-</para>
-
-</sect1>
-
-<sect1><title>Objects and Classes</title>
-<sect2><title>Classes</title>
-<para>
-All Java classes are derived from <literal>java.lang.Object</literal>.
-C++ does not have a unique <quote>root</quote>class, but we use
-a C++ <literal>java::lang::Object</literal> as the C++ version
-of the <literal>java.lang.Object</literal> Java class. All
-other Java classes are mapped into corresponding C++ classes
-derived from <literal>java::lang::Object</literal>.</para>
-<para>
-Interface inheritance (the <quote><literal>implements</literal></quote>
-keyword) is currently not reflected in the C++ mapping.</para>
-</sect2>
-<sect2><title>Object references</title>
-<para>
-We implement a Java object reference as a pointer to the start
-of the referenced object. It maps to a C++ pointer.
-(We cannot use C++ references for Java references, since
-once a C++ reference has been initialized, you cannot change it to
-point to another object.)
-The <literal>null</literal> Java reference maps to the <literal>NULL</literal>
-C++ pointer.
-</para>
-<para>
-Note that in some Java implementations an object reference is implemented as
-a pointer to a two-word <quote>handle</quote>. One word of the handle
-points to the fields of the object, while the other points
-to a method table. Gcj does not use this extra indirection.
-</para>
-</sect2>
-<sect2><title>Object fields</title>
-<para>
-Each object contains an object header, followed by the instance
-fields of the class, in order. The object header consists of
-a single pointer to a dispatch or virtual function table.
-(There may be extra fields <quote>in front of</quote> the object,
-for example for
-memory management, but this is invisible to the application, and
-the reference to the object points to the dispatch table pointer.)
-</para>
-<para>
-The fields are laid out in the same order, alignment, and size
-as in C++. Specifically, 8-bite and 16-bit native types
-(<literal>byte</literal>, <literal>short</literal>, <literal>char</literal>,
-and <literal>boolean</literal>) are <emphasis>not</emphasis>
-widened to 32 bits.
-Note that the Java VM does extend 8-bit and 16-bit types to 32 bits
-when on the VM stack or temporary registers.</para>
-<para>
-If you include the <literal>gcjh</literal>-generated header for a
-class, you can access fields of Java classes in the <quote>natural</quote>
-way. Given the following Java class:
-<programlisting>
-public class Int
-{
- public int i;
- public Integer (int i) { this.i = i; }
- public static zero = new Integer(0);
-}
-</programlisting>
-you can write:
-<programlisting>
-#include <gcj/cni.h>
-#include <Int.h>
-Int*
-mult (Int *p, jint k)
-{
- if (k == 0)
- return Int::zero; // static member access.
- return new Int(p->i * k);
-}
-</programlisting>
-</para>
-<para>
-<acronym>CNI</acronym> does not strictly enforce the Java access
-specifiers, because Java permissions cannot be directly mapped
-into C++ permission. Private Java fields and methods are mapped
-to private C++ fields and methods, but other fields and methods
-are mapped to public fields and methods.
-</para>
-</sect2>
-</sect1>
-
-<sect1><title>Arrays</title>
-<para>
-While in many ways Java is similar to C and C++,
-it is quite different in its treatment of arrays.
-C arrays are based on the idea of pointer arithmetic,
-which would be incompatible with Java's security requirements.
-Java arrays are true objects (array types inherit from
-<literal>java.lang.Object</literal>). An array-valued variable
-is one that contains a reference (pointer) to an array object.
-</para>
-<para>
-Referencing a Java array in C++ code is done using the
-<literal>JArray</literal> template, which as defined as follows:
-<programlisting>
-class __JArray : public java::lang::Object
-{
-public:
- int length;
-};
-
-template<class T>
-class JArray : public __JArray
-{
- T data[0];
-public:
- T& operator[](jint i) { return data[i]; }
-};
-</programlisting></para>
-<para>
-<funcsynopsis>
- <funcdef>template<class T> T *<function>elements</function></funcdef>
- <paramdef>JArray<T> &<parameter>array</parameter></paramdef>
-</funcsynopsis>
- This template function can be used to get a pointer to the
- elements of the <parameter>array</parameter>.
- For instance, you can fetch a pointer
- to the integers that make up an <literal>int[]</literal> like so:
-<programlisting>
-extern jintArray foo;
-jint *intp = elements (foo);
-</programlisting>
-The name of this function may change in the future.</para>
-<para>
-There are a number of typedefs which correspond to typedefs from JNI.
-Each is the type of an array holding objects of the appropriate type:
-<programlisting>
-typedef __JArray *jarray;
-typedef JArray<jobject> *jobjectArray;
-typedef JArray<jboolean> *jbooleanArray;
-typedef JArray<jbyte> *jbyteArray;
-typedef JArray<jchar> *jcharArray;
-typedef JArray<jshort> *jshortArray;
-typedef JArray<jint> *jintArray;
-typedef JArray<jlong> *jlongArray;
-typedef JArray<jfloat> *jfloatArray;
-typedef JArray<jdouble> *jdoubleArray;
-</programlisting>
-</para>
-<para>
- You can create an array of objects using this function:
-<funcsynopsis>
- <funcdef>jobjectArray <function>JvNewObjectArray</function></funcdef>
- <paramdef>jint <parameter>length</parameter></paramdef>
- <paramdef>jclass <parameter>klass</parameter></paramdef>
- <paramdef>jobject <parameter>init</parameter></paramdef>
- </funcsynopsis>
- Here <parameter>klass</parameter> is the type of elements of the array;
- <parameter>init</parameter> is the initial
- value to be put into every slot in the array.
-</para>
-<para>
-For each primitive type there is a function which can be used
- to create a new array holding that type. The name of the function
- is of the form
- `<literal>JvNew<<replaceable>Type</replaceable>>Array</literal>',
- where `<<replaceable>Type</replaceable>>' is the name of
- the primitive type, with its initial letter in upper-case. For
- instance, `<literal>JvNewBooleanArray</literal>' can be used to create
- a new array of booleans.
- Each such function follows this example:
-<funcsynopsis>
- <funcdef>jbooleanArray <function>JvNewBooleanArray</function></funcdef>
- <paramdef>jint <parameter>length</parameter></paramdef>
-</funcsynopsis>
-</para>
-<para>
-<funcsynopsis>
- <funcdef>jsize <function>JvGetArrayLength</function></funcdef>
- <paramdef>jarray <parameter>array</parameter></paramdef>
- </funcsynopsis>
- Returns the length of <parameter>array</parameter>.</para>
-</sect1>
-
-<sect1><title>Methods</title>
-
-<para>
-Java methods are mapped directly into C++ methods.
-The header files generated by <literal>gcjh</literal>
-include the appropriate method definitions.
-Basically, the generated methods have the same names and
-<quote>corresponding</quote> types as the Java methods,
-and are called in the natural manner.</para>
-
-<sect2><title>Overloading</title>
-<para>
-Both Java and C++ provide method overloading, where multiple
-methods in a class have the same name, and the correct one is chosen
-(at compile time) depending on the argument types.
-The rules for choosing the correct method are (as expected) more complicated
-in C++ than in Java, but given a set of overloaded methods
-generated by <literal>gcjh</literal> the C++ compiler will choose
-the expected one.</para>
-<para>
-Common assemblers and linkers are not aware of C++ overloading,
-so the standard implementation strategy is to encode the
-parameter types of a method into its assembly-level name.
-This encoding is called <firstterm>mangling</firstterm>,
-and the encoded name is the <firstterm>mangled name</firstterm>.
-The same mechanism is used to implement Java overloading.
-For C++/Java interoperability, it is important that both the Java
-and C++ compilers use the <emphasis>same</emphasis> encoding scheme.
-</para>
-</sect2>
-
-<sect2><title>Static methods</title>
-<para>
-Static Java methods are invoked in <acronym>CNI</acronym> using the standard
-C++ syntax, using the `<literal>::</literal>' operator rather
-than the `<literal>.</literal>' operator. For example:
-</para>
-<programlisting>
-jint i = java::lang::Math::round((jfloat) 2.3);
-</programlisting>
-<para>
-<!-- FIXME this next sentence seems ungammatical jsm -->
-Defining a static native method uses standard C++ method
-definition syntax. For example:
-<programlisting>
-#include <java/lang/Integer.h>
-java::lang::Integer*
-java::lang::Integer::getInteger(jstring str)
-{
- ...
-}
-</programlisting>
-</sect2>
-
-<sect2><title>Object Constructors</title>
-<para>
-Constructors are called implicitly as part of object allocation
-using the <literal>new</literal> operator. For example:
-<programlisting>
-java::lang::Int x = new java::lang::Int(234);
-</programlisting>
-</para>
-<para>
-<!-- FIXME rewrite needed here, mine may not be good jsm -->
-Java does not allow a constructor to be a native method.
-Instead, you could define a private method which
-you can have the constructor call.
-</para>
-</sect2>
-
-<sect2><title>Instance methods</title>
-<para>
-<!-- FIXME next para week, I would remove a few words from some sentences jsm -->
-Virtual method dispatch is handled essentially the same way
-in C++ and Java -- <abbrev>i.e.</abbrev> by doing an
-indirect call through a function pointer stored in a per-class virtual
-function table. C++ is more complicated because it has to support
-multiple inheritance, but this does not effect Java classes.
-However, G++ has historically used a different calling convention
-that is not compatible with the one used by <acronym>gcj</acronym>.
-During 1999, G++ will switch to a new ABI that is compatible with
-<acronym>gcj</acronym>. Some platforms (including Linux) have already
-changed. On other platforms, you will have to pass
-the <literal>-fvtable-thunks</literal> flag to g++ when
-compiling <acronym>CNI</acronym> code. Note that you must also compile
-your C++ source code with <literal>-fno-rtti</literal>.
-</para>
-<para>
-Calling a Java instance method in <acronym>CNI</acronym> is done
-using the standard C++ syntax. For example:
-<programlisting>
- java::lang::Number *x;
- if (x->doubleValue() > 0.0) ...
-</programlisting>
-</para>
-<para>
-Defining a Java native instance method is also done the natural way:
-<programlisting>
-#include <java/lang/Integer.h>
-jdouble
-java::lang:Integer::doubleValue()
-{
- return (jdouble) value;
-}
-</programlisting>
-</para>
-</sect2>
-
-<sect2><title>Interface method calls</title>
-<para>
-In Java you can call a method using an interface reference.
-This is not yet supported in <acronym>CNI</acronym>.</para>
-</sect2>
-</sect1>
-
-<sect1><title>Object allocation</title>
-
-<para>
-New Java objects are allocated using a
-<firstterm>class-instance-creation-expression</firstterm>:
-<programlisting>
-new <replaceable>Type</replaceable> ( <replaceable>arguments</replaceable> )
-</programlisting>
-The same syntax is used in C++. The main difference is that
-C++ objects have to be explicitly deleted; in Java they are
-automatically deleted by the garbage collector.
-Using <acronym>CNI</acronym>, you can allocate a new object
-using standard C++ syntax. The C++ compiler is smart enough to
-realize the class is a Java class, and hence it needs to allocate
-memory from the garbage collector. If you have overloaded
-constructors, the compiler will choose the correct one
-using standard C++ overload resolution rules. For example:
-<programlisting>
-java::util::Hashtable *ht = new java::util::Hashtable(120);
-</programlisting>
-</para>
-<para>
-<funcsynopsis>
- <funcdef>void *<function>_Jv_AllocBytes</function></funcdef>
- <paramdef>jsize <parameter>size</parameter></paramdef>
-</funcsynopsis>
- Allocate <parameter>size</parameter> bytes. This memory is not
- scanned by the garbage collector. However, it will be freed by
-the GC if no references to it are discovered.
-</para>
-</sect1>
-
-<sect1><title>Interfaces</title>
-<para>
-A Java class can <firstterm>implement</firstterm> zero or more
-<firstterm>interfaces</firstterm>, in addition to inheriting from
-a single base class.
-An interface is a collection of constants and method specifications;
-it is similar to the <firstterm>signatures</firstterm> available
-as a G++ extension. An interface provides a subset of the
-functionality of C++ abstract virtual base classes, but they
-are currently implemented differently.
-CNI does not currently provide any support for interfaces,
-or calling methods from an interface pointer.
-This is partly because we are planning to re-do how
-interfaces are implemented in <acronym>gcj</acronym>.
-</para>
-</sect1>
-
-<sect1><title>Strings</title>
-<para>
-<acronym>CNI</acronym> provides a number of utility functions for
-working with Java <literal>String</literal> objects.
-The names and interfaces are analogous to those of <acronym>JNI</acronym>.
-</para>
-
-<para>
-<funcsynopsis>
- <funcdef>jstring <function>JvNewString</function></funcdef>
- <paramdef>const jchar *<parameter>chars</parameter></paramdef>
- <paramdef>jsize <parameter>len</parameter></paramdef>
- </funcsynopsis>
- Creates a new Java String object, where
- <parameter>chars</parameter> are the contents, and
- <parameter>len</parameter> is the number of characters.
-</para>
-
-<para>
-<funcsynopsis>
- <funcdef>jstring <function>JvNewStringLatin1</function></funcdef>
- <paramdef>const char *<parameter>bytes</parameter></paramdef>
- <paramdef>jsize <parameter>len</parameter></paramdef>
- </funcsynopsis>
- Creates a new Java String object, where <parameter>bytes</parameter>
- are the Latin-1 encoded
- characters, and <parameter>len</parameter> is the length of
- <parameter>bytes</parameter>, in bytes.
-</para>
-
-<para>
-<funcsynopsis>
- <funcdef>jstring <function>JvNewStringLatin1</function></funcdef>
- <paramdef>const char *<parameter>bytes</parameter></paramdef>
- </funcsynopsis>
- Like the first JvNewStringLatin1, but computes <parameter>len</parameter>
- using <literal>strlen</literal>.
-</para>
-
-<para>
-<funcsynopsis>
- <funcdef>jstring <function>JvNewStringUTF</function></funcdef>
- <paramdef>const char *<parameter>bytes</parameter></paramdef>
- </funcsynopsis>
- Creates a new Java String object, where <parameter>bytes</parameter> are
- the UTF-8 encoded characters of the string, terminated by a null byte.
-</para>
-
-<para>
-<funcsynopsis>
- <funcdef>jchar *<function>JvGetStringChars</function></funcdef>
- <paramdef>jstring <parameter>str</parameter></paramdef>
- </funcsynopsis>
- Returns a pointer to the array of characters which make up a string.
-</para>
-
-<para>
-<funcsynopsis>
- <funcdef> int <function>JvGetStringUTFLength</function></funcdef>
- <paramdef>jstring <parameter>str</parameter></paramdef>
- </funcsynopsis>
- Returns number of bytes required to encode contents
- of <parameter>str</parameter> as UTF-8.
-</para>
-
-<para>
-<funcsynopsis>
- <funcdef> jsize <function>JvGetStringUTFRegion</function></funcdef>
- <paramdef>jstring <parameter>str</parameter></paramdef>
- <paramdef>jsize <parameter>start</parameter></paramdef>
- <paramdef>jsize <parameter>len</parameter></paramdef>
- <paramdef>char *<parameter>buf</parameter></paramdef>
- </funcsynopsis>
- This puts the UTF-8 encoding of a region of the
- string <parameter>str</parameter> into
- the buffer <parameter>buf</parameter>.
- The region of the string to fetch is specifued by
- <parameter>start</parameter> and <parameter>len</parameter>.
- It is assumed that <parameter>buf</parameter> is big enough
- to hold the result. Note
- that <parameter>buf</parameter> is <emphasis>not</emphasis> null-terminated.
-</para>
-</sect1>
-
-<sect1><title>Class Initialization</title>
-<para>
-Java requires that each class be automatically initialized at the time
-of the first active use. Initializing a class involves
-initializing the static fields, running code in class initializer
-methods, and initializing base classes. There may also be
-some implementation specific actions, such as allocating
-<classname>String</classname> objects corresponding to string literals in
-the code.</para>
-<para>
-The Gcj compiler inserts calls to <literal>JvInitClass</literal> (actually
-<literal>_Jv_InitClass</literal>) at appropriate places to ensure that a
-class is initialized when required. The C++ compiler does not
-insert these calls automatically - it is the programmer's
-responsibility to make sure classes are initialized. However,
-this is fairly painless because of the conventions assumed by the Java
-system.</para>
-<para>
-First, <literal>libgcj</literal> will make sure a class is initialized
-before an instance of that object is created. This is one
-of the responsibilities of the <literal>new</literal> operation. This is
-taken care of both in Java code, and in C++ code. (When the G++
-compiler sees a <literal>new</literal> of a Java class, it will call
-a routine in <literal>libgcj</literal> to allocate the object, and that
-routine will take care of initializing the class.) It follows that you can
-access an instance field, or call an instance (non-static)
-method and be safe in the knowledge that the class and all
-of its base classes have been initialized.</para>
-<para>
-Invoking a static method is also safe. This is because the
-Java compiler adds code to the start of a static method to make sure
-the class is initialized. However, the C++ compiler does not
-add this extra code. Hence, if you write a native static method
-using CNI, you are responsible for calling <literal>JvInitClass</literal>
-before doing anything else in the method (unless you are sure
-it is safe to leave it out).</para>
-<para>
-Accessing a static field also requires the class of the
-field to be initialized. The Java compiler will generate code
-to call <literal>_Jv_InitClass</literal> before getting or setting the field.
-However, the C++ compiler will not generate this extra code,
-so it is your responsibility to make sure the class is
-initialized before you access a static field.</para>
-</sect1>
-<sect1><title>Exception Handling</title>
-<para>
-While C++ and Java share a common exception handling framework,
-things are not yet perfectly integrated. The main issue is that the
-<quote>run-time type information</quote> facilities of the two
-languages are not integrated.</para>
-<para>
-Still, things work fairly well. You can throw a Java exception from
-C++ using the ordinary <literal>throw</literal> construct, and this
-exception can be caught by Java code. Similarly, you can catch an
-exception thrown from Java using the C++ <literal>catch</literal>
-construct.
-<para>
-Note that currently you cannot mix C++ catches and Java catches in
-a single C++ translation unit. We do intend to fix this eventually.
-</para>
-<para>
-Here is an example:
-<programlisting>
-if (i >= count)
- throw new java::lang::IndexOutOfBoundsException();
-</programlisting>
-</para>
-<para>
-Normally, GNU C++ will automatically detect when you are writing C++
-code that uses Java exceptions, and handle them appropriately.
-However, if C++ code only needs to execute destructors when Java
-exceptions are thrown through it, GCC will guess incorrectly. Sample
-problematic code:
-<programlisting>
- struct S { ~S(); };
- extern void bar(); // is implemented in Java and may throw exceptions
- void foo()
- {
- S s;
- bar();
- }
-</programlisting>
-The usual effect of an incorrect guess is a link failure, complaining of
-a missing routine called <literal>__gxx_personality_v0</literal>.
-</para>
-<para>
-You can inform the compiler that Java exceptions are to be used in a
-translation unit, irrespective of what it might think, by writing
-<literal>#pragma GCC java_exceptions</literal> at the head of the
-file. This <literal>#pragma</literal> must appear before any
-functions that throw or catch exceptions, or run destructors when
-exceptions are thrown through them.</para>
-</sect1>
-
-<sect1><title>Synchronization</title>
-<para>
-Each Java object has an implicit monitor.
-The Java VM uses the instruction <literal>monitorenter</literal> to acquire
-and lock a monitor, and <literal>monitorexit</literal> to release it.
-The JNI has corresponding methods <literal>MonitorEnter</literal>
-and <literal>MonitorExit</literal>. The corresponding CNI macros
-are <literal>JvMonitorEnter</literal> and <literal>JvMonitorExit</literal>.
-</para>
-<para>
-The Java source language does not provide direct access to these primitives.
-Instead, there is a <literal>synchronized</literal> statement that does an
-implicit <literal>monitorenter</literal> before entry to the block,
-and does a <literal>monitorexit</literal> on exit from the block.
-Note that the lock has to be released even the block is abnormally
-terminated by an exception, which means there is an implicit
-<literal>try</literal>-<literal>finally</literal>.
-</para>
-<para>
-From C++, it makes sense to use a destructor to release a lock.
-CNI defines the following utility class.
-<programlisting>
-class JvSynchronize() {
- jobject obj;
- JvSynchronize(jobject o) { obj = o; JvMonitorEnter(o); }
- ~JvSynchronize() { JvMonitorExit(obj); }
-};
-</programlisting>
-The equivalent of Java's:
-<programlisting>
-synchronized (OBJ) { CODE; }
-</programlisting>
-can be simply expressed:
-<programlisting>
-{ JvSynchronize dummy(OBJ); CODE; }
-</programlisting>
-</para>
-<para>
-Java also has methods with the <literal>synchronized</literal> attribute.
-This is equivalent to wrapping the entire method body in a
-<literal>synchronized</literal> statement.
-(Alternatively, an implementation could require the caller to do
-the synchronization. This is not practical for a compiler, because
-each virtual method call would have to test at run-time if
-synchronization is needed.) Since in <literal>gcj</literal>
-the <literal>synchronized</literal> attribute is handled by the
-method implementation, it is up to the programmer
-of a synchronized native method to handle the synchronization
-(in the C++ implementation of the method).
-In otherwords, you need to manually add <literal>JvSynchronize</literal>
-in a <literal>native synchornized</literal> method.</para>
-</sect1>
-
-<sect1><title>Reflection</title>
-<para>The types <literal>jfieldID</literal> and <literal>jmethodID</literal>
-are as in JNI.</para>
-<para>
-The function <literal>JvFromReflectedField</literal>,
-<literal>JvFromReflectedMethod</literal>,
-<literal>JvToReflectedField</literal>, and
-<literal>JvToFromReflectedMethod</literal> (as in Java 2 JNI)
-will be added shortly, as will other functions corresponding to JNI.</para>
-
-<sect1><title>Using gcjh</title>
-<para>
- The <command>gcjh</command> is used to generate C++ header files from
- Java class files. By default, <command>gcjh</command> generates
- a relatively straightforward C++ header file. However, there
- are a few caveats to its use, and a few options which can be
- used to change how it operates:
-</para>
-<variablelist>
-<varlistentry>
-<term><literal>--classpath</literal> <replaceable>path</replaceable></term>
-<term><literal>--CLASSPATH</literal> <replaceable>path</replaceable></term>
-<term><literal>-I</literal> <replaceable>dir</replaceable></term>
-<listitem><para>
- These options can be used to set the class path for gcjh.
- Gcjh searches the class path the same way the compiler does;
- these options have their familiar meanings.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>-d <replaceable>directory</replaceable></literal></term>
-<listitem><para>
-Puts the generated <literal>.h</literal> files
-beneath <replaceable>directory</replaceable>.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>-o <replaceable>file</replaceable></literal></term>
-<listitem><para>
- Sets the name of the <literal>.h</literal> file to be generated.
- By default the <literal>.h</literal> file is named after the class.
- This option only really makes sense if just a single class file
- is specified.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>--verbose</literal></term>
-<listitem><para>
- gcjh will print information to stderr as it works.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>-M</literal></term>
-<term><literal>-MM</literal></term>
-<term><literal>-MD</literal></term>
-<term><literal>-MMD</literal></term>
-<listitem><para>
- These options can be used to generate dependency information
- for the generated header file. They work the same way as the
- corresponding compiler options.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>-prepend <replaceable>text</replaceable></literal></term>
-<listitem><para>
-This causes the <replaceable>text</replaceable> to be put into the generated
- header just after class declarations (but before declaration
- of the current class). This option should be used with caution.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>-friend <replaceable>text</replaceable></literal></term>
-<listitem><para>
-This causes the <replaceable>text</replaceable> to be put into the class
-declaration after a <literal>friend</literal> keyword.
-This can be used to declare some
- other class or function to be a friend of this class.
- This option should be used with caution.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>-add <replaceable>text</replaceable></literal></term>
-<listitem><para>
-The <replaceable>text</replaceable> is inserted into the class declaration.
-This option should be used with caution.</para>
-</listitem>
-</varlistentry>
-
-<varlistentry>
-<term><literal>-append <replaceable>text</replaceable></literal></term>
-<listitem><para>
-The <replaceable>text</replaceable> is inserted into the header file
-after the class declaration. One use for this is to generate
-inline functions. This option should be used with caution.
-</listitem>
-</varlistentry>
-</variablelist>
-<para>
-All other options not beginning with a <literal>-</literal> are treated
-as the names of classes for which headers should be generated.</para>
-<para>
-gcjh will generate all the required namespace declarations and
-<literal>#include</literal>'s for the header file.
-In some situations, gcjh will generate simple inline member
-functions. Note that, while gcjh puts <literal>#pragma
-interface</literal> in the generated header file, you should
-<emphasis>not</emphasis> put <literal>#pragma implementation</literal>
-into your C++ source file. If you do, duplicate definitions of
-inline functions will sometimes be created, leading to link-time
-errors.
-</para>
-<para>
-There are a few cases where gcjh will fail to work properly:</para>
-<para>
-gcjh assumes that all the methods and fields of a class have ASCII
-names. The C++ compiler cannot correctly handle non-ASCII
-identifiers. gcjh does not currently diagnose this problem.</para>
-<para>
-gcjh also cannot fully handle classes where a field and a method have
-the same name. If the field is static, an error will result.
-Otherwise, the field will be renamed in the generated header; `__'
-will be appended to the field name.</para>
-<para>
-Eventually we hope to change the C++ compiler so that these
-restrictions can be lifted.</para>
-</sect1>
-
-</article>
+++ /dev/null
-/* DelegateFactory.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.javax.rmi.CORBA;
-
-import java.util.HashMap;
-import javax.rmi.CORBA.Util;
-
-public class DelegateFactory
-{
- private static HashMap cache = new HashMap(4);
-
- public static synchronized Object getInstance(String type)
- throws GetDelegateInstanceException
- {
- Object r = cache.get(type);
- if (r != null)
- return r;
- String dcname = System.getProperty("javax.rmi.CORBA." + type + "Class");
- if (dcname == null)
- {
- //throw new DelegateException
- // ("no javax.rmi.CORBA.XXXClass property sepcified.");
- dcname = "gnu.javax.rmi.CORBA." + type + "DelegateImpl";
- }
- try
- {
- Class dclass = Class.forName(dcname);
- r = dclass.newInstance();
- cache.put(type, r);
- return r;
- }
- catch(Exception e)
- {
- throw new GetDelegateInstanceException
- ("Exception when trying to get delegate instance:" + dcname, e);
- }
- }
-}
+++ /dev/null
-/* GetDelegateInstanceException.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.javax.rmi.CORBA;
-
-import java.io.PrintStream;
-import java.io.PrintWriter;
-
-public class GetDelegateInstanceException
- extends Exception
-{
- private Throwable next;
-
- public GetDelegateInstanceException(String msg)
- {
- super(msg);
- }
-
- public GetDelegateInstanceException(String msg, Throwable next)
- {
- super(msg, next);
- }
-}
+++ /dev/null
-/* PortableRemoteObjectDelegateImpl.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.javax.rmi.CORBA;
-
-import java.rmi.*;
-import java.rmi.server.*;
-import gnu.javax.rmi.*;
-import javax.rmi.CORBA.*;
-
-public class PortableRemoteObjectDelegateImpl
- implements PortableRemoteObjectDelegate
-{
-
- public PortableRemoteObjectDelegateImpl()
- {
- }
-
- public void connect(Remote remote, Remote remote1)
- throws RemoteException
- {
- throw new Error("Not implemented for PortableRemoteObjectDelegateImpl");
- }
-
- public void exportObject(Remote obj)
- throws RemoteException
- {
- PortableServer.exportObject(obj);
- }
-
- public Object narrow(Object narrowFrom, Class narrowTo)
- throws ClassCastException
- {
- if (narrowTo == null)
- throw new ClassCastException("Can't narrow to null class");
- if (narrowFrom == null)
- return null;
-
- Class fromClass = narrowFrom.getClass();
- Object result = null;
-
- try
- {
- if (narrowTo.isAssignableFrom(fromClass))
- result = narrowFrom;
- else
- {
- System.out.println("We still haven't implement this case: narrow "
- + narrowFrom + " of type " + fromClass + " to "
- + narrowTo);
- Class[] cs = fromClass.getInterfaces();
- for (int i = 0; i < cs.length; i++)
- System.out.println(cs[i]);
- Exception e1 = new Exception();
- try
- {
- throw e1;
- }
- catch(Exception ee)
- {
- ee.printStackTrace();
- }
- System.exit(2);
- //throw new Error("We still haven't implement this case: narrow "
- // + narrowFrom + " of type " + fromClass + " to "
- // + narrowTo);
- /*
- ObjectImpl objimpl = (ObjectImpl)narrowFrom;
- if(objimpl._is_a(PortableServer.getTypeName(narrowTo)))
- result = PortableServer.getStubFromObjectImpl(objimpl, narrowTo);
- */
- }
- }
- catch(Exception e)
- {
- result = null;
- }
-
- if (result == null)
- throw new ClassCastException("Can't narrow from "
- + fromClass + " to " + narrowTo);
-
- return result;
- }
-
- public Remote toStub(Remote obj)
- throws NoSuchObjectException
- {
- return PortableServer.toStub(obj);
- }
-
- public void unexportObject(Remote obj)
- throws NoSuchObjectException
- {
- PortableServer.unexportObject(obj);
- }
-
-}
+++ /dev/null
-/* StubDelegateImpl.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.javax.rmi.CORBA;
-
-import java.io.IOException;
-import java.io.ObjectInputStream;
-import java.io.ObjectOutputStream;
-//import org.omg.CORBA.portable.Delegate;
-//import org.omg.CORBA.portable.InputStream;
-//import org.omg.CORBA.portable.OutputStream;
-//import org.omg.CORBA_2_3.portable.ObjectImpl;
-//import org.omg.CORBA.portable.ObjectImpl;
-//import org.omg.CORBA.BAD_OPERATION;
-//import org.omg.CORBA.ORB;
-import java.rmi.RemoteException;
-import javax.rmi.CORBA.Stub;
-import javax.rmi.CORBA.StubDelegate;
-import javax.rmi.CORBA.Tie;
-import javax.rmi.CORBA.StubDelegate;
-
-public class StubDelegateImpl
- implements StubDelegate
-{
-
- private int hashCode;
-
- public StubDelegateImpl(){
- hashCode = 0;
- }
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- public void connect(Stub self, javax.rmi.ORB orb)
- throws RemoteException
- {
- throw new Error("Not implemented for StubDelegate");
- }
-
- public boolean equals(Stub self, Object obj)
- {
- if(self == null || obj == null)
- return self == obj;
- if(!(obj instanceof Stub))
- return false;
- return self.hashCode() == ((Stub)obj).hashCode();
- }
-
- public int hashCode(Stub self)
- {
- //FIX ME
- return hashCode;
- }
-
- public String toString(Stub self)
- {
- try
- {
- return self._orb().object_to_string(self);
- }
- // XXX javax.rmi.BAD_OPERATION -> org.omg.CORBA.BAD_OPERATION
- catch(javax.rmi.BAD_OPERATION bad_operation)
- {
- return null;
- }
- }
-
- public void readObject(Stub self, ObjectInputStream s)
- throws IOException, ClassNotFoundException
- {
- throw new Error("Not implemented for StubDelegate");
- }
-
- public void writeObject(Stub self, ObjectOutputStream s)
- throws IOException
- {
- throw new Error("Not implemented for StubDelegate");
- }
-
-}
+++ /dev/null
-/* UtilDelegateImpl.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.javax.rmi.CORBA;
-
-import java.rmi.Remote;
-import java.rmi.RemoteException;
-import java.rmi.server.RMIClassLoader;
-import java.net.MalformedURLException;
-import java.io.*;
-//import org.omg.CORBA.ORB;
-//import org.omg.CORBA.SystemException;
-//import org.omg.CORBA.portable.InputStream;
-//import org.omg.CORBA.portable.OutputStream;
-import javax.rmi.CORBA.*;
-
-public class UtilDelegateImpl
- implements UtilDelegate
-{
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- public Object copyObject(Object obj, javax.rmi.ORB orb)
- throws RemoteException
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- public Object[] copyObjects(Object obj[], javax.rmi.ORB orb)
- throws RemoteException
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public ValueHandler createValueHandler()
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public String getCodebase(Class clz)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public Tie getTie(Remote target)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public boolean isLocal(Stub stub)
- throws RemoteException
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public Class loadClass(String className, String remoteCodebase,
- ClassLoader loader)
- throws ClassNotFoundException
- {
- try{
- if (remoteCodebase == null)
- return RMIClassLoader.loadClass(className);
- else
- return RMIClassLoader.loadClass(remoteCodebase, className);
- }
- catch (MalformedURLException e1)
- {
- throw new ClassNotFoundException(className, e1);
- }
- catch(ClassNotFoundException e2)
- {
- if(loader != null)
- return loader.loadClass(className);
- else
- return null;
- }
- }
-
- public RemoteException mapSystemException(SystemException ex)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public Object readAny(InputStream in)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public void registerTarget(Tie tie, Remote target)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public void unexportObject(Remote target)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public RemoteException wrapException(Throwable orig)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public void writeAbstractObject(OutputStream out, Object obj)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public void writeAny(OutputStream out, Object obj)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-
- public void writeRemoteObject(OutputStream out, Object obj)
- {
- throw new Error("Not implemented for UtilDelegate");
- }
-}
+++ /dev/null
-/* ValueHandlerImpl.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.javax.rmi.CORBA;
-
-import java.io.*;
-//import org.omg.CORBA.portable.InputStream;
-//import org.omg.CORBA.portable.OutputStream;
-//import org.omg.SendingContext.RunTime;
-import javax.rmi.CORBA.ValueHandler;
-
-public class ValueHandlerImpl
- implements ValueHandler
-{
-
- public String getRMIRepositoryID(Class clz)
- {
- throw new Error("Not implemented for ValueHandler");
- }
-
- // XXX - Runtime -> RunTime
- public Runtime getRunTimeCodeBase()
- {
- throw new Error("Not implemented for ValueHandler");
- }
-
- public boolean isCustomMarshaled(Class clz)
- {
- throw new Error("Not implemented for ValueHandler");
- }
-
- // XXX - Runtime -> RunTime
- public Serializable readValue(InputStream in, int offset, Class clz, String repositoryID, Runtime sender)
- {
- throw new Error("Not implemented for ValueHandler");
- }
-
- public Serializable writeReplace(Serializable value)
- {
- throw new Error("Not implemented for ValueHandler");
- }
-
- public void writeValue(OutputStream out, Serializable value)
- {
- throw new Error("Not implemented for ValueHandler");
- }
-}
+++ /dev/null
-/* PortableServer.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.javax.rmi;
-
-import java.util.Hashtable;
-import java.rmi.Remote;
-import java.rmi.RemoteException;
-import java.rmi.NoSuchObjectException;
-import java.rmi.server.ExportException;
-import java.rmi.server.UnicastRemoteObject;
-import java.rmi.server.RemoteStub;
-import javax.rmi.CORBA.*;
-//import org.omg.CORBA.portable.ObjectImpl;
-
-/**
- * The relationship of PortableRemoteObjectImpl with PortableServer
- * is like that of UnicastRemoteObject with UnicastServer
- */
-public class PortableServer
-{
- static private Hashtable tieCache = new Hashtable();
- static private Object NO_TIE = new Object();
-
- public static final synchronized void exportObject(Remote obj)
- throws RemoteException
- {
- if(Util.getTie(obj) != null)
- return;
-
- Tie tie = getTieFromRemote(obj);
- if (tie != null)
- Util.registerTarget(tie, obj);
- else
- UnicastRemoteObject.exportObject(obj);
- }
-
- public static final void unexportObject(Remote obj)
- {
- if (Util.getTie(obj) != null)
- Util.unexportObject(obj);
- if (tieCache.get(obj) != null) //??
- tieCache.remove(obj);
- }
-
- public static final Remote toStub(Remote obj)
- throws NoSuchObjectException
- {
- if (obj instanceof Stub || obj instanceof RemoteStub)
- return obj;
-
- Tie tie = Util.getTie(obj);
- Remote stub;
- if (tie != null)
- stub = getStubFromTie(tie);
- else
- throw new NoSuchObjectException("Can't toStub an unexported object");
- return stub;
- }
-
- static synchronized Tie getTieFromRemote(Remote obj)
- {
- Object tie = tieCache.get(obj);
- if (tie == null)
- {
- tie = getTieFromClass(obj.getClass());
- if(tie == null)
- tieCache.put(obj, NO_TIE);
- else
- tieCache.put(obj, tie);
- }
- else
- if(tie != NO_TIE)
- {
- try
- {
- tie = obj.getClass().newInstance();
- }
- catch(Exception _)
- {
- tie = null;
- }
- }
- else //NO_TIE
- tie = null;
-
- return (Tie)tie;
- }
-
- static synchronized Tie getTieFromClass(Class clz)
- {
- //FIX ME
- return null;
- }
-
- public static Remote getStubFromTie(Tie tie)
- {
- //FIX ME
- return null;
- }
-
- public static Remote getStubFromObjectImpl(ObjectImpl objimpl, Class toClass)
- {
- //FIX ME
- return null;
- }
-}
+++ /dev/null
-package javax.rmi;
-
-/** XXX - Stub till we have org.omg.CORBA */
-public class BAD_OPERATION extends Exception { }
+++ /dev/null
-/* ClassDesc.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.io.Serializable;
-
-public class ClassDesc
- implements Serializable
-{
- /*
- * The following is serialized form required by Java API Doc
- */
- private String repid;
- private String codebase;
-
- public ClassDesc()
- {
- }
-}
+++ /dev/null
-package javax.rmi.CORBA;
-
-/** XXX - Stub till we have org.omg.CORBA */
-public class ObjectImpl
-{
- public ObjectImpl _orb() { return null; }
- public String object_to_string(ObjectImpl o)
- throws javax.rmi.BAD_OPERATION { return null; }
-}
+++ /dev/null
-/* PortableRemoteObjectDelegate.java -- Interface supporting PortableRemoteObject
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.rmi.*;
-
-/**
- * A delegate is a singleton class that support delegation for method
- * implementation in PortableRemoteObject.
- */
-public interface PortableRemoteObjectDelegate
-{
- void connect(Remote target, Remote source)
- throws RemoteException;
-
- void exportObject(Remote obj)
- throws RemoteException;
-
- Object narrow(Object narrowFrom, Class narrowTo)
- throws ClassCastException;
-
- Remote toStub(Remote obj)
- throws NoSuchObjectException;
-
- void unexportObject(Remote obj)
- throws NoSuchObjectException;
-}
+++ /dev/null
-/* Stub.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.io.IOException;
-import java.io.ObjectInputStream;
-import java.io.ObjectOutputStream;
-import java.io.Serializable;
-import java.rmi.RemoteException;
-//import org.omg.CORBA.ORB;
-//import org.omg.CORBA_2_3.portable.ObjectImpl;
-//import org.omg.CORBA.portable.ObjectImpl;
-import gnu.javax.rmi.CORBA.DelegateFactory;
-import gnu.javax.rmi.CORBA.GetDelegateInstanceException;
-
-public abstract class Stub extends ObjectImpl
- implements Serializable
-{
- private transient StubDelegate delegate;
-
- protected Stub()
- {
- try
- {
- delegate = (StubDelegate)DelegateFactory.getInstance("Stub");
- }
- catch(GetDelegateInstanceException e)
- {
- delegate = null;
- }
- }
-
- public int hashCode()
- {
- if(delegate != null)
- return delegate.hashCode(this);
- else
- return 0;
- }
-
- public boolean equals(Object obj)
- {
- if(delegate != null)
- return delegate.equals(this, obj);
- else
- return false;
- }
-
- public String toString()
- {
- String s = null;
- if(delegate != null)
- s = delegate.toString(this);
- if(s == null)
- s = super.toString();
- return s;
- }
-
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- public void connect(javax.rmi.ORB orb)
- throws RemoteException
- {
- if(delegate != null)
- delegate.connect(this, orb);
- }
-
- /**
- * The following two routines are required by serialized form of Java API doc.
- */
- private void readObject(ObjectInputStream stream)
- throws IOException, ClassNotFoundException
- {
- if(delegate != null)
- delegate.readObject(this, stream);
- }
-
- private void writeObject(ObjectOutputStream stream)
- throws IOException
- {
- if(delegate != null)
- delegate.writeObject(this, stream);
- }
-
-}
+++ /dev/null
-/* StubDelegate.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.io.IOException;
-import java.io.ObjectInputStream;
-import java.io.ObjectOutputStream;
-import java.rmi.RemoteException;
-//import org.omg.CORBA.ORB;
-
-public interface StubDelegate
-{
-
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- void connect(Stub self, javax.rmi.ORB orb)
- throws RemoteException;
-
- boolean equals(Stub self, Object obj);
-
- int hashCode(Stub self);
-
- void readObject(Stub self, ObjectInputStream s)
- throws IOException, ClassNotFoundException;
-
- String toString(Stub self);
-
- void writeObject(Stub self, ObjectOutputStream s)
- throws IOException;
-}
+++ /dev/null
-package javax.rmi.CORBA;
-
-/** XXX - Stub till we have org.omg.CORBA */
-public class SystemException extends Exception { }
+++ /dev/null
-/* Tie.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.rmi.Remote;
-//import org.omg.CORBA.ORB;
-//import org.omg.CORBA.portable.InvokeHandler;
-
-public interface Tie // XXX extends InvokeHandler
-{
-
- void deactivate();
-
- Remote getTarget();
-
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- javax.rmi.ORB orb();
-
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- void orb(javax.rmi.ORB orb);
-
- void setTarget(Remote target);
-
- // XXX Object -> org.omg.CORBA.Object
- Object thisObject();
-}
+++ /dev/null
-/* Util.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.rmi.Remote;
-import java.rmi.RemoteException;
-import java.lang.Object;
-import java.io.*;
-//import org.omg.CORBA.*;
-//import org.omg.CORBA.portable.InputStream;
-//import org.omg.CORBA.portable.OutputStream;
-import gnu.javax.rmi.CORBA.DelegateFactory;
-import gnu.javax.rmi.CORBA.GetDelegateInstanceException;
-
-public class Util
-{
-
- private static UtilDelegate delegate;
- static
- {
- try
- {
- delegate = (UtilDelegate)DelegateFactory.getInstance("Util");
- }
- catch(GetDelegateInstanceException e)
- {
- delegate = null;
- }
- }
-
- private Util()
- {
- }
-
- // XXX - javax.rmi.ORB -> org.omg.CORBA.ORB
- public static Object copyObject(Object obj, javax.rmi.ORB orb)
- throws RemoteException
- {
- if(delegate != null)
- return delegate.copyObject(obj, orb);
- else
- return null;
- }
-
- // XXX - javax.rmi.ORB -> org.omg.CORBA.ORB
- public static Object[] copyObjects(Object obj[], javax.rmi.ORB orb)
- throws RemoteException
- {
- if(delegate != null)
- return delegate.copyObjects(obj, orb);
- else
- return null;
- }
-
- public static ValueHandler createValueHandler()
- {
- if(delegate != null)
- return delegate.createValueHandler();
- else
- return null;
- }
-
- public static String getCodebase(Class clz)
- {
- if(delegate != null)
- return delegate.getCodebase(clz);
- else
- return null;
- }
-
- public static Tie getTie(Remote target)
- {
- if(delegate != null)
- return delegate.getTie(target);
- else
- return null;
- }
-
- public static boolean isLocal(Stub stub)
- throws RemoteException
- {
- if(delegate != null)
- return delegate.isLocal(stub);
- else
- return false;
- }
-
- public static Class loadClass(String className, String remoteCodebase, ClassLoader loader)
- throws ClassNotFoundException
- {
- if(delegate != null)
- return delegate.loadClass(className, remoteCodebase, loader);
- else
- throw new ClassNotFoundException(className + ": delegate == null");
- }
-
- public static RemoteException mapSystemException(SystemException ex)
- {
- if(delegate != null)
- return delegate.mapSystemException(ex);
- else
- return null;
- }
-
- public static Object readAny(InputStream in)
- {
- if(delegate != null)
- return delegate.readAny(in);
- else
- return null;
- }
-
- public static void registerTarget(Tie tie, Remote target)
- {
- if(delegate != null)
- delegate.registerTarget(tie, target);
- }
-
- public static void unexportObject(Remote target)
- {
- if(delegate != null)
- delegate.unexportObject(target);
- }
-
- public static RemoteException wrapException(Throwable orig)
- {
- if(delegate != null)
- return delegate.wrapException(orig);
- else
- return null;
- }
-
- public static void writeAbstractObject(OutputStream out, Object obj)
- {
- if(delegate != null)
- delegate.writeAbstractObject(out, obj);
- }
-
- public static void writeAny(OutputStream out, Object obj)
- {
- if(delegate != null)
- delegate.writeAny(out, obj);
- }
-
- public static void writeRemoteObject(OutputStream out, Object obj)
- {
- if(delegate != null)
- delegate.writeRemoteObject(out, obj);
- }
-
-}
+++ /dev/null
-/* UtilDelegate.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.rmi.Remote;
-import java.rmi.RemoteException;
-import java.io.*;
-//import org.omg.CORBA.ORB;
-//import org.omg.CORBA.SystemException;
-//import org.omg.CORBA.portable.InputStream;
-//import org.omg.CORBA.portable.OutputStream;
-
-public interface UtilDelegate
-{
-
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- Object copyObject(Object obj, javax.rmi.ORB orb) throws RemoteException;
-
- // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
- Object[] copyObjects(Object obj[], javax.rmi.ORB orb) throws RemoteException;
-
- ValueHandler createValueHandler();
-
- String getCodebase(Class clz);
-
- Tie getTie(Remote target);
-
- boolean isLocal(Stub stub) throws RemoteException;
-
- Class loadClass(String className, String remoteCodebase,
- ClassLoader loader) throws ClassNotFoundException;
-
- RemoteException mapSystemException(SystemException ex);
-
- Object readAny(InputStream in);
-
- void registerTarget(Tie tie, Remote target);
-
- void unexportObject(Remote target);
-
- RemoteException wrapException(Throwable orig);
-
- void writeAbstractObject(OutputStream out, Object obj);
-
- void writeAny(OutputStream out, Object obj);
-
- void writeRemoteObject(OutputStream out, Object obj);
-}
+++ /dev/null
-/* ValueHandler.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi.CORBA;
-
-import java.io.*;
-//import org.omg.CORBA.portable.InputStream;
-//import org.omg.CORBA.portable.OutputStream;
-//import org.omg.SendingContext.RunTime;
-
-public interface ValueHandler
-{
-
- String getRMIRepositoryID(Class clz);
-
- // XXX Runtime -> RunTime
- Runtime getRunTimeCodeBase();
-
- boolean isCustomMarshaled(Class clz);
-
- // XXX Runtime -> RunTime
- Serializable readValue(InputStream in, int offset, Class clz,
- String repositoryID, Runtime sender);
-
- Serializable writeReplace(Serializable value);
-
- void writeValue(OutputStream out, Serializable value);
-}
+++ /dev/null
-package javax.rmi;
-
-/** XXX - Stub till we have org.omg.CORBA */
-public class ORB { }
+++ /dev/null
-/* PortableRemoteObject.java --
- Copyright (C) 2002 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package javax.rmi;
-
-import java.rmi.Remote;
-import java.rmi.RemoteException;
-import java.rmi.NoSuchObjectException;
-import gnu.javax.rmi.CORBA.DelegateFactory;
-import gnu.javax.rmi.CORBA.GetDelegateInstanceException;
-import javax.rmi.CORBA.PortableRemoteObjectDelegate;
-import javax.rmi.CORBA.Util;
-
-public class PortableRemoteObject
- implements Remote /* why doc doesn't say should implement Remote */
-{
-
- private static PortableRemoteObjectDelegate delegate;
- static
- {
- try
- {
- delegate = (PortableRemoteObjectDelegate)DelegateFactory.getInstance
- ("PortableRemoteObject");
- }
- catch(GetDelegateInstanceException e)
- {
- e.printStackTrace();
- delegate = null;
- }
- }
-
- protected PortableRemoteObject()
- throws RemoteException
- {
- if(delegate != null)
- exportObject((Remote)this);
- }
-
- public static void connect(Remote target, Remote source)
- throws RemoteException
- {
- if(delegate != null)
- delegate.connect(target, source);
- }
-
- public static void exportObject(Remote obj)
- throws RemoteException
- {
- if(delegate != null)
- delegate.exportObject(obj);
- }
-
- public static Object narrow(Object narrowFrom, Class narrowTo)
- throws ClassCastException
- {
- if(delegate != null)
- return delegate.narrow(narrowFrom, narrowTo);
- else
- return null;
- }
-
- public static Remote toStub(Remote obj)
- throws NoSuchObjectException
- {
- if(delegate != null)
- return delegate.toStub(obj);
- else
- return null;
- }
-
- public static void unexportObject(Remote obj)
- throws NoSuchObjectException
- {
- if(delegate != null)
- delegate.unexportObject(obj);
- }
-
-}
+++ /dev/null
-// 2001-06-14 Benjamin Kosnik <bkoz@redhat.com>
-
-// Copyright (C) 2001, 2002, 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.1.1 allocator members
-
-#include <memory>
-#include <stdexcept>
-#include <cstdlib>
-#include <testsuite_hooks.h>
-
-struct gnu { };
-
-bool check_new = false;
-bool check_delete = false;
-
-void*
-operator new(std::size_t n) throw(std::bad_alloc)
-{
- check_new = true;
- return std::malloc(n);
-}
-
-void operator delete(void *v) throw()
-{
- check_delete = true;
- return std::free(v);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-// Explicitly instantiate for systems with no COMDAT or weak support.
-template class __gnu_cxx::__mt_alloc<gnu>;
-#endif
-
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::allocator<gnu> obj;
-
- // NB: These should work for various size allocation and
- // deallocations. Currently, they only work as expected for sizes >
- // _MAX_BYTES as defined in stl_alloc.h, which happes to be 128.
- gnu* pobj = obj.allocate(256);
- VERIFY( check_new );
-
- obj.deallocate(pobj, 256);
- VERIFY( check_delete );
-}
-
-int main()
-{
- test01();
- return 0;
-}
-
+++ /dev/null
-// Copyright (C) 2003, 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.1.5 allocator requirements / 20.4.1.1 allocator members
-
-#include <list>
-#include <cstdlib>
-#include <testsuite_hooks.h>
-
-class Bob
-{
-public:
- static void* operator new(size_t sz)
- { return std::malloc(sz); }
-};
-
-// libstdc++/10378
-void test01()
-{
- using namespace std;
- bool test __attribute__((unused)) = true;
-
- list<Bob> uniset;
- uniset.push_back(Bob());
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-// Explicitly instantiate for systems with no COMDAT or weak support.
-template class __gnu_cxx::__mt_alloc<std::_List_node<Bob> >;
-#endif
-
-int main()
-{
- test01();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.1.1 allocator members
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-// libstdc++/14176
-void test02()
-{
- unsigned int len = 0;
- std::allocator<int> a;
- int* p = a.allocate(len);
- a.deallocate(p, len);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-// Explicitly instantiate for systems with no COMDAT or weak support.
-template class __gnu_cxx::__mt_alloc<int>;
-#endif
-
-int main()
-{
- test02();
- return 0;
-}
+++ /dev/null
-// 2001-06-14 Benjamin Kosnik <bkoz@redhat.com>
-
-// Copyright (C) 2001, 2002, 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.1.1 allocator members
-
-#include <memory>
-#include <stdexcept>
-#include <testsuite_hooks.h>
-
-// libstdc++/8230
-void test02()
-{
- bool test __attribute__((unused)) = true;
- try
- {
- std::allocator<int> alloc;
- const std::allocator<int>::size_type n = alloc.max_size();
- int* p = alloc.allocate(n + 1);
- p[n] = 2002;
- }
- catch(const std::bad_alloc& e)
- {
- // Allowed.
- test = true;
- }
- catch(...)
- {
- test = false;
- }
- VERIFY( test );
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-// Explicitly instantiate for systems with no COMDAT or weak support.
-template class __gnu_cxx::__mt_alloc<int>;
-#endif
-
-int main()
-{
- test02();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-struct A
-{
- A() { ++ctor_count; }
- virtual ~A() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long A::ctor_count = 0;
-long A::dtor_count = 0;
-
-struct B : A
-{
- B() { ++ctor_count; }
- virtual ~B() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long B::ctor_count = 0;
-long B::dtor_count = 0;
-
-
-struct reset_count_struct
-{
- ~reset_count_struct()
- {
- A::ctor_count = 0;
- A::dtor_count = 0;
- B::ctor_count = 0;
- B::dtor_count = 0;
- }
-};
-
-
-// 20.4.5.1 auto_ptr constructors [lib.auto.ptr.cons]
-
-// Construction from pointer
-int
-test01()
-{
- reset_count_struct __attribute__((unused)) reset;
- bool test __attribute__((unused)) = true;
-
- std::auto_ptr<A> A_default;
- VERIFY( A_default.get() == 0 );
- VERIFY( A::ctor_count == 0 );
- VERIFY( A::dtor_count == 0 );
- VERIFY( B::ctor_count == 0 );
- VERIFY( B::dtor_count == 0 );
-
- std::auto_ptr<A> A_from_A(new A);
- VERIFY( A_from_A.get() != 0 );
- VERIFY( A::ctor_count == 1 );
- VERIFY( A::dtor_count == 0 );
- VERIFY( B::ctor_count == 0 );
- VERIFY( B::dtor_count == 0 );
-
- std::auto_ptr<A> A_from_B(new B);
- VERIFY( A_from_B.get() != 0 );
- VERIFY( A::ctor_count == 2 );
- VERIFY( A::dtor_count == 0 );
- VERIFY( B::ctor_count == 1 );
- VERIFY( B::dtor_count == 0 );
-
- return 0;
-}
-
-int
-main()
-{
- test01();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-struct A
-{
- A() { ++ctor_count; }
- virtual ~A() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long A::ctor_count = 0;
-long A::dtor_count = 0;
-
-struct B : A
-{
- B() { ++ctor_count; }
- virtual ~B() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long B::ctor_count = 0;
-long B::dtor_count = 0;
-
-
-struct reset_count_struct
-{
- ~reset_count_struct()
- {
- A::ctor_count = 0;
- A::dtor_count = 0;
- B::ctor_count = 0;
- B::dtor_count = 0;
- }
-};
-
-// Construction from std::auto_ptr
-int
-test02()
-{
- reset_count_struct __attribute__((unused)) reset;
- bool test __attribute__((unused)) = true;
-
- std::auto_ptr<A> A_from_A(new A);
- std::auto_ptr<B> B_from_B(new B);
-
- std::auto_ptr<A> A_from_ptr_A(A_from_A);
- std::auto_ptr<A> A_from_ptr_B(B_from_B);
- VERIFY( A_from_A.get() == 0 );
- VERIFY( B_from_B.get() == 0 );
- VERIFY( A_from_ptr_A.get() != 0 );
- VERIFY( A_from_ptr_B.get() != 0 );
- VERIFY( A::ctor_count == 2 );
- VERIFY( A::dtor_count == 0 );
- VERIFY( B::ctor_count == 1 );
- VERIFY( B::dtor_count == 0 );
-
- return 0;
-}
-
-int
-main()
-{
- test02();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-struct A
-{
- A() { ++ctor_count; }
- virtual ~A() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long A::ctor_count = 0;
-long A::dtor_count = 0;
-
-struct B : A
-{
- B() { ++ctor_count; }
- virtual ~B() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long B::ctor_count = 0;
-long B::dtor_count = 0;
-
-
-struct reset_count_struct
-{
- ~reset_count_struct()
- {
- A::ctor_count = 0;
- A::dtor_count = 0;
- B::ctor_count = 0;
- B::dtor_count = 0;
- }
-};
-
-// Assignment from std::auto_ptr
-int
-test03()
-{
- reset_count_struct __attribute__((unused)) reset;
- bool test __attribute__((unused)) = true;
-
- std::auto_ptr<A> A_from_ptr_A;
- std::auto_ptr<A> A_from_ptr_B;
- std::auto_ptr<A> A_from_A(new A);
- std::auto_ptr<B> B_from_B(new B);
-
- A_from_ptr_A = A_from_A;
- A_from_ptr_B = B_from_B;
- VERIFY( A_from_A.get() == 0 );
- VERIFY( B_from_B.get() == 0 );
- VERIFY( A_from_ptr_A.get() != 0 );
- VERIFY( A_from_ptr_B.get() != 0 );
- VERIFY( A::ctor_count == 2 );
- VERIFY( A::dtor_count == 0 );
- VERIFY( B::ctor_count == 1 );
- VERIFY( B::dtor_count == 0 );
-
- return 0;
-}
-
-int
-main()
-{
- test03();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-// libstdc++/3946
-// http://gcc.gnu.org/ml/libstdc++/2002-07/msg00024.html
-struct Base { };
-struct Derived : public Base { };
-
-std::auto_ptr<Derived>
-conversiontest08() { return std::auto_ptr<Derived>(new Derived); }
-
-void
-test08()
-{
- std::auto_ptr<Base> ptr;
- ptr = conversiontest08();
-}
-
-
-int
-main()
-{
- test08();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-struct A
-{
- A() { ++ctor_count; }
- virtual ~A() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long A::ctor_count = 0;
-long A::dtor_count = 0;
-
-struct B : A
-{
- B() { ++ctor_count; }
- virtual ~B() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long B::ctor_count = 0;
-long B::dtor_count = 0;
-
-
-struct reset_count_struct
-{
- ~reset_count_struct()
- {
- A::ctor_count = 0;
- A::dtor_count = 0;
- B::ctor_count = 0;
- B::dtor_count = 0;
- }
-};
-
-
-// Destruction
-int
-test04()
-{
- reset_count_struct __attribute__((unused)) reset;
- bool test __attribute__((unused)) = true;
-
- {/*lifetine scope*/
- std::auto_ptr<A> A_from_A(new A);
- std::auto_ptr<A> A_from_B(new B);
- std::auto_ptr<B> B_from_B(new B);
- }/*destructors called here*/
-
- VERIFY( A::ctor_count == 3 );
- VERIFY( A::dtor_count == 3 );
- VERIFY( B::ctor_count == 2 );
- VERIFY( B::dtor_count == 2 );
-
- return 0;
-}
-
-int
-main()
-{
- test04();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-struct A
-{
- A() { ++ctor_count; }
- virtual ~A() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long A::ctor_count = 0;
-long A::dtor_count = 0;
-
-struct B : A
-{
- B() { ++ctor_count; }
- virtual ~B() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long B::ctor_count = 0;
-long B::dtor_count = 0;
-
-
-struct reset_count_struct
-{
- ~reset_count_struct()
- {
- A::ctor_count = 0;
- A::dtor_count = 0;
- B::ctor_count = 0;
- B::dtor_count = 0;
- }
-};
-
-
-// Class member construction/destruction
-template <typename T>
-class pimpl
-{
-public:
- pimpl() : p_impl(new T) {}
-private:
- std::auto_ptr<T> p_impl;
-};
-
-int
-test05()
-{
- bool test __attribute__((unused)) = true;
- reset_count_struct __attribute__((unused)) reset;
-
- pimpl<A>();
- pimpl<B>();
- VERIFY( A::ctor_count == 2 );
- VERIFY( A::dtor_count == 2 );
- VERIFY( B::ctor_count == 1 );
- VERIFY( B::dtor_count == 1 );
- return 0;
-}
-
-int
-main()
-{
- test05();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-struct A
-{
- A() { ++ctor_count; }
- virtual ~A() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long A::ctor_count = 0;
-long A::dtor_count = 0;
-
-struct B : A
-{
- B() { ++ctor_count; }
- virtual ~B() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long B::ctor_count = 0;
-long B::dtor_count = 0;
-
-
-struct reset_count_struct
-{
- ~reset_count_struct()
- {
- A::ctor_count = 0;
- A::dtor_count = 0;
- B::ctor_count = 0;
- B::dtor_count = 0;
- }
-};
-
-// 20.4.5.2 auto_ptr members [lib.auto.ptr.members]
-
-// Member access
-int
-test06()
-{
- reset_count_struct __attribute__((unused)) reset;
- bool test __attribute__((unused)) = true;
-
- std::auto_ptr<A> A_from_A(new A);
- std::auto_ptr<A> A_from_A_ptr(A_from_A.release());
- VERIFY( A_from_A.get() == 0 );
- VERIFY( A_from_A_ptr.get() != 0 );
- VERIFY( A_from_A_ptr->ctor_count == 1 );
- VERIFY( (*A_from_A_ptr).dtor_count == 0 );
-
- A* A_ptr = A_from_A_ptr.get();
-
- A_from_A_ptr.reset(A_ptr);
- VERIFY( A_from_A_ptr.get() == A_ptr );
- VERIFY( A_from_A_ptr->ctor_count == 1 );
- VERIFY( (*A_from_A_ptr).dtor_count == 0 );
-
- A_from_A_ptr.reset(new A);
- VERIFY( A_from_A_ptr.get() != A_ptr );
- VERIFY( A_from_A_ptr->ctor_count == 2 );
- VERIFY( (*A_from_A_ptr).dtor_count == 1 );
- return 0;
-}
-
-int
-main()
-{
- test06();
- return 0;
-}
+++ /dev/null
-// Copyright (C) 2000, 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-struct A
-{
- A() { ++ctor_count; }
- virtual ~A() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long A::ctor_count = 0;
-long A::dtor_count = 0;
-
-struct B : A
-{
- B() { ++ctor_count; }
- virtual ~B() { ++dtor_count; }
- static long ctor_count;
- static long dtor_count;
-};
-long B::ctor_count = 0;
-long B::dtor_count = 0;
-
-
-struct reset_count_struct
-{
- ~reset_count_struct()
- {
- A::ctor_count = 0;
- A::dtor_count = 0;
- B::ctor_count = 0;
- B::dtor_count = 0;
- }
-};
-
-// 20.4.5.3 auto_ptr conversions [lib.auto.ptr.conv]
-
-// Parameters and return values
-template <typename T>
-static std::auto_ptr<T> source()
-{
- return std::auto_ptr<T>(new T);
-}
-
-template <typename T>
-static void drain(std::auto_ptr<T>)
-{}
-
-int
-test07()
-{
- bool test __attribute__((unused)) = true;
- reset_count_struct __attribute__((unused)) reset;
-
- drain(source<A>());
- // The resolution of core issue 84, now a DR, breaks this call.
- // drain<A>(source<B>());
- drain(source<B>());
- VERIFY( A::ctor_count == 2 );
- VERIFY( A::dtor_count == 2 );
- VERIFY( B::ctor_count == 1 );
- VERIFY( B::dtor_count == 1 );
- return 0;
-}
-
-int
-main()
-{
- test07();
- return 0;
-}
+++ /dev/null
-// { dg-do compile }
-
-// Copyright (C) 2002, 2003, 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.5 Template class auto_ptr negative tests [lib.auto.ptr]
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-// via Jack Reeves <jack_reeves@hispeed.ch>
-// libstdc++/3946
-// http://gcc.gnu.org/ml/libstdc++/2002-07/msg00024.html
-struct Base { };
-struct Derived : public Base { };
-
-std::auto_ptr<Derived>
-foo() { return std::auto_ptr<Derived>(new Derived); }
-
-int
-test01()
-{
- std::auto_ptr<Base> ptr2;
- ptr2 = new Base; // { dg-error "no match" }
- return 0;
-}
-
-int
-main()
-{
- test01();
- return 0;
-}
-// { dg-error "candidates" "" { target *-*-* } 223 }
-// { dg-error "std::auto_ptr" "" { target *-*-* } 353 }
+++ /dev/null
-// 2001-06-18 Benjamin Kosnik <bkoz@redhat.com>
-
-// Copyright (C) 2001, 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.2.2 Pairs
-
-#include <utility>
-#include <testsuite_hooks.h>
-
-class gnu_obj
-{
- int i;
-public:
- gnu_obj(int arg = 0): i(arg) { }
- bool operator==(const gnu_obj& rhs) const { return i == rhs.i; }
- bool operator<(const gnu_obj& rhs) const { return i < rhs.i; }
-};
-
-template<typename T>
- struct gnu_t
- {
- bool b;
- public:
- gnu_t(bool arg = 0): b(arg) { }
- bool operator==(const gnu_t& rhs) const { return b == rhs.b; }
- bool operator<(const gnu_t& rhs) const { return int(b) < int(rhs.b); }
- };
-
-
-// heterogeneous
-void test01()
-{
- bool test __attribute__((unused)) = true;
-
- std::pair<bool, long> p_bl_1(true, 433);
- std::pair<bool, long> p_bl_2 = std::make_pair(true, 433);
- VERIFY( p_bl_1 == p_bl_2 );
- VERIFY( !(p_bl_1 < p_bl_2) );
-
- std::pair<const char*, float> p_sf_1("total enlightenment", 433.00);
- std::pair<const char*, float> p_sf_2 = std::make_pair("total enlightenment",
- 433.00);
- VERIFY( p_sf_1 == p_sf_2 );
- VERIFY( !(p_sf_1 < p_sf_2) );
-
- std::pair<const char*, gnu_obj> p_sg_1("enlightenment", gnu_obj(5));
- std::pair<const char*, gnu_obj> p_sg_2 = std::make_pair("enlightenment",
- gnu_obj(5));
- VERIFY( p_sg_1 == p_sg_2 );
- VERIFY( !(p_sg_1 < p_sg_2) );
-
- std::pair<gnu_t<long>, gnu_obj> p_st_1(gnu_t<long>(false), gnu_obj(5));
- std::pair<gnu_t<long>, gnu_obj> p_st_2 = std::make_pair(gnu_t<long>(false),
- gnu_obj(5));
- VERIFY( p_st_1 == p_st_2 );
- VERIFY( !(p_st_1 < p_st_2) );
-}
-
-int main()
-{
- test01();
- return 0;
-}
+++ /dev/null
-// 2001-06-18 Benjamin Kosnik <bkoz@redhat.com>
-
-// Copyright (C) 2001, 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.2.2 Pairs
-
-#include <utility>
-#include <testsuite_hooks.h>
-
-class gnu_obj
-{
- int i;
-public:
- gnu_obj(int arg = 0): i(arg) { }
- bool operator==(const gnu_obj& rhs) const { return i == rhs.i; }
- bool operator<(const gnu_obj& rhs) const { return i < rhs.i; }
-};
-
-template<typename T>
- struct gnu_t
- {
- bool b;
- public:
- gnu_t(bool arg = 0): b(arg) { }
- bool operator==(const gnu_t& rhs) const { return b == rhs.b; }
- bool operator<(const gnu_t& rhs) const { return int(b) < int(rhs.b); }
- };
-
-// homogeneous
-void test02()
-{
- bool test __attribute__((unused)) = true;
-
- std::pair<bool, bool> p_bb_1(true, false);
- std::pair<bool, bool> p_bb_2 = std::make_pair(true, false);
- VERIFY( p_bb_1 == p_bb_2 );
- VERIFY( !(p_bb_1 < p_bb_2) );
-}
-
-int main()
-{
- test02();
- return 0;
-}
+++ /dev/null
-// 2001-06-18 Benjamin Kosnik <bkoz@redhat.com>
-
-// Copyright (C) 2001, 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.2.2 Pairs
-
-#include <utility>
-#include <testsuite_hooks.h>
-
-class gnu_obj
-{
- int i;
-public:
- gnu_obj(int arg = 0): i(arg) { }
- bool operator==(const gnu_obj& rhs) const { return i == rhs.i; }
- bool operator<(const gnu_obj& rhs) const { return i < rhs.i; }
-};
-
-template<typename T>
- struct gnu_t
- {
- bool b;
- public:
- gnu_t(bool arg = 0): b(arg) { }
- bool operator==(const gnu_t& rhs) const { return b == rhs.b; }
- bool operator<(const gnu_t& rhs) const { return int(b) < int(rhs.b); }
- };
-
-
-// const
-void test03()
-{
- bool test __attribute__((unused)) = true;
-
- const std::pair<bool, long> p_bl_1(true, 433);
- const std::pair<bool, long> p_bl_2 = std::make_pair(true, 433);
- VERIFY( p_bl_1 == p_bl_2 );
- VERIFY( !(p_bl_1 < p_bl_2) );
-
- const std::pair<const char*, float> p_sf_1("total enlightenment", 433.00);
- const std::pair<const char*, float> p_sf_2 =
- std::make_pair("total enlightenment", 433.00);
- VERIFY( p_sf_1 == p_sf_2 );
- VERIFY( !(p_sf_1 < p_sf_2) );
-
- const std::pair<const char*, gnu_obj> p_sg_1("enlightenment", gnu_obj(5));
- const std::pair<const char*, gnu_obj> p_sg_2 =
- std::make_pair("enlightenment", gnu_obj(5));
- VERIFY( p_sg_1 == p_sg_2 );
- VERIFY( !(p_sg_1 < p_sg_2) );
-
- const std::pair<gnu_t<long>, gnu_obj> p_st_1(gnu_t<long>(false), gnu_obj(5));
- const std::pair<gnu_t<long>, gnu_obj> p_st_2 =
- std::make_pair(gnu_t<long>(false), gnu_obj(5));
- VERIFY( p_st_1 == p_st_2 );
- VERIFY( !(p_st_1 < p_st_2) );
-}
-
-int main()
-{
- test03();
- return 0;
-}
+++ /dev/null
-// 2001-06-18 Benjamin Kosnik <bkoz@redhat.com>
-
-// Copyright (C) 2001, 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.2.2 Pairs
-
-#include <utility>
-#include <testsuite_hooks.h>
-
-class gnu_obj
-{
- int i;
-public:
- gnu_obj(int arg = 0): i(arg) { }
- bool operator==(const gnu_obj& rhs) const { return i == rhs.i; }
- bool operator<(const gnu_obj& rhs) const { return i < rhs.i; }
-};
-
-template<typename T>
- struct gnu_t
- {
- bool b;
- public:
- gnu_t(bool arg = 0): b(arg) { }
- bool operator==(const gnu_t& rhs) const { return b == rhs.b; }
- bool operator<(const gnu_t& rhs) const { return int(b) < int(rhs.b); }
- };
-
-// const&
-void test04()
-{
- bool test __attribute__((unused)) = true;
- const gnu_obj& obj1 = gnu_obj(5);
- const std::pair<const char*, gnu_obj> p_sg_1("enlightenment", obj1);
- const std::pair<const char*, gnu_obj> p_sg_2 =
- std::make_pair("enlightenment", obj1);
- VERIFY( p_sg_1 == p_sg_2 );
- VERIFY( !(p_sg_1 < p_sg_2) );
-
- const gnu_t<long>& tmpl1 = gnu_t<long>(false);
- const std::pair<gnu_t<long>, gnu_obj> p_st_1(tmpl1, obj1);
- const std::pair<gnu_t<long>, gnu_obj> p_st_2 = std::make_pair(tmpl1, obj1);
- VERIFY( p_st_1 == p_st_2 );
- VERIFY( !(p_st_1 < p_st_2) );
-}
-
-int main()
-{
- test04();
- return 0;
-}
+++ /dev/null
-;
-; gvmat32.asm -- Asm portion of the optimized longest_match for 32 bits x86
-; Copyright (C) 1995-1996 Jean-loup Gailly and Gilles Vollant.
-; File written by Gilles Vollant, by modifiying the longest_match
-; from Jean-loup Gailly in deflate.c
-; It need wmask == 0x7fff
-; (assembly code is faster with a fixed wmask)
-;
-; For Visual C++ 4.2 and ML 6.11c (version in directory \MASM611C of Win95 DDK)
-; I compile with : "ml /coff /Zi /c gvmat32.asm"
-;
-
-;uInt longest_match_7fff(s, cur_match)
-; deflate_state *s;
-; IPos cur_match; /* current match */
-
- NbStack equ 76
- cur_match equ dword ptr[esp+NbStack-0]
- str_s equ dword ptr[esp+NbStack-4]
-; 5 dword on top (ret,ebp,esi,edi,ebx)
- adrret equ dword ptr[esp+NbStack-8]
- pushebp equ dword ptr[esp+NbStack-12]
- pushedi equ dword ptr[esp+NbStack-16]
- pushesi equ dword ptr[esp+NbStack-20]
- pushebx equ dword ptr[esp+NbStack-24]
-
- chain_length equ dword ptr [esp+NbStack-28]
- limit equ dword ptr [esp+NbStack-32]
- best_len equ dword ptr [esp+NbStack-36]
- window equ dword ptr [esp+NbStack-40]
- prev equ dword ptr [esp+NbStack-44]
- scan_start equ word ptr [esp+NbStack-48]
- wmask equ dword ptr [esp+NbStack-52]
- match_start_ptr equ dword ptr [esp+NbStack-56]
- nice_match equ dword ptr [esp+NbStack-60]
- scan equ dword ptr [esp+NbStack-64]
-
- windowlen equ dword ptr [esp+NbStack-68]
- match_start equ dword ptr [esp+NbStack-72]
- strend equ dword ptr [esp+NbStack-76]
- NbStackAdd equ (NbStack-24)
-
- .386p
-
- name gvmatch
- .MODEL FLAT
-
-
-
-; all the +4 offsets are due to the addition of pending_buf_size (in zlib
-; in the deflate_state structure since the asm code was first written
-; (if you compile with zlib 1.0.4 or older, remove the +4).
-; Note : these value are good with a 8 bytes boundary pack structure
- dep_chain_length equ 70h+4
- dep_window equ 2ch+4
- dep_strstart equ 60h+4
- dep_prev_length equ 6ch+4
- dep_nice_match equ 84h+4
- dep_w_size equ 20h+4
- dep_prev equ 34h+4
- dep_w_mask equ 28h+4
- dep_good_match equ 80h+4
- dep_match_start equ 64h+4
- dep_lookahead equ 68h+4
-
-
-_TEXT segment
-
-IFDEF NOUNDERLINE
- public longest_match_7fff
-; public match_init
-ELSE
- public _longest_match_7fff
-; public _match_init
-ENDIF
-
- MAX_MATCH equ 258
- MIN_MATCH equ 3
- MIN_LOOKAHEAD equ (MAX_MATCH+MIN_MATCH+1)
-
-
-
-IFDEF NOUNDERLINE
-;match_init proc near
-; ret
-;match_init endp
-ELSE
-;_match_init proc near
-; ret
-;_match_init endp
-ENDIF
-
-
-IFDEF NOUNDERLINE
-longest_match_7fff proc near
-ELSE
-_longest_match_7fff proc near
-ENDIF
-
- mov edx,[esp+4]
-
-
-
- push ebp
- push edi
- push esi
- push ebx
-
- sub esp,NbStackAdd
-
-; initialize or check the variables used in match.asm.
- mov ebp,edx
-
-; chain_length = s->max_chain_length
-; if (prev_length>=good_match) chain_length >>= 2
- mov edx,[ebp+dep_chain_length]
- mov ebx,[ebp+dep_prev_length]
- cmp [ebp+dep_good_match],ebx
- ja noshr
- shr edx,2
-noshr:
-; we increment chain_length because in the asm, the --chain_lenght is in the beginning of the loop
- inc edx
- mov edi,[ebp+dep_nice_match]
- mov chain_length,edx
- mov eax,[ebp+dep_lookahead]
- cmp eax,edi
-; if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead;
- jae nolookaheadnicematch
- mov edi,eax
-nolookaheadnicematch:
-; best_len = s->prev_length
- mov best_len,ebx
-
-; window = s->window
- mov esi,[ebp+dep_window]
- mov ecx,[ebp+dep_strstart]
- mov window,esi
-
- mov nice_match,edi
-; scan = window + strstart
- add esi,ecx
- mov scan,esi
-; dx = *window
- mov dx,word ptr [esi]
-; bx = *(window+best_len-1)
- mov bx,word ptr [esi+ebx-1]
- add esi,MAX_MATCH-1
-; scan_start = *scan
- mov scan_start,dx
-; strend = scan + MAX_MATCH-1
- mov strend,esi
-; bx = scan_end = *(window+best_len-1)
-
-; IPos limit = s->strstart > (IPos)MAX_DIST(s) ?
-; s->strstart - (IPos)MAX_DIST(s) : NIL;
-
- mov esi,[ebp+dep_w_size]
- sub esi,MIN_LOOKAHEAD
-; here esi = MAX_DIST(s)
- sub ecx,esi
- ja nodist
- xor ecx,ecx
-nodist:
- mov limit,ecx
-
-; prev = s->prev
- mov edx,[ebp+dep_prev]
- mov prev,edx
-
-;
- mov edx,dword ptr [ebp+dep_match_start]
- mov bp,scan_start
- mov eax,cur_match
- mov match_start,edx
-
- mov edx,window
- mov edi,edx
- add edi,best_len
- mov esi,prev
- dec edi
-; windowlen = window + best_len -1
- mov windowlen,edi
-
- jmp beginloop2
- align 4
-
-; here, in the loop
-; eax = ax = cur_match
-; ecx = limit
-; bx = scan_end
-; bp = scan_start
-; edi = windowlen (window + best_len -1)
-; esi = prev
-
-
-;// here; chain_length <=16
-normalbeg0add16:
- add chain_length,16
- jz exitloop
-normalbeg0:
- cmp word ptr[edi+eax],bx
- je normalbeg2noroll
-rcontlabnoroll:
-; cur_match = prev[cur_match & wmask]
- and eax,7fffh
- mov ax,word ptr[esi+eax*2]
-; if cur_match > limit, go to exitloop
- cmp ecx,eax
- jnb exitloop
-; if --chain_length != 0, go to exitloop
- dec chain_length
- jnz normalbeg0
- jmp exitloop
-
-normalbeg2noroll:
-; if (scan_start==*(cur_match+window)) goto normalbeg2
- cmp bp,word ptr[edx+eax]
- jne rcontlabnoroll
- jmp normalbeg2
-
-contloop3:
- mov edi,windowlen
-
-; cur_match = prev[cur_match & wmask]
- and eax,7fffh
- mov ax,word ptr[esi+eax*2]
-; if cur_match > limit, go to exitloop
- cmp ecx,eax
-jnbexitloopshort1:
- jnb exitloop
-; if --chain_length != 0, go to exitloop
-
-
-; begin the main loop
-beginloop2:
- sub chain_length,16+1
-; if chain_length <=16, don't use the unrolled loop
- jna normalbeg0add16
-
-do16:
- cmp word ptr[edi+eax],bx
- je normalbeg2dc0
-
-maccn MACRO lab
- and eax,7fffh
- mov ax,word ptr[esi+eax*2]
- cmp ecx,eax
- jnb exitloop
- cmp word ptr[edi+eax],bx
- je lab
- ENDM
-
-rcontloop0:
- maccn normalbeg2dc1
-
-rcontloop1:
- maccn normalbeg2dc2
-
-rcontloop2:
- maccn normalbeg2dc3
-
-rcontloop3:
- maccn normalbeg2dc4
-
-rcontloop4:
- maccn normalbeg2dc5
-
-rcontloop5:
- maccn normalbeg2dc6
-
-rcontloop6:
- maccn normalbeg2dc7
-
-rcontloop7:
- maccn normalbeg2dc8
-
-rcontloop8:
- maccn normalbeg2dc9
-
-rcontloop9:
- maccn normalbeg2dc10
-
-rcontloop10:
- maccn short normalbeg2dc11
-
-rcontloop11:
- maccn short normalbeg2dc12
-
-rcontloop12:
- maccn short normalbeg2dc13
-
-rcontloop13:
- maccn short normalbeg2dc14
-
-rcontloop14:
- maccn short normalbeg2dc15
-
-rcontloop15:
- and eax,7fffh
- mov ax,word ptr[esi+eax*2]
- cmp ecx,eax
- jnb exitloop
-
- sub chain_length,16
- ja do16
- jmp normalbeg0add16
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-normbeg MACRO rcontlab,valsub
-; if we are here, we know that *(match+best_len-1) == scan_end
- cmp bp,word ptr[edx+eax]
-; if (match != scan_start) goto rcontlab
- jne rcontlab
-; calculate the good chain_length, and we'll compare scan and match string
- add chain_length,16-valsub
- jmp iseq
- ENDM
-
-
-normalbeg2dc11:
- normbeg rcontloop11,11
-
-normalbeg2dc12:
- normbeg short rcontloop12,12
-
-normalbeg2dc13:
- normbeg short rcontloop13,13
-
-normalbeg2dc14:
- normbeg short rcontloop14,14
-
-normalbeg2dc15:
- normbeg short rcontloop15,15
-
-normalbeg2dc10:
- normbeg rcontloop10,10
-
-normalbeg2dc9:
- normbeg rcontloop9,9
-
-normalbeg2dc8:
- normbeg rcontloop8,8
-
-normalbeg2dc7:
- normbeg rcontloop7,7
-
-normalbeg2dc6:
- normbeg rcontloop6,6
-
-normalbeg2dc5:
- normbeg rcontloop5,5
-
-normalbeg2dc4:
- normbeg rcontloop4,4
-
-normalbeg2dc3:
- normbeg rcontloop3,3
-
-normalbeg2dc2:
- normbeg rcontloop2,2
-
-normalbeg2dc1:
- normbeg rcontloop1,1
-
-normalbeg2dc0:
- normbeg rcontloop0,0
-
-
-; we go in normalbeg2 because *(ushf*)(match+best_len-1) == scan_end
-
-normalbeg2:
- mov edi,window
-
- cmp bp,word ptr[edi+eax]
- jne contloop3 ; if *(ushf*)match != scan_start, continue
-
-iseq:
-; if we are here, we know that *(match+best_len-1) == scan_end
-; and (match == scan_start)
-
- mov edi,edx
- mov esi,scan ; esi = scan
- add edi,eax ; edi = window + cur_match = match
-
- mov edx,[esi+3] ; compare manually dword at match+3
- xor edx,[edi+3] ; and scan +3
-
- jz begincompare ; if equal, go to long compare
-
-; we will determine the unmatch byte and calculate len (in esi)
- or dl,dl
- je eq1rr
- mov esi,3
- jmp trfinval
-eq1rr:
- or dx,dx
- je eq1
-
- mov esi,4
- jmp trfinval
-eq1:
- and edx,0ffffffh
- jz eq11
- mov esi,5
- jmp trfinval
-eq11:
- mov esi,6
- jmp trfinval
-
-begincompare:
- ; here we now scan and match begin same
- add edi,6
- add esi,6
- mov ecx,(MAX_MATCH-(2+4))/4 ; scan for at most MAX_MATCH bytes
- repe cmpsd ; loop until mismatch
-
- je trfin ; go to trfin if not unmatch
-; we determine the unmatch byte
- sub esi,4
- mov edx,[edi-4]
- xor edx,[esi]
-
- or dl,dl
- jnz trfin
- inc esi
-
- or dx,dx
- jnz trfin
- inc esi
-
- and edx,0ffffffh
- jnz trfin
- inc esi
-
-trfin:
- sub esi,scan ; esi = len
-trfinval:
-; here we have finised compare, and esi contain len of equal string
- cmp esi,best_len ; if len > best_len, go newbestlen
- ja short newbestlen
-; now we restore edx, ecx and esi, for the big loop
- mov esi,prev
- mov ecx,limit
- mov edx,window
- jmp contloop3
-
-newbestlen:
- mov best_len,esi ; len become best_len
-
- mov match_start,eax ; save new position as match_start
- cmp esi,nice_match ; if best_len >= nice_match, exit
- jae exitloop
- mov ecx,scan
- mov edx,window ; restore edx=window
- add ecx,esi
- add esi,edx
-
- dec esi
- mov windowlen,esi ; windowlen = window + best_len-1
- mov bx,[ecx-1] ; bx = *(scan+best_len-1) = scan_end
-
-; now we restore ecx and esi, for the big loop :
- mov esi,prev
- mov ecx,limit
- jmp contloop3
-
-exitloop:
-; exit : s->match_start=match_start
- mov ebx,match_start
- mov ebp,str_s
- mov ecx,best_len
- mov dword ptr [ebp+dep_match_start],ebx
- mov eax,dword ptr [ebp+dep_lookahead]
- cmp ecx,eax
- ja minexlo
- mov eax,ecx
-minexlo:
-; return min(best_len,s->lookahead)
-
-; restore stack and register ebx,esi,edi,ebp
- add esp,NbStackAdd
-
- pop ebx
- pop esi
- pop edi
- pop ebp
- ret
-InfoAuthor:
-; please don't remove this string !
-; Your are free use gvmat32 in any fre or commercial apps if you don't remove the string in the binary!
- db 0dh,0ah,"GVMat32 optimised assembly code written 1996-98 by Gilles Vollant",0dh,0ah
-
-
-
-IFDEF NOUNDERLINE
-longest_match_7fff endp
-ELSE
-_longest_match_7fff endp
-ENDIF
-
-
-IFDEF NOUNDERLINE
-cpudetect32 proc near
-ELSE
-_cpudetect32 proc near
-ENDIF
-
-
- pushfd ; push original EFLAGS
- pop eax ; get original EFLAGS
- mov ecx, eax ; save original EFLAGS
- xor eax, 40000h ; flip AC bit in EFLAGS
- push eax ; save new EFLAGS value on stack
- popfd ; replace current EFLAGS value
- pushfd ; get new EFLAGS
- pop eax ; store new EFLAGS in EAX
- xor eax, ecx ; can\92t toggle AC bit, processor=80386
- jz end_cpu_is_386 ; jump if 80386 processor
- push ecx
- popfd ; restore AC bit in EFLAGS first
-
- pushfd
- pushfd
- pop ecx
-
- mov eax, ecx ; get original EFLAGS
- xor eax, 200000h ; flip ID bit in EFLAGS
- push eax ; save new EFLAGS value on stack
- popfd ; replace current EFLAGS value
- pushfd ; get new EFLAGS
- pop eax ; store new EFLAGS in EAX
- popfd ; restore original EFLAGS
- xor eax, ecx ; can\92t toggle ID bit,
- je is_old_486 ; processor=old
-
- mov eax,1
- db 0fh,0a2h ;CPUID
-
-exitcpudetect:
- ret
-
-end_cpu_is_386:
- mov eax,0300h
- jmp exitcpudetect
-
-is_old_486:
- mov eax,0400h
- jmp exitcpudetect
-
-IFDEF NOUNDERLINE
-cpudetect32 endp
-ELSE
-_cpudetect32 endp
-ENDIF
-
-_TEXT ends
-end
+++ /dev/null
-/* gvmat32.c -- C portion of the optimized longest_match for 32 bits x86
- * Copyright (C) 1995-1996 Jean-loup Gailly and Gilles Vollant.
- * File written by Gilles Vollant, by modifiying the longest_match
- * from Jean-loup Gailly in deflate.c
- * it prepare all parameters and call the assembly longest_match_gvasm
- * longest_match execute standard C code is wmask != 0x7fff
- * (assembly code is faster with a fixed wmask)
- *
- */
-
-#include "deflate.h"
-
-#undef FAR
-#include <windows.h>
-
-#ifdef ASMV
-#define NIL 0
-
-#define UNALIGNED_OK
-
-
-/* if your C compiler don't add underline before function name,
- define ADD_UNDERLINE_ASMFUNC */
-#ifdef ADD_UNDERLINE_ASMFUNC
-#define longest_match_7fff _longest_match_7fff
-#endif
-
-
-
-void match_init()
-{
-}
-
-unsigned long cpudetect32();
-
-uInt longest_match_c(
- deflate_state *s,
- IPos cur_match); /* current match */
-
-
-uInt longest_match_7fff(
- deflate_state *s,
- IPos cur_match); /* current match */
-
-uInt longest_match(
- deflate_state *s,
- IPos cur_match) /* current match */
-{
- static uInt iIsPPro=2;
-
- if ((s->w_mask == 0x7fff) && (iIsPPro==0))
- return longest_match_7fff(s,cur_match);
-
- if (iIsPPro==2)
- iIsPPro = (((cpudetect32()/0x100)&0xf)>=6) ? 1 : 0;
-
- return longest_match_c(s,cur_match);
-}
-
-
-
-uInt longest_match_c(s, cur_match)
- deflate_state *s;
- IPos cur_match; /* current match */
-{
- unsigned chain_length = s->max_chain_length;/* max hash chain length */
- register Bytef *scan = s->window + s->strstart; /* current string */
- register Bytef *match; /* matched string */
- register int len; /* length of current match */
- int best_len = s->prev_length; /* best match length so far */
- int nice_match = s->nice_match; /* stop if match long enough */
- IPos limit = s->strstart > (IPos)MAX_DIST(s) ?
- s->strstart - (IPos)MAX_DIST(s) : NIL;
- /* Stop when cur_match becomes <= limit. To simplify the code,
- * we prevent matches with the string of window index 0.
- */
- Posf *prev = s->prev;
- uInt wmask = s->w_mask;
-
-#ifdef UNALIGNED_OK
- /* Compare two bytes at a time. Note: this is not always beneficial.
- * Try with and without -DUNALIGNED_OK to check.
- */
- register Bytef *strend = s->window + s->strstart + MAX_MATCH - 1;
- register ush scan_start = *(ushf*)scan;
- register ush scan_end = *(ushf*)(scan+best_len-1);
-#else
- register Bytef *strend = s->window + s->strstart + MAX_MATCH;
- register Byte scan_end1 = scan[best_len-1];
- register Byte scan_end = scan[best_len];
-#endif
-
- /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
- * It is easy to get rid of this optimization if necessary.
- */
- Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever");
-
- /* Do not waste too much time if we already have a good match: */
- if (s->prev_length >= s->good_match) {
- chain_length >>= 2;
- }
- /* Do not look for matches beyond the end of the input. This is necessary
- * to make deflate deterministic.
- */
- if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead;
-
- Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead");
-
- do {
- Assert(cur_match < s->strstart, "no future");
- match = s->window + cur_match;
-
- /* Skip to next match if the match length cannot increase
- * or if the match length is less than 2:
- */
-#if (defined(UNALIGNED_OK) && MAX_MATCH == 258)
- /* This code assumes sizeof(unsigned short) == 2. Do not use
- * UNALIGNED_OK if your compiler uses a different size.
- */
- if (*(ushf*)(match+best_len-1) != scan_end ||
- *(ushf*)match != scan_start) continue;
-
- /* It is not necessary to compare scan[2] and match[2] since they are
- * always equal when the other bytes match, given that the hash keys
- * are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at
- * strstart+3, +5, ... up to strstart+257. We check for insufficient
- * lookahead only every 4th comparison; the 128th check will be made
- * at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is
- * necessary to put more guard bytes at the end of the window, or
- * to check more often for insufficient lookahead.
- */
- Assert(scan[2] == match[2], "scan[2]?");
- scan++, match++;
- do {
- } while (*(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
- *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
- *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
- *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
- scan < strend);
- /* The funny "do {}" generates better code on most compilers */
-
- /* Here, scan <= window+strstart+257 */
- Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
- if (*scan == *match) scan++;
-
- len = (MAX_MATCH - 1) - (int)(strend-scan);
- scan = strend - (MAX_MATCH-1);
-
-#else /* UNALIGNED_OK */
-
- if (match[best_len] != scan_end ||
- match[best_len-1] != scan_end1 ||
- *match != *scan ||
- *++match != scan[1]) continue;
-
- /* The check at best_len-1 can be removed because it will be made
- * again later. (This heuristic is not always a win.)
- * It is not necessary to compare scan[2] and match[2] since they
- * are always equal when the other bytes match, given that
- * the hash keys are equal and that HASH_BITS >= 8.
- */
- scan += 2, match++;
- Assert(*scan == *match, "match[2]?");
-
- /* We check for insufficient lookahead only every 8th comparison;
- * the 256th check will be made at strstart+258.
- */
- do {
- } while (*++scan == *++match && *++scan == *++match &&
- *++scan == *++match && *++scan == *++match &&
- *++scan == *++match && *++scan == *++match &&
- *++scan == *++match && *++scan == *++match &&
- scan < strend);
-
- Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
-
- len = MAX_MATCH - (int)(strend - scan);
- scan = strend - MAX_MATCH;
-
-#endif /* UNALIGNED_OK */
-
- if (len > best_len) {
- s->match_start = cur_match;
- best_len = len;
- if (len >= nice_match) break;
-#ifdef UNALIGNED_OK
- scan_end = *(ushf*)(scan+best_len-1);
-#else
- scan_end1 = scan[best_len-1];
- scan_end = scan[best_len];
-#endif
- }
- } while ((cur_match = prev[cur_match & wmask]) > limit
- && --chain_length != 0);
-
- if ((uInt)best_len <= s->lookahead) return (uInt)best_len;
- return s->lookahead;
-}
-
-#endif /* ASMV */
+++ /dev/null
-c:\masm611\bin\ml /coff /Zi /c /Flgvmat32.lst gvmat32.asm
+++ /dev/null
-LIBRARY "zlib"
-
-DESCRIPTION '"""zlib data compression library"""'
-
-
-VERSION 1.11
-
-
-HEAPSIZE 1048576,8192
-
-EXPORTS
- adler32 @1
- compress @2
- crc32 @3
- deflate @4
- deflateCopy @5
- deflateEnd @6
- deflateInit2_ @7
- deflateInit_ @8
- deflateParams @9
- deflateReset @10
- deflateSetDictionary @11
- gzclose @12
- gzdopen @13
- gzerror @14
- gzflush @15
- gzopen @16
- gzread @17
- gzwrite @18
- inflate @19
- inflateEnd @20
- inflateInit2_ @21
- inflateInit_ @22
- inflateReset @23
- inflateSetDictionary @24
- inflateSync @25
- uncompress @26
- zlibVersion @27
- gzprintf @28
- gzputc @29
- gzgetc @30
- gzseek @31
- gzrewind @32
- gztell @33
- gzeof @34
- gzsetparams @35
- zError @36
- inflateSyncPoint @37
- get_crc_table @38
- compress2 @39
- gzputs @40
- gzgets @41
-
- unzOpen @61
- unzClose @62
- unzGetGlobalInfo @63
- unzGetCurrentFileInfo @64
- unzGoToFirstFile @65
- unzGoToNextFile @66
- unzOpenCurrentFile @67
- unzReadCurrentFile @68
- unztell @70
- unzeof @71
- unzCloseCurrentFile @72
- unzGetGlobalComment @73
- unzStringFileNameCompare @74
- unzLocateFile @75
- unzGetLocalExtrafield @76
-
- zipOpen @80
- zipOpenNewFileInZip @81
- zipWriteInFileInZip @82
- zipCloseFileInZip @83
- zipClose @84
+++ /dev/null
-# Microsoft Developer Studio Project File - Name="zlibvc" - Package Owner=<4>
-# Microsoft Developer Studio Generated Build File, Format Version 5.00
-# ** DO NOT EDIT **
-
-# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102
-# TARGTYPE "Win32 (ALPHA) Dynamic-Link Library" 0x0602
-
-CFG=zlibvc - Win32 Release
-!MESSAGE This is not a valid makefile. To build this project using NMAKE,
-!MESSAGE use the Export Makefile command and run
-!MESSAGE
-!MESSAGE NMAKE /f "zlibvc.mak".
-!MESSAGE
-!MESSAGE You can specify a configuration when running NMAKE
-!MESSAGE by defining the macro CFG on the command line. For example:
-!MESSAGE
-!MESSAGE NMAKE /f "zlibvc.mak" CFG="zlibvc - Win32 Release"
-!MESSAGE
-!MESSAGE Possible choices for configuration are:
-!MESSAGE
-!MESSAGE "zlibvc - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library")
-!MESSAGE "zlibvc - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library")
-!MESSAGE "zlibvc - Win32 ReleaseAxp" (based on\
- "Win32 (ALPHA) Dynamic-Link Library")
-!MESSAGE "zlibvc - Win32 ReleaseWithoutAsm" (based on\
- "Win32 (x86) Dynamic-Link Library")
-!MESSAGE "zlibvc - Win32 ReleaseWithoutCrtdll" (based on\
- "Win32 (x86) Dynamic-Link Library")
-!MESSAGE
-
-# Begin Project
-# PROP Scc_ProjName ""
-# PROP Scc_LocalPath ""
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-# PROP BASE Use_MFC 0
-# PROP BASE Use_Debug_Libraries 0
-# PROP BASE Output_Dir ".\Release"
-# PROP BASE Intermediate_Dir ".\Release"
-# PROP BASE Target_Dir ""
-# PROP Use_MFC 0
-# PROP Use_Debug_Libraries 0
-# PROP Output_Dir ".\Release"
-# PROP Intermediate_Dir ".\Release"
-# PROP Ignore_Export_Lib 0
-# PROP Target_Dir ""
-CPP=cl.exe
-# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /YX /c
-# ADD CPP /nologo /MT /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_WINDLL" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /D "DYNAMIC_CRC_TABLE" /D "ASMV" /FAcs /FR /FD /c
-# SUBTRACT CPP /YX
-MTL=midl.exe
-# ADD BASE MTL /nologo /D "NDEBUG" /win32
-# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
-RSC=rc.exe
-# ADD BASE RSC /l 0x40c /d "NDEBUG"
-# ADD RSC /l 0x40c /d "NDEBUG"
-BSC32=bscmake.exe
-# ADD BASE BSC32 /nologo
-# ADD BSC32 /nologo
-LINK32=link.exe
-# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /machine:I386
-# ADD LINK32 gvmat32.obj kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib crtdll.lib /nologo /subsystem:windows /dll /map /machine:I386 /nodefaultlib /out:".\Release\zlib.dll"
-# SUBTRACT LINK32 /pdb:none
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-# PROP BASE Use_MFC 0
-# PROP BASE Use_Debug_Libraries 1
-# PROP BASE Output_Dir ".\Debug"
-# PROP BASE Intermediate_Dir ".\Debug"
-# PROP BASE Target_Dir ""
-# PROP Use_MFC 0
-# PROP Use_Debug_Libraries 1
-# PROP Output_Dir ".\Debug"
-# PROP Intermediate_Dir ".\Debug"
-# PROP Target_Dir ""
-CPP=cl.exe
-# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /YX /c
-# ADD CPP /nologo /MTd /W3 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "_WINDLL" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /FD /c
-# SUBTRACT CPP /YX
-MTL=midl.exe
-# ADD BASE MTL /nologo /D "_DEBUG" /win32
-# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32
-RSC=rc.exe
-# ADD BASE RSC /l 0x40c /d "_DEBUG"
-# ADD RSC /l 0x40c /d "_DEBUG"
-BSC32=bscmake.exe
-# ADD BASE BSC32 /nologo
-# ADD BSC32 /nologo
-LINK32=link.exe
-# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /debug /machine:I386
-# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /subsystem:windows /dll /debug /machine:I386 /out:".\Debug\zlib.dll"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-# PROP BASE Use_MFC 0
-# PROP BASE Use_Debug_Libraries 0
-# PROP BASE Output_Dir "zlibvc__"
-# PROP BASE Intermediate_Dir "zlibvc__"
-# PROP BASE Ignore_Export_Lib 0
-# PROP BASE Target_Dir ""
-# PROP Use_MFC 0
-# PROP Use_Debug_Libraries 0
-# PROP Output_Dir "zlibvc__"
-# PROP Intermediate_Dir "zlibvc__"
-# PROP Ignore_Export_Lib 0
-# PROP Target_Dir ""
-MTL=midl.exe
-# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
-# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
-CPP=cl.exe
-# ADD BASE CPP /nologo /MT /Gt0 /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /D "DYNAMIC_CRC_TABLE" /FAcs /FR /YX /FD /c
-# ADD CPP /nologo /MT /Gt0 /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /D "DYNAMIC_CRC_TABLE" /FAcs /FR /FD /c
-# SUBTRACT CPP /YX
-RSC=rc.exe
-# ADD BASE RSC /l 0x40c /d "NDEBUG"
-# ADD RSC /l 0x40c /d "NDEBUG"
-BSC32=bscmake.exe
-# ADD BASE BSC32 /nologo
-# ADD BSC32 /nologo
-LINK32=link.exe
-# ADD BASE LINK32 crtdll.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /subsystem:windows /dll /map /machine:ALPHA /nodefaultlib /out:".\Release\zlib.dll"
-# SUBTRACT BASE LINK32 /pdb:none
-# ADD LINK32 crtdll.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /subsystem:windows /dll /map /machine:ALPHA /nodefaultlib /out:"zlibvc__\zlib.dll"
-# SUBTRACT LINK32 /pdb:none
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-# PROP BASE Use_MFC 0
-# PROP BASE Use_Debug_Libraries 0
-# PROP BASE Output_Dir "zlibvc_0"
-# PROP BASE Intermediate_Dir "zlibvc_0"
-# PROP BASE Ignore_Export_Lib 0
-# PROP BASE Target_Dir ""
-# PROP Use_MFC 0
-# PROP Use_Debug_Libraries 0
-# PROP Output_Dir "zlibvc_0"
-# PROP Intermediate_Dir "zlibvc_0"
-# PROP Ignore_Export_Lib 0
-# PROP Target_Dir ""
-CPP=cl.exe
-# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_WINDLL" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /D "DYNAMIC_CRC_TABLE" /FAcs /FR /YX /FD /c
-# ADD CPP /nologo /MT /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_WINDLL" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /D "DYNAMIC_CRC_TABLE" /FAcs /FR /FD /c
-# SUBTRACT CPP /YX
-MTL=midl.exe
-# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
-# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
-RSC=rc.exe
-# ADD BASE RSC /l 0x40c /d "NDEBUG"
-# ADD RSC /l 0x40c /d "NDEBUG"
-BSC32=bscmake.exe
-# ADD BASE BSC32 /nologo
-# ADD BSC32 /nologo
-LINK32=link.exe
-# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib crtdll.lib /nologo /subsystem:windows /dll /map /machine:I386 /nodefaultlib /out:".\Release\zlib.dll"
-# SUBTRACT BASE LINK32 /pdb:none
-# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib crtdll.lib /nologo /subsystem:windows /dll /map /machine:I386 /nodefaultlib /out:".\zlibvc_0\zlib.dll"
-# SUBTRACT LINK32 /pdb:none
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-# PROP BASE Use_MFC 0
-# PROP BASE Use_Debug_Libraries 0
-# PROP BASE Output_Dir "zlibvc_1"
-# PROP BASE Intermediate_Dir "zlibvc_1"
-# PROP BASE Ignore_Export_Lib 0
-# PROP BASE Target_Dir ""
-# PROP Use_MFC 0
-# PROP Use_Debug_Libraries 0
-# PROP Output_Dir "zlibvc_1"
-# PROP Intermediate_Dir "zlibvc_1"
-# PROP Ignore_Export_Lib 0
-# PROP Target_Dir ""
-CPP=cl.exe
-# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_WINDLL" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /D "DYNAMIC_CRC_TABLE" /D "ASMV" /FAcs /FR /YX /FD /c
-# ADD CPP /nologo /MT /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_WINDLL" /D "_WIN32" /D "BUILD_ZLIBDLL" /D "ZLIB_DLL" /D "DYNAMIC_CRC_TABLE" /D "ASMV" /FAcs /FR /FD /c
-# SUBTRACT CPP /YX
-MTL=midl.exe
-# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
-# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
-RSC=rc.exe
-# ADD BASE RSC /l 0x40c /d "NDEBUG"
-# ADD RSC /l 0x40c /d "NDEBUG"
-BSC32=bscmake.exe
-# ADD BASE BSC32 /nologo
-# ADD BSC32 /nologo
-LINK32=link.exe
-# ADD BASE LINK32 gvmat32.obj kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib crtdll.lib /nologo /subsystem:windows /dll /map /machine:I386 /nodefaultlib /out:".\Release\zlib.dll"
-# SUBTRACT BASE LINK32 /pdb:none
-# ADD LINK32 gvmat32.obj kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib crtdll.lib /nologo /subsystem:windows /dll /map /machine:I386 /nodefaultlib /out:".\zlibvc_1\zlib.dll"
-# SUBTRACT LINK32 /pdb:none
-
-!ENDIF
-
-# Begin Target
-
-# Name "zlibvc - Win32 Release"
-# Name "zlibvc - Win32 Debug"
-# Name "zlibvc - Win32 ReleaseAxp"
-# Name "zlibvc - Win32 ReleaseWithoutAsm"
-# Name "zlibvc - Win32 ReleaseWithoutCrtdll"
-# Begin Group "Source Files"
-
-# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;hpj;bat;for;f90"
-# Begin Source File
-
-SOURCE=.\adler32.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_ADLER=\
- ".\zconf.h"\
- ".\zlib.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\compress.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_COMPR=\
- ".\zconf.h"\
- ".\zlib.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\crc32.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_CRC32=\
- ".\zconf.h"\
- ".\zlib.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\deflate.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_DEFLA=\
- ".\deflate.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\gvmat32c.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\gzio.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_GZIO_=\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\infblock.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_INFBL=\
- ".\infblock.h"\
- ".\infcodes.h"\
- ".\inftrees.h"\
- ".\infutil.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\infcodes.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_INFCO=\
- ".\infblock.h"\
- ".\infcodes.h"\
- ".\inffast.h"\
- ".\inftrees.h"\
- ".\infutil.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\inffast.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_INFFA=\
- ".\infblock.h"\
- ".\infcodes.h"\
- ".\inffast.h"\
- ".\inftrees.h"\
- ".\infutil.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\inflate.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_INFLA=\
- ".\infblock.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\inftrees.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_INFTR=\
- ".\inftrees.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\infutil.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_INFUT=\
- ".\infblock.h"\
- ".\infcodes.h"\
- ".\inftrees.h"\
- ".\infutil.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\trees.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_TREES=\
- ".\deflate.h"\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\uncompr.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_UNCOM=\
- ".\zconf.h"\
- ".\zlib.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\unzip.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\zip.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\zlib.rc
-# End Source File
-# Begin Source File
-
-SOURCE=.\zlibvc.def
-# End Source File
-# Begin Source File
-
-SOURCE=.\zutil.c
-
-!IF "$(CFG)" == "zlibvc - Win32 Release"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 Debug"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseAxp"
-
-DEP_CPP_ZUTIL=\
- ".\zconf.h"\
- ".\zlib.h"\
- ".\zutil.h"\
-
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutAsm"
-
-!ELSEIF "$(CFG)" == "zlibvc - Win32 ReleaseWithoutCrtdll"
-
-!ENDIF
-
-# End Source File
-# End Group
-# Begin Group "Header Files"
-
-# PROP Default_Filter "h;hpp;hxx;hm;inl;fi;fd"
-# Begin Source File
-
-SOURCE=.\deflate.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\infblock.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\infcodes.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\inffast.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\inftrees.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\infutil.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\zconf.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\zlib.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\zutil.h
-# End Source File
-# End Group
-# Begin Group "Resource Files"
-
-# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;cnt;rtf;gif;jpg;jpeg;jpe"
-# End Group
-# End Target
-# End Project
+++ /dev/null
-Microsoft Developer Studio Workspace File, Format Version 5.00
-# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
-
-###############################################################################
-
-Project: "zlibstat"=.\zlibstat.dsp - Package Owner=<4>
-
-Package=<5>
-{{{
-}}}
-
-Package=<4>
-{{{
-}}}
-
-###############################################################################
-
-Project: "zlibvc"=.\zlibvc.dsp - Package Owner=<4>
-
-Package=<5>
-{{{
-}}}
-
-Package=<4>
-{{{
-}}}
-
-###############################################################################
-
-Global:
-
-Package=<5>
-{{{
-}}}
-
-Package=<3>
-{{{
-}}}
-
-###############################################################################
-
+++ /dev/null
-# ---------------------------------------------------------------------------
-!if !$d(BCB)
-BCB = $(MAKEDIR)\..
-!endif
-
-# ---------------------------------------------------------------------------
-# IDE SECTION
-# ---------------------------------------------------------------------------
-# The following section of the project makefile is managed by the BCB IDE.
-# It is recommended to use the IDE to change any of the values in this
-# section.
-# ---------------------------------------------------------------------------
-
-VERSION = BCB.03
-# ---------------------------------------------------------------------------
-PROJECT = d_zlib.lib
-OBJFILES = d_zlib.obj adler32.obj deflate.obj infblock.obj infcodes.obj inffast.obj \
- inflate.obj inftrees.obj infutil.obj trees.obj
-RESFILES =
-RESDEPEN = $(RESFILES)
-LIBFILES =
-LIBRARIES = VCL35.lib
-SPARELIBS = VCL35.lib
-DEFFILE =
-PACKAGES = VCLX35.bpi VCL35.bpi VCLDB35.bpi VCLDBX35.bpi ibsmp35.bpi bcbsmp35.bpi \
- dclocx35.bpi QRPT35.bpi TEEUI35.bpi TEEDB35.bpi TEE35.bpi DSS35.bpi \
- NMFAST35.bpi INETDB35.bpi INET35.bpi VCLMID35.bpi
-# ---------------------------------------------------------------------------
-PATHCPP = .;
-PATHASM = .;
-PATHPAS = .;
-PATHRC = .;
-DEBUGLIBPATH = $(BCB)\lib\debug
-RELEASELIBPATH = $(BCB)\lib\release
-# ---------------------------------------------------------------------------
-CFLAG1 = -O2 -Ve -d -k- -vi
-CFLAG2 = -I$(BCB)\include;$(BCB)\include\vcl -H=$(BCB)\lib\vcl35.csm
-CFLAG3 = -ff -pr -5
-PFLAGS = -U;$(DEBUGLIBPATH) -I$(BCB)\include;$(BCB)\include\vcl -H -W -$I- -v -JPHN -M
-RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl
-AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn
-LFLAGS =
-IFLAGS = -g -Gn
-# ---------------------------------------------------------------------------
-ALLOBJ = c0w32.obj $(OBJFILES)
-ALLRES = $(RESFILES)
-ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mt.lib
-# ---------------------------------------------------------------------------
-!!ifdef IDEOPTIONS
-
-[Version Info]
-IncludeVerInfo=0
-AutoIncBuild=0
-MajorVer=1
-MinorVer=0
-Release=0
-Build=0
-Debug=0
-PreRelease=0
-Special=0
-Private=0
-DLL=0
-Locale=1040
-CodePage=1252
-
-[Version Info Keys]
-CompanyName=
-FileDescription=
-FileVersion=1.0.0.0
-InternalName=
-LegalCopyright=
-LegalTrademarks=
-OriginalFilename=
-ProductName=
-ProductVersion=1.0.0.0
-Comments=
-
-[HistoryLists\hlIncludePath]
-Count=2
-Item0=$(BCB)\include
-Item1=$(BCB)\include;$(BCB)\include\vcl
-
-[HistoryLists\hlLibraryPath]
-Count=1
-Item0=$(BCB)\lib\obj;$(BCB)\lib
-
-[HistoryLists\hlDebugSourcePath]
-Count=1
-Item0=$(BCB)\source\vcl
-
-[Debugging]
-DebugSourceDirs=
-
-[Parameters]
-RunParams=
-HostApplication=
-
-!endif
-
- ---------------------------------------------------------------------------
-# MAKE SECTION
-# ---------------------------------------------------------------------------
-# This section of the project file is not used by the BCB IDE. It is for
-# the benefit of building from the command-line using the MAKE utility.
-# ---------------------------------------------------------------------------
-
-.autodepend
-# ---------------------------------------------------------------------------
-!if !$d(BCC32)
-BCC32 = bcc32
-!endif
-
-!if !$d(DCC32)
-DCC32 = dcc32
-!endif
-
-!if !$d(TASM32)
-TASM32 = tasm32
-!endif
-
-!if !$d(LINKER)
-LINKER = TLib
-!endif
-
-!if !$d(BRCC32)
-BRCC32 = brcc32
-!endif
-# ---------------------------------------------------------------------------
-!if $d(PATHCPP)
-.PATH.CPP = $(PATHCPP)
-.PATH.C = $(PATHCPP)
-!endif
-
-!if $d(PATHPAS)
-.PATH.PAS = $(PATHPAS)
-!endif
-
-!if $d(PATHASM)
-.PATH.ASM = $(PATHASM)
-!endif
-
-!if $d(PATHRC)
-.PATH.RC = $(PATHRC)
-!endif
-# ---------------------------------------------------------------------------
-!ifdef IDEOPTIONS
-
-[Version Info]
-IncludeVerInfo=0
-AutoIncBuild=0
-MajorVer=1
-MinorVer=0
-Release=0
-Build=0
-Debug=0
-PreRelease=0
-Special=0
-Private=0
-DLL=0
-Locale=1040
-CodePage=1252
-
-[Version Info Keys]
-CompanyName=
-FileDescription=
-FileVersion=1.0.0.0
-InternalName=
-LegalCopyright=
-LegalTrademarks=
-OriginalFilename=
-ProductName=
-ProductVersion=1.0.0.0
-Comments=
-
-[HistoryLists\hlIncludePath]
-Count=2
-Item0=$(BCB)\include;$(BCB)\include\vcl
-Item1=$(BCB)\include
-
-[HistoryLists\hlLibraryPath]
-Count=1
-Item0=$(BCB)\lib\obj;$(BCB)\lib
-
-[HistoryLists\hlDebugSourcePath]
-Count=1
-Item0=$(BCB)\source\vcl
-
-[Debugging]
-DebugSourceDirs=
-
-[Parameters]
-RunParams=
-HostApplication=
-
-!endif
-
-$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE)
- $(BCB)\BIN\$(LINKER) @&&!
- $(LFLAGS) $(IFLAGS) +
- $(ALLOBJ), +
- $(PROJECT),, +
- $(ALLLIB), +
- $(DEFFILE), +
- $(ALLRES)
-!
-# ---------------------------------------------------------------------------
-.pas.hpp:
- $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< }
-
-.pas.obj:
- $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< }
-
-.cpp.obj:
- $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< }
-
-.c.obj:
- $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< }
-
-.asm.obj:
- $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@
-
-.rc.res:
- $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $<
-# ---------------------------------------------------------------------------
+++ /dev/null
-#include <condefs.h>
-#pragma hdrstop
-//---------------------------------------------------------------------------
-USEUNIT("adler32.c");
-USEUNIT("deflate.c");
-USEUNIT("infblock.c");
-USEUNIT("infcodes.c");
-USEUNIT("inffast.c");
-USEUNIT("inflate.c");
-USEUNIT("inftrees.c");
-USEUNIT("infutil.c");
-USEUNIT("trees.c");
-//---------------------------------------------------------------------------
-#define Library
-
-// To add a file to the library use the Project menu 'Add to Project'.
-
+++ /dev/null
-These are files used to compile zlib under Borland C++ Builder 3.
-
-zlib.bpg is the main project group that can be loaded in the BCB IDE and
-loads all other *.bpr projects
-
-zlib.bpr is a project used to create a static zlib.lib library with C calling
-convention for functions.
-
-zlib32.bpr creates a zlib32.dll dynamic link library with Windows standard
-calling convention.
-
-d_zlib.bpr creates a set of .obj files with register calling convention.
-These files are used by zlib.pas to create a Delphi unit containing zlib.
-The d_zlib.lib file generated isn't useful and can be deleted.
-
-zlib.cpp, zlib32.cpp and d_zlib.cpp are used by the above projects.
-
+++ /dev/null
-#------------------------------------------------------------------------------
-VERSION = BWS.01
-#------------------------------------------------------------------------------
-!ifndef ROOT
-ROOT = $(MAKEDIR)\..
-!endif
-#------------------------------------------------------------------------------
-MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$**
-DCC = $(ROOT)\bin\dcc32.exe $**
-BRCC = $(ROOT)\bin\brcc32.exe $**
-#------------------------------------------------------------------------------
-PROJECTS = zlib zlib32 d_zlib
-#------------------------------------------------------------------------------
-default: $(PROJECTS)
-#------------------------------------------------------------------------------
-
-zlib: zlib.bpr
- $(MAKE)
-
-zlib32: zlib32.bpr
- $(MAKE)
-
-d_zlib: d_zlib.bpr
- $(MAKE)
-
-
+++ /dev/null
-# ---------------------------------------------------------------------------
-!if !$d(BCB)
-BCB = $(MAKEDIR)\..
-!endif
-
-# ---------------------------------------------------------------------------
-# IDE SECTION
-# ---------------------------------------------------------------------------
-# The following section of the project makefile is managed by the BCB IDE.
-# It is recommended to use the IDE to change any of the values in this
-# section.
-# ---------------------------------------------------------------------------
-
-VERSION = BCB.03
-# ---------------------------------------------------------------------------
-PROJECT = zlib.lib
-OBJFILES = zlib.obj adler32.obj compress.obj crc32.obj deflate.obj gzio.obj infblock.obj \
- infcodes.obj inffast.obj inflate.obj inftrees.obj infutil.obj trees.obj \
- uncompr.obj zutil.obj
-RESFILES =
-RESDEPEN = $(RESFILES)
-LIBFILES =
-LIBRARIES = VCL35.lib
-SPARELIBS = VCL35.lib
-DEFFILE =
-PACKAGES = VCLX35.bpi VCL35.bpi VCLDB35.bpi VCLDBX35.bpi ibsmp35.bpi bcbsmp35.bpi \
- dclocx35.bpi QRPT35.bpi TEEUI35.bpi TEEDB35.bpi TEE35.bpi DSS35.bpi \
- NMFAST35.bpi INETDB35.bpi INET35.bpi VCLMID35.bpi
-# ---------------------------------------------------------------------------
-PATHCPP = .;
-PATHASM = .;
-PATHPAS = .;
-PATHRC = .;
-DEBUGLIBPATH = $(BCB)\lib\debug
-RELEASELIBPATH = $(BCB)\lib\release
-# ---------------------------------------------------------------------------
-CFLAG1 = -O2 -Ve -d -k- -vi
-CFLAG2 = -I$(BCB)\include;$(BCB)\include\vcl -H=$(BCB)\lib\vcl35.csm
-CFLAG3 = -ff -5
-PFLAGS = -U;$(DEBUGLIBPATH) -I$(BCB)\include;$(BCB)\include\vcl -H -W -$I- -v -JPHN -M
-RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl
-AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn
-LFLAGS =
-IFLAGS = -g -Gn
-# ---------------------------------------------------------------------------
-ALLOBJ = c0w32.obj $(OBJFILES)
-ALLRES = $(RESFILES)
-ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mt.lib
-# ---------------------------------------------------------------------------
-!!ifdef IDEOPTIONS
-
-[Version Info]
-IncludeVerInfo=0
-AutoIncBuild=0
-MajorVer=1
-MinorVer=0
-Release=0
-Build=0
-Debug=0
-PreRelease=0
-Special=0
-Private=0
-DLL=0
-Locale=1040
-CodePage=1252
-
-[Version Info Keys]
-CompanyName=
-FileDescription=
-FileVersion=1.0.0.0
-InternalName=
-LegalCopyright=
-LegalTrademarks=
-OriginalFilename=
-ProductName=
-ProductVersion=1.0.0.0
-Comments=
-
-[HistoryLists\hlIncludePath]
-Count=2
-Item0=$(BCB)\include
-Item1=$(BCB)\include;$(BCB)\include\vcl
-
-[HistoryLists\hlLibraryPath]
-Count=1
-Item0=$(BCB)\lib\obj;$(BCB)\lib
-
-[HistoryLists\hlDebugSourcePath]
-Count=1
-Item0=$(BCB)\source\vcl
-
-[Debugging]
-DebugSourceDirs=
-
-[Parameters]
-RunParams=
-HostApplication=
-
-!endif
-
- ---------------------------------------------------------------------------
-# MAKE SECTION
-# ---------------------------------------------------------------------------
-# This section of the project file is not used by the BCB IDE. It is for
-# the benefit of building from the command-line using the MAKE utility.
-# ---------------------------------------------------------------------------
-
-.autodepend
-# ---------------------------------------------------------------------------
-!if !$d(BCC32)
-BCC32 = bcc32
-!endif
-
-!if !$d(DCC32)
-DCC32 = dcc32
-!endif
-
-!if !$d(TASM32)
-TASM32 = tasm32
-!endif
-
-!if !$d(LINKER)
-LINKER = TLib
-!endif
-
-!if !$d(BRCC32)
-BRCC32 = brcc32
-!endif
-# ---------------------------------------------------------------------------
-!if $d(PATHCPP)
-.PATH.CPP = $(PATHCPP)
-.PATH.C = $(PATHCPP)
-!endif
-
-!if $d(PATHPAS)
-.PATH.PAS = $(PATHPAS)
-!endif
-
-!if $d(PATHASM)
-.PATH.ASM = $(PATHASM)
-!endif
-
-!if $d(PATHRC)
-.PATH.RC = $(PATHRC)
-!endif
-# ---------------------------------------------------------------------------
-!ifdef IDEOPTIONS
-
-[Version Info]
-IncludeVerInfo=0
-AutoIncBuild=0
-MajorVer=1
-MinorVer=0
-Release=0
-Build=0
-Debug=0
-PreRelease=0
-Special=0
-Private=0
-DLL=0
-Locale=1040
-CodePage=1252
-
-[Version Info Keys]
-CompanyName=
-FileDescription=
-FileVersion=1.0.0.0
-InternalName=
-LegalCopyright=
-LegalTrademarks=
-OriginalFilename=
-ProductName=
-ProductVersion=1.0.0.0
-Comments=
-
-[HistoryLists\hlIncludePath]
-Count=2
-Item0=$(BCB)\include;$(BCB)\include\vcl
-Item1=$(BCB)\include
-
-[HistoryLists\hlLibraryPath]
-Count=1
-Item0=$(BCB)\lib\obj;$(BCB)\lib
-
-[HistoryLists\hlDebugSourcePath]
-Count=1
-Item0=$(BCB)\source\vcl
-
-[Debugging]
-DebugSourceDirs=
-
-[Parameters]
-RunParams=
-HostApplication=
-
-!endif
-
-$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE)
- $(BCB)\BIN\$(LINKER) @&&!
- $(LFLAGS) $(IFLAGS) +
- $(ALLOBJ), +
- $(PROJECT),, +
- $(ALLLIB), +
- $(DEFFILE), +
- $(ALLRES)
-!
-# ---------------------------------------------------------------------------
-.pas.hpp:
- $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< }
-
-.pas.obj:
- $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< }
-
-.cpp.obj:
- $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< }
-
-.c.obj:
- $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< }
-
-.asm.obj:
- $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@
-
-.rc.res:
- $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $<
-# ---------------------------------------------------------------------------
+++ /dev/null
-#include <condefs.h>
-#pragma hdrstop
-//---------------------------------------------------------------------------
-USEUNIT("adler32.c");
-USEUNIT("compress.c");
-USEUNIT("crc32.c");
-USEUNIT("deflate.c");
-USEUNIT("gzio.c");
-USEUNIT("infblock.c");
-USEUNIT("infcodes.c");
-USEUNIT("inffast.c");
-USEUNIT("inflate.c");
-USEUNIT("inftrees.c");
-USEUNIT("infutil.c");
-USEUNIT("trees.c");
-USEUNIT("uncompr.c");
-USEUNIT("zutil.c");
-//---------------------------------------------------------------------------
-#define Library
-
-// To add a file to the library use the Project menu 'Add to Project'.
-
+++ /dev/null
-{*******************************************************}
-{ }
-{ Delphi Supplemental Components }
-{ ZLIB Data Compression Interface Unit }
-{ }
-{ Copyright (c) 1997 Borland International }
-{ }
-{*******************************************************}
-
-{ Modified for zlib 1.1.3 by Davide Moretti <dave@rimini.com }
-
-unit zlib;
-
-interface
-
-uses Sysutils, Classes;
-
-type
- TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer;
- TFree = procedure (AppData, Block: Pointer);
-
- // Internal structure. Ignore.
- TZStreamRec = packed record
- next_in: PChar; // next input byte
- avail_in: Integer; // number of bytes available at next_in
- total_in: Integer; // total nb of input bytes read so far
-
- next_out: PChar; // next output byte should be put here
- avail_out: Integer; // remaining free space at next_out
- total_out: Integer; // total nb of bytes output so far
-
- msg: PChar; // last error message, NULL if no error
- internal: Pointer; // not visible by applications
-
- zalloc: TAlloc; // used to allocate the internal state
- zfree: TFree; // used to free the internal state
- AppData: Pointer; // private data object passed to zalloc and zfree
-
- data_type: Integer; // best guess about the data type: ascii or binary
- adler: Integer; // adler32 value of the uncompressed data
- reserved: Integer; // reserved for future use
- end;
-
- // Abstract ancestor class
- TCustomZlibStream = class(TStream)
- private
- FStrm: TStream;
- FStrmPos: Integer;
- FOnProgress: TNotifyEvent;
- FZRec: TZStreamRec;
- FBuffer: array [Word] of Char;
- protected
- procedure Progress(Sender: TObject); dynamic;
- property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
- constructor Create(Strm: TStream);
- end;
-
-{ TCompressionStream compresses data on the fly as data is written to it, and
- stores the compressed data to another stream.
-
- TCompressionStream is write-only and strictly sequential. Reading from the
- stream will raise an exception. Using Seek to move the stream pointer
- will raise an exception.
-
- Output data is cached internally, written to the output stream only when
- the internal output buffer is full. All pending output data is flushed
- when the stream is destroyed.
-
- The Position property returns the number of uncompressed bytes of
- data that have been written to the stream so far.
-
- CompressionRate returns the on-the-fly percentage by which the original
- data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100
- If raw data size = 100 and compressed data size = 25, the CompressionRate
- is 75%
-
- The OnProgress event is called each time the output buffer is filled and
- written to the output stream. This is useful for updating a progress
- indicator when you are writing a large chunk of data to the compression
- stream in a single call.}
-
-
- TCompressionLevel = (clNone, clFastest, clDefault, clMax);
-
- TCompressionStream = class(TCustomZlibStream)
- private
- function GetCompressionRate: Single;
- public
- constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);
- destructor Destroy; override;
- function Read(var Buffer; Count: Longint): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- property CompressionRate: Single read GetCompressionRate;
- property OnProgress;
- end;
-
-{ TDecompressionStream decompresses data on the fly as data is read from it.
-
- Compressed data comes from a separate source stream. TDecompressionStream
- is read-only and unidirectional; you can seek forward in the stream, but not
- backwards. The special case of setting the stream position to zero is
- allowed. Seeking forward decompresses data until the requested position in
- the uncompressed data has been reached. Seeking backwards, seeking relative
- to the end of the stream, requesting the size of the stream, and writing to
- the stream will raise an exception.
-
- The Position property returns the number of bytes of uncompressed data that
- have been read from the stream so far.
-
- The OnProgress event is called each time the internal input buffer of
- compressed data is exhausted and the next block is read from the input stream.
- This is useful for updating a progress indicator when you are reading a
- large chunk of data from the decompression stream in a single call.}
-
- TDecompressionStream = class(TCustomZlibStream)
- public
- constructor Create(Source: TStream);
- destructor Destroy; override;
- function Read(var Buffer; Count: Longint): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- property OnProgress;
- end;
-
-
-
-{ CompressBuf compresses data, buffer to buffer, in one call.
- In: InBuf = ptr to compressed data
- InBytes = number of bytes in InBuf
- Out: OutBuf = ptr to newly allocated buffer containing decompressed data
- OutBytes = number of bytes in OutBuf }
-procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
- out OutBuf: Pointer; out OutBytes: Integer);
-
-
-{ DecompressBuf decompresses data, buffer to buffer, in one call.
- In: InBuf = ptr to compressed data
- InBytes = number of bytes in InBuf
- OutEstimate = zero, or est. size of the decompressed data
- Out: OutBuf = ptr to newly allocated buffer containing decompressed data
- OutBytes = number of bytes in OutBuf }
-procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
- OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
-
-const
- zlib_version = '1.1.3';
-
-type
- EZlibError = class(Exception);
- ECompressionError = class(EZlibError);
- EDecompressionError = class(EZlibError);
-
-function adler32(adler: Integer; buf: PChar; len: Integer): Integer;
-
-implementation
-
-const
- Z_NO_FLUSH = 0;
- Z_PARTIAL_FLUSH = 1;
- Z_SYNC_FLUSH = 2;
- Z_FULL_FLUSH = 3;
- Z_FINISH = 4;
-
- Z_OK = 0;
- Z_STREAM_END = 1;
- Z_NEED_DICT = 2;
- Z_ERRNO = (-1);
- Z_STREAM_ERROR = (-2);
- Z_DATA_ERROR = (-3);
- Z_MEM_ERROR = (-4);
- Z_BUF_ERROR = (-5);
- Z_VERSION_ERROR = (-6);
-
- Z_NO_COMPRESSION = 0;
- Z_BEST_SPEED = 1;
- Z_BEST_COMPRESSION = 9;
- Z_DEFAULT_COMPRESSION = (-1);
-
- Z_FILTERED = 1;
- Z_HUFFMAN_ONLY = 2;
- Z_DEFAULT_STRATEGY = 0;
-
- Z_BINARY = 0;
- Z_ASCII = 1;
- Z_UNKNOWN = 2;
-
- Z_DEFLATED = 8;
-
- _z_errmsg: array[0..9] of PChar = (
- 'need dictionary', // Z_NEED_DICT (2)
- 'stream end', // Z_STREAM_END (1)
- '', // Z_OK (0)
- 'file error', // Z_ERRNO (-1)
- 'stream error', // Z_STREAM_ERROR (-2)
- 'data error', // Z_DATA_ERROR (-3)
- 'insufficient memory', // Z_MEM_ERROR (-4)
- 'buffer error', // Z_BUF_ERROR (-5)
- 'incompatible version', // Z_VERSION_ERROR (-6)
- ''
- );
-
-{$L deflate.obj}
-{$L inflate.obj}
-{$L inftrees.obj}
-{$L trees.obj}
-{$L adler32.obj}
-{$L infblock.obj}
-{$L infcodes.obj}
-{$L infutil.obj}
-{$L inffast.obj}
-
-procedure _tr_init; external;
-procedure _tr_tally; external;
-procedure _tr_flush_block; external;
-procedure _tr_align; external;
-procedure _tr_stored_block; external;
-function adler32; external;
-procedure inflate_blocks_new; external;
-procedure inflate_blocks; external;
-procedure inflate_blocks_reset; external;
-procedure inflate_blocks_free; external;
-procedure inflate_set_dictionary; external;
-procedure inflate_trees_bits; external;
-procedure inflate_trees_dynamic; external;
-procedure inflate_trees_fixed; external;
-procedure inflate_codes_new; external;
-procedure inflate_codes; external;
-procedure inflate_codes_free; external;
-procedure _inflate_mask; external;
-procedure inflate_flush; external;
-procedure inflate_fast; external;
-
-procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl;
-begin
- FillChar(P^, count, B);
-end;
-
-procedure _memcpy(dest, source: Pointer; count: Integer);cdecl;
-begin
- Move(source^, dest^, count);
-end;
-
-
-
-// deflate compresses data
-function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar;
- recsize: Integer): Integer; external;
-function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
-function deflateEnd(var strm: TZStreamRec): Integer; external;
-
-// inflate decompresses data
-function inflateInit_(var strm: TZStreamRec; version: PChar;
- recsize: Integer): Integer; external;
-function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
-function inflateEnd(var strm: TZStreamRec): Integer; external;
-function inflateReset(var strm: TZStreamRec): Integer; external;
-
-
-function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer;
-begin
- GetMem(Result, Items*Size);
-end;
-
-procedure zcfree(AppData, Block: Pointer);
-begin
- FreeMem(Block);
-end;
-
-function zlibCheck(code: Integer): Integer;
-begin
- Result := code;
- if code < 0 then
- raise EZlibError.Create('error'); //!!
-end;
-
-function CCheck(code: Integer): Integer;
-begin
- Result := code;
- if code < 0 then
- raise ECompressionError.Create('error'); //!!
-end;
-
-function DCheck(code: Integer): Integer;
-begin
- Result := code;
- if code < 0 then
- raise EDecompressionError.Create('error'); //!!
-end;
-
-procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
- out OutBuf: Pointer; out OutBytes: Integer);
-var
- strm: TZStreamRec;
- P: Pointer;
-begin
- FillChar(strm, sizeof(strm), 0);
- OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
- GetMem(OutBuf, OutBytes);
- try
- strm.next_in := InBuf;
- strm.avail_in := InBytes;
- strm.next_out := OutBuf;
- strm.avail_out := OutBytes;
- CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)));
- try
- while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
- begin
- P := OutBuf;
- Inc(OutBytes, 256);
- ReallocMem(OutBuf, OutBytes);
- strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
- strm.avail_out := 256;
- end;
- finally
- CCheck(deflateEnd(strm));
- end;
- ReallocMem(OutBuf, strm.total_out);
- OutBytes := strm.total_out;
- except
- FreeMem(OutBuf);
- raise
- end;
-end;
-
-
-procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
- OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer);
-var
- strm: TZStreamRec;
- P: Pointer;
- BufInc: Integer;
-begin
- FillChar(strm, sizeof(strm), 0);
- BufInc := (InBytes + 255) and not 255;
- if OutEstimate = 0 then
- OutBytes := BufInc
- else
- OutBytes := OutEstimate;
- GetMem(OutBuf, OutBytes);
- try
- strm.next_in := InBuf;
- strm.avail_in := InBytes;
- strm.next_out := OutBuf;
- strm.avail_out := OutBytes;
- DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
- try
- while DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END do
- begin
- P := OutBuf;
- Inc(OutBytes, BufInc);
- ReallocMem(OutBuf, OutBytes);
- strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
- strm.avail_out := BufInc;
- end;
- finally
- DCheck(inflateEnd(strm));
- end;
- ReallocMem(OutBuf, strm.total_out);
- OutBytes := strm.total_out;
- except
- FreeMem(OutBuf);
- raise
- end;
-end;
-
-
-// TCustomZlibStream
-
-constructor TCustomZLibStream.Create(Strm: TStream);
-begin
- inherited Create;
- FStrm := Strm;
- FStrmPos := Strm.Position;
-end;
-
-procedure TCustomZLibStream.Progress(Sender: TObject);
-begin
- if Assigned(FOnProgress) then FOnProgress(Sender);
-end;
-
-
-// TCompressionStream
-
-constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
- Dest: TStream);
-const
- Levels: array [TCompressionLevel] of ShortInt =
- (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
-begin
- inherited Create(Dest);
- FZRec.next_out := FBuffer;
- FZRec.avail_out := sizeof(FBuffer);
- CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
-end;
-
-destructor TCompressionStream.Destroy;
-begin
- FZRec.next_in := nil;
- FZRec.avail_in := 0;
- try
- if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
- while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
- and (FZRec.avail_out = 0) do
- begin
- FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
- FZRec.next_out := FBuffer;
- FZRec.avail_out := sizeof(FBuffer);
- end;
- if FZRec.avail_out < sizeof(FBuffer) then
- FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
- finally
- deflateEnd(FZRec);
- end;
- inherited Destroy;
-end;
-
-function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
-begin
- raise ECompressionError.Create('Invalid stream operation');
-end;
-
-function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
-begin
- FZRec.next_in := @Buffer;
- FZRec.avail_in := Count;
- if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
- while (FZRec.avail_in > 0) do
- begin
- CCheck(deflate(FZRec, 0));
- if FZRec.avail_out = 0 then
- begin
- FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
- FZRec.next_out := FBuffer;
- FZRec.avail_out := sizeof(FBuffer);
- FStrmPos := FStrm.Position;
- Progress(Self);
- end;
- end;
- Result := Count;
-end;
-
-function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
-begin
- if (Offset = 0) and (Origin = soFromCurrent) then
- Result := FZRec.total_in
- else
- raise ECompressionError.Create('Invalid stream operation');
-end;
-
-function TCompressionStream.GetCompressionRate: Single;
-begin
- if FZRec.total_in = 0 then
- Result := 0
- else
- Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
-end;
-
-
-// TDecompressionStream
-
-constructor TDecompressionStream.Create(Source: TStream);
-begin
- inherited Create(Source);
- FZRec.next_in := FBuffer;
- FZRec.avail_in := 0;
- DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
-end;
-
-destructor TDecompressionStream.Destroy;
-begin
- inflateEnd(FZRec);
- inherited Destroy;
-end;
-
-function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
-begin
- FZRec.next_out := @Buffer;
- FZRec.avail_out := Count;
- if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
- while (FZRec.avail_out > 0) do
- begin
- if FZRec.avail_in = 0 then
- begin
- FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
- if FZRec.avail_in = 0 then
- begin
- Result := Count - FZRec.avail_out;
- Exit;
- end;
- FZRec.next_in := FBuffer;
- FStrmPos := FStrm.Position;
- Progress(Self);
- end;
- DCheck(inflate(FZRec, 0));
- end;
- Result := Count;
-end;
-
-function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
-begin
- raise EDecompressionError.Create('Invalid stream operation');
-end;
-
-function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
-var
- I: Integer;
- Buf: array [0..4095] of Char;
-begin
- if (Offset = 0) and (Origin = soFromBeginning) then
- begin
- DCheck(inflateReset(FZRec));
- FZRec.next_in := FBuffer;
- FZRec.avail_in := 0;
- FStrm.Position := 0;
- FStrmPos := 0;
- end
- else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
- ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
- begin
- if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
- if Offset > 0 then
- begin
- for I := 1 to Offset div sizeof(Buf) do
- ReadBuffer(Buf, sizeof(Buf));
- ReadBuffer(Buf, Offset mod sizeof(Buf));
- end;
- end
- else
- raise EDecompressionError.Create('Invalid stream operation');
- Result := FZRec.total_out;
-end;
-
-end.
+++ /dev/null
-# ---------------------------------------------------------------------------
-!if !$d(BCB)
-BCB = $(MAKEDIR)\..
-!endif
-
-# ---------------------------------------------------------------------------
-# IDE SECTION
-# ---------------------------------------------------------------------------
-# The following section of the project makefile is managed by the BCB IDE.
-# It is recommended to use the IDE to change any of the values in this
-# section.
-# ---------------------------------------------------------------------------
-
-VERSION = BCB.03
-# ---------------------------------------------------------------------------
-PROJECT = zlib32.dll
-OBJFILES = zlib32.obj adler32.obj compress.obj crc32.obj deflate.obj gzio.obj infblock.obj \
- infcodes.obj inffast.obj inflate.obj inftrees.obj infutil.obj trees.obj \
- uncompr.obj zutil.obj
-RESFILES =
-RESDEPEN = $(RESFILES)
-LIBFILES =
-LIBRARIES =
-SPARELIBS =
-DEFFILE =
-PACKAGES = VCLX35.bpi VCL35.bpi VCLDB35.bpi VCLDBX35.bpi ibsmp35.bpi bcbsmp35.bpi \
- dclocx35.bpi QRPT35.bpi TEEUI35.bpi TEEDB35.bpi TEE35.bpi DSS35.bpi \
- NMFAST35.bpi INETDB35.bpi INET35.bpi VCLMID35.bpi
-# ---------------------------------------------------------------------------
-PATHCPP = .;
-PATHASM = .;
-PATHPAS = .;
-PATHRC = .;
-DEBUGLIBPATH = $(BCB)\lib\debug
-RELEASELIBPATH = $(BCB)\lib\release
-# ---------------------------------------------------------------------------
-CFLAG1 = -WD -O2 -Ve -d -k- -vi -c -tWD
-CFLAG2 = -D_NO_VCL;ZLIB_DLL -I$(BCB)\include
-CFLAG3 = -ff -5
-PFLAGS = -D_NO_VCL;ZLIB_DLL -U$(BCB)\lib;$(RELEASELIBPATH) -I$(BCB)\include -$I- -v \
- -JPHN -M
-RFLAGS = -D_NO_VCL;ZLIB_DLL -i$(BCB)\include
-AFLAGS = /i$(BCB)\include /d_NO_VCL /dZLIB_DLL /mx /w2 /zn
-LFLAGS = -L$(BCB)\lib;$(RELEASELIBPATH) -aa -Tpd -x -Gi
-IFLAGS = -Gn -g
-# ---------------------------------------------------------------------------
-ALLOBJ = c0d32.obj $(OBJFILES)
-ALLRES = $(RESFILES)
-ALLLIB = $(LIBFILES) import32.lib cw32mt.lib
-# ---------------------------------------------------------------------------
-!ifdef IDEOPTIONS
-
-[Version Info]
-IncludeVerInfo=0
-AutoIncBuild=0
-MajorVer=1
-MinorVer=0
-Release=0
-Build=0
-Debug=0
-PreRelease=0
-Special=0
-Private=0
-DLL=1
-Locale=1040
-CodePage=1252
-
-[Version Info Keys]
-CompanyName=
-FileDescription=DLL (GUI)
-FileVersion=1.0.0.0
-InternalName=
-LegalCopyright=
-LegalTrademarks=
-OriginalFilename=
-ProductName=
-ProductVersion=1.0.0.0
-Comments=
-
-[HistoryLists\hlIncludePath]
-Count=1
-Item0=$(BCB)\include
-
-[HistoryLists\hlLibraryPath]
-Count=1
-Item0=$(BCB)\lib
-
-[HistoryLists\hlConditionals]
-Count=1
-Item0=_NO_VCL;ZLIB_DLL
-
-[Debugging]
-DebugSourceDirs=
-
-[Parameters]
-RunParams=
-HostApplication=
-
-!endif
-
-# ---------------------------------------------------------------------------
-# MAKE SECTION
-# ---------------------------------------------------------------------------
-# This section of the project file is not used by the BCB IDE. It is for
-# the benefit of building from the command-line using the MAKE utility.
-# ---------------------------------------------------------------------------
-
-.autodepend
-# ---------------------------------------------------------------------------
-!if !$d(BCC32)
-BCC32 = bcc32
-!endif
-
-!if !$d(DCC32)
-DCC32 = dcc32
-!endif
-
-!if !$d(TASM32)
-TASM32 = tasm32
-!endif
-
-!if !$d(LINKER)
-LINKER = ilink32
-!endif
-
-!if !$d(BRCC32)
-BRCC32 = brcc32
-!endif
-# ---------------------------------------------------------------------------
-!if $d(PATHCPP)
-.PATH.CPP = $(PATHCPP)
-.PATH.C = $(PATHCPP)
-!endif
-
-!if $d(PATHPAS)
-.PATH.PAS = $(PATHPAS)
-!endif
-
-!if $d(PATHASM)
-.PATH.ASM = $(PATHASM)
-!endif
-
-!if $d(PATHRC)
-.PATH.RC = $(PATHRC)
-!endif
-# ---------------------------------------------------------------------------
-$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE)
- $(BCB)\BIN\$(LINKER) @&&!
- $(LFLAGS) $(IFLAGS) +
- $(ALLOBJ), +
- $(PROJECT),, +
- $(ALLLIB), +
- $(DEFFILE), +
- $(ALLRES)
-!
-# ---------------------------------------------------------------------------
-.pas.hpp:
- $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< }
-
-.pas.obj:
- $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< }
-
-.cpp.obj:
- $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< }
-
-.c.obj:
- $(BCB)\BIN\$(BCC32) $(CFLAG1) $(CFLAG2) $(CFLAG3) -n$(@D) {$< }
-
-.asm.obj:
- $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@
-
-.rc.res:
- $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $<
-# ---------------------------------------------------------------------------
+++ /dev/null
-
-#include <windows.h>
-#pragma hdrstop
-#include <condefs.h>
-
-
-//---------------------------------------------------------------------------
-// Important note about DLL memory management in a VCL DLL:
-//
-//
-//
-// If your DLL uses VCL and exports any functions that pass VCL String objects
-// (or structs/classes containing nested Strings) as parameter or function
-// results, you will need to build both your DLL project and any EXE projects
-// that use your DLL with the dynamic RTL (the RTL DLL). This will change your
-// DLL and its calling EXE's to use BORLNDMM.DLL as their memory manager. In
-// these cases, the file BORLNDMM.DLL should be deployed along with your DLL
-// and the RTL DLL (CP3240MT.DLL). To avoid the requiring BORLNDMM.DLL in
-// these situations, pass string information using "char *" or ShortString
-// parameters and then link with the static RTL.
-//
-//---------------------------------------------------------------------------
-USEUNIT("adler32.c");
-USEUNIT("compress.c");
-USEUNIT("crc32.c");
-USEUNIT("deflate.c");
-USEUNIT("gzio.c");
-USEUNIT("infblock.c");
-USEUNIT("infcodes.c");
-USEUNIT("inffast.c");
-USEUNIT("inflate.c");
-USEUNIT("inftrees.c");
-USEUNIT("infutil.c");
-USEUNIT("trees.c");
-USEUNIT("uncompr.c");
-USEUNIT("zutil.c");
-//---------------------------------------------------------------------------
-#pragma argsused
-int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*)
-{
- return 1;
-}
+++ /dev/null
-# Makefile for zlib. Modified for emx/rsxnt by Chr. Spieler, 6/16/98.
-# Copyright (C) 1995-1998 Jean-loup Gailly.
-# For conditions of distribution and use, see copyright notice in zlib.h
-
-# To compile, or to compile and test, type:
-#
-# make -fmakefile.emx; make test -fmakefile.emx
-#
-
-CC=gcc -Zwin32
-
-#CFLAGS=-MMD -O
-#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7
-#CFLAGS=-MMD -g -DDEBUG
-CFLAGS=-MMD -O3 $(BUTT) -Wall -Wwrite-strings -Wpointer-arith -Wconversion \
- -Wstrict-prototypes -Wmissing-prototypes
-
-# If cp.exe is available, replace "copy /Y" with "cp -fp" .
-CP=copy /Y
-# If gnu install.exe is available, replace $(CP) with ginstall.
-INSTALL=$(CP)
-# The default value of RM is "rm -f." If "rm.exe" is found, comment out:
-RM=del
-LDLIBS=-L. -lzlib
-LD=$(CC) -s -o
-LDSHARED=$(CC)
-
-INCL=zlib.h zconf.h
-LIBS=zlib.a
-
-AR=ar rcs
-
-prefix=/usr/local
-exec_prefix = $(prefix)
-
-OBJS = adler32.o compress.o crc32.o gzio.o uncompr.o deflate.o trees.o \
- zutil.o inflate.o infblock.o inftrees.o infcodes.o infutil.o inffast.o
-
-TEST_OBJS = example.o minigzip.o
-
-all: example.exe minigzip.exe
-
-test: all
- ./example
- echo hello world | .\minigzip | .\minigzip -d
-
-%.o : %.c
- $(CC) $(CFLAGS) -c $< -o $@
-
-zlib.a: $(OBJS)
- $(AR) $@ $(OBJS)
-
-%.exe : %.o $(LIBS)
- $(LD) $@ $< $(LDLIBS)
-
-
-.PHONY : clean
-
-clean:
- $(RM) *.d
- $(RM) *.o
- $(RM) *.exe
- $(RM) zlib.a
- $(RM) foo.gz
-
-DEPS := $(wildcard *.d)
-ifneq ($(DEPS),)
-include $(DEPS)
-endif
-# Makefile for zlib. Modified for emx 0.9c by Chr. Spieler, 6/17/98.
-# Copyright (C) 1995-1998 Jean-loup Gailly.
-# For conditions of distribution and use, see copyright notice in zlib.h
-
-# To compile, or to compile and test, type:
-#
-# make -fmakefile.emx; make test -fmakefile.emx
-#
-
-CC=gcc
-
-#CFLAGS=-MMD -O
-#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7
-#CFLAGS=-MMD -g -DDEBUG
-CFLAGS=-MMD -O3 $(BUTT) -Wall -Wwrite-strings -Wpointer-arith -Wconversion \
- -Wstrict-prototypes -Wmissing-prototypes
-
-# If cp.exe is available, replace "copy /Y" with "cp -fp" .
-CP=copy /Y
-# If gnu install.exe is available, replace $(CP) with ginstall.
-INSTALL=$(CP)
-# The default value of RM is "rm -f." If "rm.exe" is found, comment out:
-RM=del
-LDLIBS=-L. -lzlib
-LD=$(CC) -s -o
-LDSHARED=$(CC)
-
-INCL=zlib.h zconf.h
-LIBS=zlib.a
-
-AR=ar rcs
-
-prefix=/usr/local
-exec_prefix = $(prefix)
-
-OBJS = adler32.o compress.o crc32.o gzio.o uncompr.o deflate.o trees.o \
- zutil.o inflate.o infblock.o inftrees.o infcodes.o infutil.o inffast.o
-
-TEST_OBJS = example.o minigzip.o
-
-all: example.exe minigzip.exe
-
-test: all
- ./example
- echo hello world | .\minigzip | .\minigzip -d
-
-%.o : %.c
- $(CC) $(CFLAGS) -c $< -o $@
-
-zlib.a: $(OBJS)
- $(AR) $@ $(OBJS)
-
-%.exe : %.o $(LIBS)
- $(LD) $@ $< $(LDLIBS)
-
-
-.PHONY : clean
-
-clean:
- $(RM) *.d
- $(RM) *.o
- $(RM) *.exe
- $(RM) zlib.a
- $(RM) foo.gz
-
-DEPS := $(wildcard *.d)
-ifneq ($(DEPS),)
-include $(DEPS)
-endif
+++ /dev/null
-# Makefile for zlib. Modified for mingw32 by C. Spieler, 6/16/98.
-# (This Makefile is directly derived from Makefile.dj2)
-# Copyright (C) 1995-1998 Jean-loup Gailly.
-# For conditions of distribution and use, see copyright notice in zlib.h
-
-# To compile, or to compile and test, type:
-#
-# make -fmakefile.gcc; make test -fmakefile.gcc
-#
-# To install libz.a, zconf.h and zlib.h in the mingw32 directories, type:
-#
-# make install -fmakefile.gcc
-#
-
-CC=gcc
-
-#CFLAGS=-MMD -O
-#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7
-#CFLAGS=-MMD -g -DDEBUG
-CFLAGS=-MMD -O3 $(BUTT) -Wall -Wwrite-strings -Wpointer-arith -Wconversion \
- -Wstrict-prototypes -Wmissing-prototypes
-
-# If cp.exe is available, replace "copy /Y" with "cp -fp" .
-CP=copy /Y
-# If gnu install.exe is available, replace $(CP) with ginstall.
-INSTALL=$(CP)
-# The default value of RM is "rm -f." If "rm.exe" is found, comment out:
-RM=del
-LDLIBS=-L. -lz
-LD=$(CC) -s -o
-LDSHARED=$(CC)
-
-INCL=zlib.h zconf.h
-LIBS=libz.a
-
-AR=ar rcs
-
-prefix=/usr/local
-exec_prefix = $(prefix)
-
-OBJS = adler32.o compress.o crc32.o gzio.o uncompr.o deflate.o trees.o \
- zutil.o inflate.o infblock.o inftrees.o infcodes.o infutil.o inffast.o
-
-TEST_OBJS = example.o minigzip.o
-
-all: example.exe minigzip.exe
-
-test: all
- ./example
- echo hello world | .\minigzip | .\minigzip -d
-
-%.o : %.c
- $(CC) $(CFLAGS) -c $< -o $@
-
-libz.a: $(OBJS)
- $(AR) $@ $(OBJS)
-
-%.exe : %.o $(LIBS)
- $(LD) $@ $< $(LDLIBS)
-
-# INCLUDE_PATH and LIBRARY_PATH were set for [make] in djgpp.env .
-
-.PHONY : uninstall clean
-
-install: $(INCL) $(LIBS)
- -@if not exist $(INCLUDE_PATH)\nul mkdir $(INCLUDE_PATH)
- -@if not exist $(LIBRARY_PATH)\nul mkdir $(LIBRARY_PATH)
- $(INSTALL) zlib.h $(INCLUDE_PATH)
- $(INSTALL) zconf.h $(INCLUDE_PATH)
- $(INSTALL) libz.a $(LIBRARY_PATH)
-
-uninstall:
- $(RM) $(INCLUDE_PATH)\zlib.h
- $(RM) $(INCLUDE_PATH)\zconf.h
- $(RM) $(LIBRARY_PATH)\libz.a
-
-clean:
- $(RM) *.d
- $(RM) *.o
- $(RM) *.exe
- $(RM) libz.a
- $(RM) foo.gz
-
-DEPS := $(wildcard *.d)
-ifneq ($(DEPS),)
-include $(DEPS)
-endif
+++ /dev/null
-# Makefile for zlib
-
-!include <ntwin32.mak>
-
-CC=cl
-LD=link
-CFLAGS=-O -nologo
-LDFLAGS=
-O=.obj
-
-# variables
-OBJ1 = adler32$(O) compress$(O) crc32$(O) gzio$(O) uncompr$(O) deflate$(O) \
- trees$(O)
-OBJ2 = zutil$(O) inflate$(O) infblock$(O) inftrees$(O) infcodes$(O) \
- infutil$(O) inffast$(O)
-
-all: zlib.dll example.exe minigzip.exe
-
-adler32.obj: adler32.c zutil.h zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-compress.obj: compress.c zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-crc32.obj: crc32.c zutil.h zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-deflate.obj: deflate.c deflate.h zutil.h zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-gzio.obj: gzio.c zutil.h zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-infblock.obj: infblock.c zutil.h zlib.h zconf.h infblock.h inftrees.h\
- infcodes.h infutil.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-infcodes.obj: infcodes.c zutil.h zlib.h zconf.h inftrees.h infutil.h\
- infcodes.h inffast.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-inflate.obj: inflate.c zutil.h zlib.h zconf.h infblock.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-inftrees.obj: inftrees.c zutil.h zlib.h zconf.h inftrees.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-infutil.obj: infutil.c zutil.h zlib.h zconf.h inftrees.h infutil.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-inffast.obj: inffast.c zutil.h zlib.h zconf.h inftrees.h infutil.h inffast.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-trees.obj: trees.c deflate.h zutil.h zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-uncompr.obj: uncompr.c zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-zutil.obj: zutil.c zutil.h zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-example.obj: example.c zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-minigzip.obj: minigzip.c zlib.h zconf.h
- $(CC) -c $(cvarsdll) $(CFLAGS) $*.c
-
-zlib.dll: $(OBJ1) $(OBJ2) zlib.dnt
- link $(dlllflags) -out:$@ -def:zlib.dnt $(OBJ1) $(OBJ2) $(guilibsdll)
-
-zlib.lib: zlib.dll
-
-example.exe: example.obj zlib.lib
- $(LD) $(LDFLAGS) example.obj zlib.lib
-
-minigzip.exe: minigzip.obj zlib.lib
- $(LD) $(LDFLAGS) minigzip.obj zlib.lib
-
-test: example.exe minigzip.exe
- example
- echo hello world | minigzip | minigzip -d
-
-clean:
- del *.obj
- del *.exe
- del *.dll
- del *.lib
+++ /dev/null
-LIBRARY zlib.dll
-EXETYPE WINDOWS
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE MULTIPLE
-
-EXPORTS
- adler32 @1
- compress @2
- crc32 @3
- deflate @4
- deflateCopy @5
- deflateEnd @6
- deflateInit2_ @7
- deflateInit_ @8
- deflateParams @9
- deflateReset @10
- deflateSetDictionary @11
- gzclose @12
- gzdopen @13
- gzerror @14
- gzflush @15
- gzopen @16
- gzread @17
- gzwrite @18
- inflate @19
- inflateEnd @20
- inflateInit2_ @21
- inflateInit_ @22
- inflateReset @23
- inflateSetDictionary @24
- inflateSync @25
- uncompress @26
- zlibVersion @27
- gzprintf @28
- gzputc @29
- gzgetc @30
- gzseek @31
- gzrewind @32
- gztell @33
- gzeof @34
- gzsetparams @35
- zError @36
- inflateSyncPoint @37
- get_crc_table @38
- compress2 @39
- gzputs @40
- gzgets @41
+++ /dev/null
-# Makefile for zlib under OS/2 using GCC (PGCC)
-# For conditions of distribution and use, see copyright notice in zlib.h
-
-# To compile and test, type:
-# cp Makefile.os2 ..
-# cd ..
-# make -f Makefile.os2 test
-
-# This makefile will build a static library z.lib, a shared library
-# z.dll and a import library zdll.lib. You can use either z.lib or
-# zdll.lib by specifying either -lz or -lzdll on gcc's command line
-
-CC=gcc -Zomf -s
-
-CFLAGS=-O6 -Wall
-#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7
-#CFLAGS=-g -DDEBUG
-#CFLAGS=-O3 -Wall -Wwrite-strings -Wpointer-arith -Wconversion \
-# -Wstrict-prototypes -Wmissing-prototypes
-
-#################### BUG WARNING: #####################
-## infcodes.c hits a bug in pgcc-1.0, so you have to use either
-## -O# where # <= 4 or one of (-fno-ommit-frame-pointer or -fno-force-mem)
-## This bug is reportedly fixed in pgcc >1.0, but this was not tested
-CFLAGS+=-fno-force-mem
-
-LDFLAGS=-s -L. -lzdll -Zcrtdll
-LDSHARED=$(CC) -s -Zomf -Zdll -Zcrtdll
-
-VER=1.1.0
-ZLIB=z.lib
-SHAREDLIB=z.dll
-SHAREDLIBIMP=zdll.lib
-LIBS=$(ZLIB) $(SHAREDLIB) $(SHAREDLIBIMP)
-
-AR=emxomfar cr
-IMPLIB=emximp
-RANLIB=echo
-TAR=tar
-SHELL=bash
-
-prefix=/usr/local
-exec_prefix = $(prefix)
-
-OBJS = adler32.o compress.o crc32.o gzio.o uncompr.o deflate.o trees.o \
- zutil.o inflate.o infblock.o inftrees.o infcodes.o infutil.o inffast.o
-
-TEST_OBJS = example.o minigzip.o
-
-DISTFILES = README INDEX ChangeLog configure Make*[a-z0-9] *.[ch] descrip.mms \
- algorithm.txt zlib.3 msdos/Make*[a-z0-9] msdos/zlib.def msdos/zlib.rc \
- nt/Makefile.nt nt/zlib.dnt contrib/README.contrib contrib/*.txt \
- contrib/asm386/*.asm contrib/asm386/*.c \
- contrib/asm386/*.bat contrib/asm386/zlibvc.d?? contrib/iostream/*.cpp \
- contrib/iostream/*.h contrib/iostream2/*.h contrib/iostream2/*.cpp \
- contrib/untgz/Makefile contrib/untgz/*.c contrib/untgz/*.w32
-
-all: example.exe minigzip.exe
-
-test: all
- @LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ; export LD_LIBRARY_PATH; \
- echo hello world | ./minigzip | ./minigzip -d || \
- echo ' *** minigzip test FAILED ***' ; \
- if ./example; then \
- echo ' *** zlib test OK ***'; \
- else \
- echo ' *** zlib test FAILED ***'; \
- fi
-
-$(ZLIB): $(OBJS)
- $(AR) $@ $(OBJS)
- -@ ($(RANLIB) $@ || true) >/dev/null 2>&1
-
-$(SHAREDLIB): $(OBJS) os2/z.def
- $(LDSHARED) -o $@ $^
-
-$(SHAREDLIBIMP): os2/z.def
- $(IMPLIB) -o $@ $^
-
-example.exe: example.o $(LIBS)
- $(CC) $(CFLAGS) -o $@ example.o $(LDFLAGS)
-
-minigzip.exe: minigzip.o $(LIBS)
- $(CC) $(CFLAGS) -o $@ minigzip.o $(LDFLAGS)
-
-clean:
- rm -f *.o *~ example minigzip libz.a libz.so* foo.gz
-
-distclean: clean
-
-zip:
- mv Makefile Makefile~; cp -p Makefile.in Makefile
- rm -f test.c ztest*.c
- v=`sed -n -e 's/\.//g' -e '/VERSION "/s/.*"\(.*\)".*/\1/p' < zlib.h`;\
- zip -ul9 zlib$$v $(DISTFILES)
- mv Makefile~ Makefile
-
-dist:
- mv Makefile Makefile~; cp -p Makefile.in Makefile
- rm -f test.c ztest*.c
- d=zlib-`sed -n '/VERSION "/s/.*"\(.*\)".*/\1/p' < zlib.h`;\
- rm -f $$d.tar.gz; \
- if test ! -d ../$$d; then rm -f ../$$d; ln -s `pwd` ../$$d; fi; \
- files=""; \
- for f in $(DISTFILES); do files="$$files $$d/$$f"; done; \
- cd ..; \
- GZIP=-9 $(TAR) chofz $$d/$$d.tar.gz $$files; \
- if test ! -d $$d; then rm -f $$d; fi
- mv Makefile~ Makefile
-
-tags:
- etags *.[ch]
-
-depend:
- makedepend -- $(CFLAGS) -- *.[ch]
-
-# DO NOT DELETE THIS LINE -- make depend depends on it.
-
-adler32.o: zlib.h zconf.h
-compress.o: zlib.h zconf.h
-crc32.o: zlib.h zconf.h
-deflate.o: deflate.h zutil.h zlib.h zconf.h
-example.o: zlib.h zconf.h
-gzio.o: zutil.h zlib.h zconf.h
-infblock.o: infblock.h inftrees.h infcodes.h infutil.h zutil.h zlib.h zconf.h
-infcodes.o: zutil.h zlib.h zconf.h
-infcodes.o: inftrees.h infblock.h infcodes.h infutil.h inffast.h
-inffast.o: zutil.h zlib.h zconf.h inftrees.h
-inffast.o: infblock.h infcodes.h infutil.h inffast.h
-inflate.o: zutil.h zlib.h zconf.h infblock.h
-inftrees.o: zutil.h zlib.h zconf.h inftrees.h
-infutil.o: zutil.h zlib.h zconf.h infblock.h inftrees.h infcodes.h infutil.h
-minigzip.o: zlib.h zconf.h
-trees.o: deflate.h zutil.h zlib.h zconf.h trees.h
-uncompr.o: zlib.h zconf.h
-zutil.o: zutil.h zlib.h zconf.h
+++ /dev/null
-;
-; Slightly modified version of ../nt/zlib.dnt :-)
-;
-
-LIBRARY Z
-DESCRIPTION "Zlib compression library for OS/2"
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE MULTIPLE
-
-EXPORTS
- adler32
- compress
- crc32
- deflate
- deflateCopy
- deflateEnd
- deflateInit2_
- deflateInit_
- deflateParams
- deflateReset
- deflateSetDictionary
- gzclose
- gzdopen
- gzerror
- gzflush
- gzopen
- gzread
- gzwrite
- inflate
- inflateEnd
- inflateInit2_
- inflateInit_
- inflateReset
- inflateSetDictionary
- inflateSync
- uncompress
- zlibVersion
- gzprintf
- gzputc
- gzgetc
- gzseek
- gzrewind
- gztell
- gzeof
- gzsetparams
- zError
- inflateSyncPoint
- get_crc_table
- compress2
- gzputs
- gzgets
projects / platform / upstream / linaro-gcc.git / commitdiff