From: nickc Date: Wed, 2 Feb 2005 19:06:59 +0000 (+0000) Subject: Imported from mainline FSF repositories X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=8e5578eabbd6bc753dda1e4d8b114c06ad2e74e0 Imported from mainline FSF repositories git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@94600 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/config/dsp16xx/dsp16xx-modes.def b/gcc/config/dsp16xx/dsp16xx-modes.def new file mode 100644 index 00000000000..968e271ff44 --- /dev/null +++ b/gcc/config/dsp16xx/dsp16xx-modes.def @@ -0,0 +1,23 @@ +/* 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); diff --git a/gcc/config/dsp16xx/dsp16xx-protos.h b/gcc/config/dsp16xx/dsp16xx-protos.h new file mode 100644 index 00000000000..802c69b62ec --- /dev/null +++ b/gcc/config/dsp16xx/dsp16xx-protos.h @@ -0,0 +1,86 @@ +/* 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); diff --git a/gcc/config/dsp16xx/dsp16xx.c b/gcc/config/dsp16xx/dsp16xx.c new file mode 100644 index 00000000000..14d9c5e088e --- /dev/null +++ b/gcc/config/dsp16xx/dsp16xx.c @@ -0,0 +1,2632 @@ +/* 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); + +/* 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; +} + + +/* 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; +} + +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; +} diff --git a/gcc/config/dsp16xx/dsp16xx.h b/gcc/config/dsp16xx/dsp16xx.h new file mode 100644 index 00000000000..472ba1f0d9b --- /dev/null +++ b/gcc/config/dsp16xx/dsp16xx.h @@ -0,0 +1,1768 @@ +/* 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; \ + } \ +} + +/* 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 + +/* 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" + + +/* 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 + +/* 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) + +/* 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) + + +/* 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(); \ +} + +/* 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 + + +/* 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 + +/* 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; \ +} + + +/* 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) + + +/* 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) ) + +/* 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 + + +/* 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) */ + + +/* 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" + +/* 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 "" + +/* 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" + +/* 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); + +/* 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)) + + +/* 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"); + +/* 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) + + +/* 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 + diff --git a/gcc/config/dsp16xx/dsp16xx.md b/gcc/config/dsp16xx/dsp16xx.md new file mode 100644 index 00000000000..fffd2a9d9e0 --- /dev/null +++ b/gcc/config/dsp16xx/dsp16xx.md @@ -0,0 +1,3049 @@ +;;- 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. + +;; 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) + + +;; .................... +;; +;; 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")]) + + +;; +;; .................... +;; +;; 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")]) + +;; +;; +;; 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; +}") + + +;; .................... +;; +;; 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; +}") + + +;; +;; .................... +;; +;; 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; +}") + + + +;; +;; ******************* +;; +;; 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; +}") + +;; +;; .................... +;; +;; 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; +}") + + + +;; +;; ******************** +;; +;; 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")]) + + +;; +;; 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); }") + + +;; 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; +}") + + +;; +;; 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")]) + +;; +;; 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 \"}\"; + } +}") + + + +;; +;; 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\"; + } +}") + + +;; +;; 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")]) + + + +;; 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 \"}\"; + } +}") + + + + +(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")]) + +;; +;; 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")]) + +;; +;; 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")]) + +;; +;; 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") diff --git a/gcc/config/i370/README b/gcc/config/i370/README new file mode 100644 index 00000000000..56c6342dc64 --- /dev/null +++ b/gcc/config/i370/README @@ -0,0 +1,125 @@ + +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 + + + + + + diff --git a/gcc/config/i370/i370-c.c b/gcc/config/i370/i370-c.c new file mode 100644 index 00000000000..fe39191cfa2 --- /dev/null +++ b/gcc/config/i370/i370-c.c @@ -0,0 +1,64 @@ +/* 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 diff --git a/gcc/config/i370/i370-protos.h b/gcc/config/i370/i370-protos.h new file mode 100644 index 00000000000..666db0b7aa6 --- /dev/null +++ b/gcc/config/i370/i370-protos.h @@ -0,0 +1,55 @@ +/* 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 */ diff --git a/gcc/config/i370/i370.c b/gcc/config/i370/i370.c new file mode 100644 index 00000000000..2cfe4fe3269 --- /dev/null +++ b/gcc/config/i370/i370.c @@ -0,0 +1,1514 @@ +/* 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 */ +/* ===================================================== */ + + +/* 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; + +/* 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; + } +} diff --git a/gcc/config/i370/i370.h b/gcc/config/i370/i370.h new file mode 100644 index 00000000000..5d7037f4902 --- /dev/null +++ b/gcc/config/i370/i370.h @@ -0,0 +1,1863 @@ +/* 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< */ + 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 */ + 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 */ + 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")] +) diff --git a/gcc/config/i370/linux.h b/gcc/config/i370/linux.h new file mode 100644 index 00000000000..f402fbde9f3 --- /dev/null +++ b/gcc/config/i370/linux.h @@ -0,0 +1,113 @@ +/* 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 */ diff --git a/gcc/config/i370/mvs.h b/gcc/config/i370/mvs.h new file mode 100644 index 00000000000..dfb4cba188a --- /dev/null +++ b/gcc/config/i370/mvs.h @@ -0,0 +1,49 @@ +/* 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 diff --git a/gcc/config/i370/oe.h b/gcc/config/i370/oe.h new file mode 100644 index 00000000000..088c043530e --- /dev/null +++ b/gcc/config/i370/oe.h @@ -0,0 +1,53 @@ +/* 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) + diff --git a/gcc/config/i370/t-i370 b/gcc/config/i370/t-i370 new file mode 100644 index 00000000000..fccd1632fde --- /dev/null +++ b/gcc/config/i370/t-i370 @@ -0,0 +1,3 @@ +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 diff --git a/gcc/config/i960/i960-c.c b/gcc/config/i960/i960-c.c new file mode 100644 index 00000000000..6c1199e352e --- /dev/null +++ b/gcc/config/i960/i960-c.c @@ -0,0 +1,117 @@ +/* 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; +} diff --git a/gcc/config/i960/i960-coff.h b/gcc/config/i960/i960-coff.h new file mode 100644 index 00000000000..465ea33cc3e --- /dev/null +++ b/gcc/config/i960/i960-coff.h @@ -0,0 +1,43 @@ +/* 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 */ diff --git a/gcc/config/i960/i960-modes.def b/gcc/config/i960/i960-modes.def new file mode 100644 index 00000000000..e99939049c6 --- /dev/null +++ b/gcc/config/i960/i960-modes.def @@ -0,0 +1,33 @@ +/* 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); diff --git a/gcc/config/i960/i960-protos.h b/gcc/config/i960/i960-protos.h new file mode 100644 index 00000000000..269a40be19c --- /dev/null +++ b/gcc/config/i960/i960-protos.h @@ -0,0 +1,102 @@ +/* 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 */ diff --git a/gcc/config/i960/i960.c b/gcc/config/i960/i960.c new file mode 100644 index 00000000000..3d976b65fd4 --- /dev/null +++ b/gcc/config/i960/i960.c @@ -0,0 +1,2917 @@ +/* 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 +#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) + +/* 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; + +/* 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; + } +} + +/* 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); +} + +/* 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; +} + +/* 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 ""; +} + + +/* 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; +} + +/* 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; + } +} + +/* 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"; +} + +/* 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; +} + +/* 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)); +} + +/* 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; +} + +#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 + + +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 (); +} + + +/* 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); +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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; + } +} diff --git a/gcc/config/i960/i960.h b/gcc/config/i960/i960.h new file mode 100644 index 00000000000..67c34e25031 --- /dev/null +++ b/gcc/config/i960/i960.h @@ -0,0 +1,1404 @@ +/* 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 + +/* 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) + +/* 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 */ + +/* 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))) + +/* 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) + +/* 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 + +/* 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 + +/* 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 + +/* 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 + +/* 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) + +/* 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) + +/* 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 + +/* 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) + + +/* 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) == '+') + +/* 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; diff --git a/gcc/config/i960/i960.md b/gcc/config/i960/i960.md new file mode 100644 index 00000000000..ad1678a7077 --- /dev/null +++ b/gcc/config/i960/i960.md @@ -0,0 +1,2818 @@ +;;- 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. + +;; 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. + +;; 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) + +;; 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")]) + +;; 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")]) + +;; 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); }") + +;; 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")]) + +;; 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") + +;; 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; +}") + +;; 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")]) + +;; 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")]) + +;; 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; +}") + +;; 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")]) + +;; 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")]) + +;; 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")]) + +;; 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")]) + +;; 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)] + "" + "") + +;; 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") + +; 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") + +; 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)") diff --git a/gcc/config/i960/rtems.h b/gcc/config/i960/rtems.h new file mode 100644 index 00000000000..092b7920abf --- /dev/null +++ b/gcc/config/i960/rtems.h @@ -0,0 +1,29 @@ +/* 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) diff --git a/gcc/config/i960/t-960bare b/gcc/config/i960/t-960bare new file mode 100644 index 00000000000..9cbaa9f9065 --- /dev/null +++ b/gcc/config/i960/t-960bare @@ -0,0 +1,30 @@ +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 diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog new file mode 100644 index 00000000000..c93c5fe7ea0 --- /dev/null +++ b/gcc/f/ChangeLog @@ -0,0 +1,7315 @@ +2004-09-06 Release Manager + + * GCC 3.4.2 released. + +2004-09-02 Eric Botcazou + + 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 + + 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 + + * 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 + + * news.texi: Note that GCC 3.4.x is the last version + of GCC to contain g77. + +2004-05-18 Joseph S. Myers + + * bugs.texi, news.texi: Don't reference mainline versions. + +2004-05-16 Gerald Pfeifer + + * g77.texi (Floating-point Errors): Fix typo. + +2004-05-07 Gerald Pfeifer + + * 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 + + * g77.texi: Update link to "G++ and GCC". + +2004-03-14 Gerald Pfeifer + + * 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 + + * parse.c (ffe_parse_file): Handle the case that main_input_filename + is NULL. + +2004-02-24 Michael Matz + + * Make-lang.in (sta.o-warn): Delete. + * sta.c (ffesta_save_): Don't break aliasing rules. + +2004-02-20 Kazu Hirata + + * 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 + + PR fortran/14129 + * lex.c (ffelex_cfelex_): Avoid calling xrealloc on a local stack + allocated array. + +2004-01-30 Kelley Cook + + * Make-lang.in (doc/g77.dvi): Use $(abs_docdir). + +2004-01-20 Kelley Cook + + * 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 + + * Make-lang.in (G77_INSTALL_NAME): Define via a immediate $(shell) + instead of deferred backquote. + +2004-01-15 Kelley Cook + + * Make-lang.in (f77.srcextra): Dummy entry. + +2004-01-13 Ian Lance Taylor + + 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 + + * README: Remove. + +2004-01-07 Joseph S. Myers + + * com.h (ffecom_gfrt_basictype): Correct return type. + +2003-12-29 Roger Sayle + + 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 + + * Make-lang.in (G77_CROSS_NAME): Delete. + (g77.install_common, g77.install-man, g77.uninstall): Adjust for above. + +2003-11-30 Andreas Jaeger + + * Make-lang.in (f77.rebuilt): Fix dependency on g77.info. + +2003-11-24 Toon Moene + + 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 + + * .cvsignore: Delete. + +2003-11-20 Joseph S. Myers + + * Make-lang.in (f77.extraclean): Delete. + +2003-11-20 Joseph S. Myers + + * Make-lang.in (check-f77, lang_checks): Add. + +2003-11-16 Jason Merrill + + * 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 + + * intdoc.in (Signal Intrinsic (subroutine)): Fix texinfo warning + using @code. + * intdoc.texi: Regenerated. + +2003-11-03 Kelley Cook + + * 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 + + * com.c (ffecom_sym_transform_): Set tree type of offset + to ssizetype. + +2003-10-21 Kelley Cook + + * 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 + + * lex.c (ffelex_cfelex_): Initialize d. + +Mon Oct 20 23:15:46 2003 Mark Mitchell + + * Make-lang.in ($(docobjdir)/g77.info): Add dependency on + stmp-docobjdir. + +Mon Oct 20 13:49:43 2003 Mark Mitchell + + * 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 + + * 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 + + * 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 + + * com.c (duplicate_decls): Copy DECL_SOURCE_LOCATION, not + file and line separately. + +2003-09-21 Richard Henderson + + * com.c, ste.c: Revert. + +2003-09-21 Richard Henderson + + * com.c, ste.c: Update for DECL_SOURCE_LOCATION rename and + change to const. + +2003-09-21 Toon Moene + + * news.texi: Update with fixed PR's. + +2003-09-21 George Helffrich + + * g77.texi: Remove ancient part about debugging COMMON + and EQUIVALENCE not correctly. + +2003-09-18 Roger Sayle + + * com.c (ffecom_overlap_): Remove FFS_EXPR case. + (ffecom_tree_canonize_ref_): Likewise. + (ffe_truthvalue_conversion): Likewise. + +2003-09-01 Josef Zlomek + + * 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 + + * com.c (ffecom_init_0): Use `dconsthalf'. + +Sat Jul 19 12:03:03 2003 Kaveh R. Ghazi + + * 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 + + * lang-options.h: Remove. + * lang.opt: Document most options. + +2003-07-14 Geoffrey Keating + + * lang-specs.h (f77-cpp-input): Use -o to specify the CPP output file. + +2003-07-10 Toon Moene + + * ffe.texi: Correctly use @var{srcdir}. + +2003-07-09 Toon Moene + + PR Fortran/11301 + * com.c (ffecom_sym_transform_): finish_decl should have + the same last argument as start_decl. + +2003-07-08 Rainer Orth + + * Make-lang.in (f/g77.dvi): Use PWD_COMMAND. + +2003-07-08 Zack Weinberg + + * lex.c: Remove error block #ifdef MAP_CHARACTER. + +Mon Jul 7 18:13:22 2003 Nathan Sidwell + + * 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 + + * 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 + + * top.c (ffe_handle_option): Don't handle filenames. + +2003-07-05 Toon Moene + + 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 + + * top.c (ffe_init_options): Update prototype. + * top.h (ffe_init_options): Update prototype. + +2003-06-27 Zack Weinberg + + * com.c (input_file_stack_tick): Delete redundant declaration. + +Thu Jun 26 07:06:29 2003 Neil Booth + + * top.c (ffe_handle_option): Don't check for missing arguments. + +Wed Jun 25 06:52:12 2003 Neil Booth + + * top.c (ffe_handle_option): Add missing break;. + +2003-06-24 Scott Snyder + + 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 + + * lang.opt: Add -fpreprocessed. + * top.c (ffe_handle_option): Handle it. + +Fri Jun 20 10:00:31 2003 Nathan Sidwell + + * com.c (finish_function): Adjust expand_function_end call. + +2003-06-17 Nathanael Nerode + + * Make-lang.in: Replace BUILD_CC references with CC_FOR_BUILD. + +Sun Jun 15 15:56:51 2003 Neil Booth + + * lang.opt: Declare F77. + +Sat Jun 14 18:13:00 2003 Nathan Sidwell + + * com.c (stor_parm_decls): Adjust init_function_start call. + +Sat Jun 14 13:25:00 2003 Neil Booth + + * 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 + + 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 + + * 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 + + * 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 + + * Make-lang.in: Update. + * top.c: Include opts.h. Define cl_options_count and cl_options. + +2003-06-07 Andreas Jaeger + + * 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 + + * com.c (ffe_init_options): Update. + +Thu Jun 5 18:33:40 CEST 2003 Jan Hubicka + + * Make-lang.in: Add support for stageprofile and stagefeedback + +2003-06-04 Andreas Jaeger + + * g77spec.c (lang_specific_driver): Remove ALT_LIBM usage. + +2003-06-01 Bud Davis + + * ste.c (ffeste_R838): Handle ERROR_MARK. + (ffeste_R839): Ditto. + +2003-06-01 Andreas Jaeger + + * 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 + + PR fortran/10843 + * sta.c (ffesta_second_): Parse GO TO correctly, + even in free source format. + +2003-05-31 Andreas Jaeger + + * 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 + + * 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 + + * com.c (ffecom_sym_transform_): Error out on unallocatable + storage after type is set. + +2003-05-18 Toon Moene + + * 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 + + * g77.texi: Remove most of the of the preface of the + bugs section. + +2003-05-15 Wolfgang Bangerth + + * g77.texi: Remove most of the bug reporting instructions and + merge them into bugs.html. + +2003-05-13 Zack Weinberg + + * 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 + + * bad.c: Don't call diagnostic_count_diagnostic. + +2003-05-12 Roger Sayle + + * 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 + + 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 + + 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 + + * 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 + + * ansify.c (die_unless): Revert lineno change here. + +2003-05-02 Nathan Sidwell + + * lex.c (ffelex_file_pop_): Adjust file_stack member use. + (ffelex_file_push_): Likewise. + (ffelex_hash_): Likewise. + +2003-05-01 Nathan Sidwell + + * 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 + + PR c/10375 + * com.c (duplicate_decls): Preserve "const" and "noreturn" + function attributes. + +2003-04-13 Roger Sayle + + * com.c (duplicate_decls): Preserve pure and malloc attributes. + +2003-04-12 Zack Weinberg + + * 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 + + 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 + + * ffe.texi: Don't mention dead file proj.c. + +2003-03-26 Roger Sayle + + 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 + + PR fortran/10204 + * ffe.texi: Reference the GCC web site in the URL. + +2003-03-24 Toon Moene + + PR fortran/10197 + * news.texi: Document PR fortran/10197 fixed. + +Sun Mar 23 23:43:45 2003 Mark Mitchell + + PR c++/7086 + * com.c (ffecom_sym_transform_): Adjust calls to + put_var_into_stack. + (ffe_mark_addressable): Likewise. + +2003-03-22 Bud Davis + + * 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 + + * 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 + + * f/ste.c (ffeste_R810): Fix whitespace. + +2003-03-15 Andreas Jaeger + + * g77spec.c (DEFAULT_SWITCH_TAKES_ARG): Remove. + (DEFAULT_WORD_SWITCH_TAKES_ARG): Remove. + +2003-03-12 Nathanael Nerode + + * g77.texi, invoke.texi, g77spec.c, lang-specs.h: GCC, not + GNU CC. Especially here. + +2003-03-10 Roger Sayle + + * com.c (duplicate_decls): Synchronize with C's duplicate_decls. + +Sat Mar 8 21:11:40 2003 Neil Booth + + * com.c (ffe_init): Update prototype; move code to ffe_post_options. + (ffe_post_options): New. + +2003-03-04 Tom Tromey + + * Make-lang.in (f77.tags): New target. + +2003-02-20 Toon Moene + + * news.texi: Document fixing PR fortran/9038. + +2003-02-04 Joseph S. Myers + + * g77.texi, invoke.texi: Update to GFDL 1.2. + +2003-01-31 Toon Moene + + * news.texi: Document fixing PR fortran/7681 + and optimization/9258. + +2003-01-26 Toon Moene + + * 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 + + Make-lang.in (f/sta.o-warn): Add -Wno-error. + +Thu Jan 16 10:53:16 2003 Kaveh R. Ghazi + + * 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 + + * 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 + + * 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 + + * news.texi: Revise history again: + PR Fortran/9038 will be fixed in 3.4. + +2003-01-05 Toon Moene + + * news.texi: Update news to reflect reality: + PR Fortran/9038 won't be fixed until 3.4. + +2003-01-04 Toon Moene + + PR Fortran/9038 + * lang-specs.h: Remove -f options before preprocessing. + * news.texi: Document fixing of PR Fortran/9038. + +2003-01-03 Bud Davis + + * 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 + + * f/Make-lang.in ($(srcdir)/f/BUGS): Add include path for + gcc-common.texi. + ($(srcdir)/f/NEWS): Likewise. + +2002-12-28 Joseph S. Myers + + * g77.texi: Use @copying. + +2002-12-23 Joseph S. Myers + + * 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 + + * intdoc.in: Fix typos. + +2002-12-18 Kazu Hirata + + * g77.texi: Fix typos. + * intdoc.texi: Likewise. + * news.texi: Follow spelling conventions. + +Mon Dec 16 13:53:18 2002 Mark Mitchell + + * root.texi: Change version number to 3.4. + +2002-12-15 Zack Weinberg + + * target.h: Don't define HOST_WIDE_INT. + +2002-12-02 Nathanael Nerode + + * 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 + + * proj.h, ansify.c, g77spec.c, intdoc.c: + Include coretypes.h and tm.h. + * Make-lang.in: Update dependencies. + +2002-11-20 Toon Moene + + * invoke.texi: Explain the purpose of -fmove-all-movables, + -freduce-all-givs and -frerun-loop-opts better. + +2002-11-19 Nathanael Nerode + + * Make-lang.in: Correct BUILD/HOST confusion. + +2002-11-19 Toon Moene + + PR fortran/8587 + * news.texi: Show PR fortran/8587 fixed. + +2002-11-19 Jason Thorpe + + * g77spec.c (lang_specific_spec_functions): New. + +2002-11-02 Toon Moene + + * 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 + + * 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 + + * lang-specs.h: Fix ratfor specs. + +2002-10-15 Richard Henderson + + * target.h (ffetarget_print_real1, ffetarget_print_real2): Use + real_to_decimal directly, and with the new arguments. + +2002-09-23 Zack Weinberg + + * 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 + + * 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 + + * com.c (union lang_tree_node): Add chain_next option. + +2002-09-16 Richard Henderson + + * 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 + + * intdoc.texi: Regenerate. + +2002-09-15 Kazu Hirata + + * ChangeLog: Follow spelling conventions. + * intdoc.in: Likewise. + +2002-09-09 Gerald Pfeifer + + 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 + + * com.c (ffe_type_for_mode): Handle long double. + +2002-09-04 Richard Henderson + + * target.h (ffetarget_print_real1, ffetarget_print_real2): Update + call to REAL_VALUE_TO_DECIMAL. + +2002-08-31 Toon Moene + + * 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 + + * 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 + + * target.h (FFETARGET_32bit_longs): Don't define for powerpc64 or + mmix. + +2002-08-28 Joseph S. Myers + + * bugs.texi, news.texi: Update URLs for online news and bugs + lists. + +2002-08-22 Hans-Peter Nilsson + + * 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 + + * where.c (ffewhere_track): Remove impossible if-then clause. + +Thu Aug 8 10:06:14 2002 Nathan Sidwell + + * f/Make-lang.in (f.mostlyclean): Remove coverage files. + +2002-08-06 Gerald Pfeifer + + * g77.texi (Top): Rename Index to Keyword Index. + +2002-08-05 Toon Moene + + * invoke.texi: Improve description of + -fno-finite-math-only flag. + +Sun Aug 4 16:45:49 2002 Joseph S. Myers + + * root.texi (version-gcc): Increase to 3.3. + +2002-07-30 Toon Moene + + * 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 + + * com.c (read_name_map): Use concat in lieu of xmalloc/strcpy. + +2002-07-25 Toon Moene + + * news.texi: Document better handling of (no-)alias + information of dummy arguments and induction variables + on loop unrolling. + +2002-07-01 Roger Sayle + + * 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 + + * 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 + + * lang-specs.h: Use cc1 for traditional preprocessing. + +2002-06-20 Andreas Jaeger + + * com.c (ffecom_prepare_expr_,ffecom_expr_power_integer_): + Remove #ifdefed HAHA sections. + +2002-06-20 Nathanael Nerode + + * com.c: Remove #ifdef HOHO sections. + +2002-06-17 Jason Thorpe + + * bit.c: Don't include glimits.h. + * target.c: Likewise. + * where.h: Likewise. + +2002-06-12 Gabriel Dos Reis + + * bad.c (ffebad_start_): Adjust calls to diagnostic_count_error. + +2002-06-04 Gabriel Dos Reis + + * 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 + + * 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 + + * lang-specs.h: Use cpp_debug_options. + +2002-05-28 Zack Weinberg + + * bld.c, com.c, expr.c, target.c: Include real.h. + * Make-lang.in: Update dependency lists. + +2002-05-16 Rainer Orth + + * Make-lang.in: Allow for PWDCMD to override hardcoded pwd. + +2002-05-09 Hassan Aurag + + * expr.c (ffeexpr_reduced_ugly2log_): Allow logicals-as-integers + under -fugly-logint as arguments of .and., .or., .xor. + +2002-05-07 Jan Hubicka + + * target.h (FFETARGET_32bit_longs): Undefine for x86-64. + +2002-04-29 Joseph S. Myers + + * 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 + + * com.h (ffe_parse_file): Update. + * lex.c (ffe_parse_file): Update. + +2002-04-20 Toon Moene + + * root.texi: Remove variable version-g77. + * g77.texi: Remove the single use of that variable. + +Thu Apr 18 19:10:44 2002 Neil Booth + + * com.c (incomplete_type_error): Remove. + +Tue Apr 16 14:55:47 2002 Mark Mitchell + + * 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 + + * g77.texi: Remove Chill reference. + +2002-04-13 Toon Moene + + * news.texi: Deprecate frontend version number; + update list of fixed bugs. + +2002-04-08 Hans-Peter Nilsson + + * 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 + + * 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 + + * com.c (LANG_HOOKS_MARK_ADDRESSABLE): Redefine. + (mark_addressable): Rename. + (ffecom_arrayref_, ffecom_1): Update. + +Mon Apr 1 09:59:53 2002 Neil Booth + + * 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 + + * 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 + + * 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 + + * invoke.texi (Warning Options): Mention -Wswitch-enum. + Fix PR c/5044. + +Tue Mar 26 07:30:51 2002 Neil Booth + + * 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 + + * com.c (maybe_build_cleanup): Remove. + +2002-03-23 Toon Moene + + * 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 + + * invoke.texi (Warning Options): Mention -Wswitch-default. + +Thu Mar 21 18:55:41 2002 Neil Booth + + * cp-tree.h (pushdecl, pushlevel, poplevel, set_block, + insert_block, getdecls, global_bindings_p): New. + +Wed Mar 20 08:03:42 2002 Neil Booth + + * 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 + + * com.h (ffe_parse_file): Prototype. + +Sun Mar 17 20:57:30 2002 Neil Booth + + * 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 + + * com.c (tree_code_type, tree_code_length, tree_code_name): + Define. + +Sun Mar 10 12:37:42 2002 Kaveh R. Ghazi + + * target.c (ffetarget_print_hex): Const-ify. + +2002-03-06 Phil Edwards + + * version.c: Fix misplaced leading blanks on first line. + +2002-03-03 Zack Weinberg + + * 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 + + * com.c (copy_lang_decl): Delete. + +2002-02-27 Zack Weinberg + + * 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 + + * news.texi: List Problem Reports fixed in 3.1. + +2002-02-13 Toon Moene + + * 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 + + * data.c (ffedata_eval_offset_): Convert non-default integer + constants to default integer kind if necessary. + +2002-02-09 Toon Moene + + * invoke.texi: Add a short debugging session + as an example to the documentation of -g. + +2002-02-06 Toon Moene + + 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 + + * implic.c lex.c stb.c ste.c stu.c: Update copyright dates. + +2002-02-04 Philipp Thomas + + * 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 + + * expr.c (ffeexpr_sym_impdoitem_): Allow other than + default INTEGER implied-do loop counts. + +2002-02-01 Toon Moene + + * 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 + + * g77spec.c (lang_specific_driver): Follow GNU Coding Standards + for --version. + +2002-01-30 Richard Henderson + + * ste.c (ffeste_begin_iterdo_): Use expand_exit_loop_top_cond. + (ffeste_R819B): Likewise. + +2002-01-30 Toon Moene + + * intrin.c (upcasecmp_): New function. + (ffeintrin_cmp_name_): Use it to correctly compare name + and table entry for bsearch. + +2002-01-26 Toon Moene + + * intrin.c (ffeintrin_cmp_name_): Correct comparison + for intrinsics in intrinsic table (intrin.def). + +2002-01-22 Zack Weinberg + + * 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 + + 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 + + * g77spec.c (lookup_option): Handle -fversion. + (lang_specific_driver): Update copyright date in --version output. + +Mon Jan 7 00:03:42 2002 Gerald Pfeifer + + * 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 + + * 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 + + * 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 + + * bld.c (ffebld_arity_op_): Declare array size explicitly. + * bld.h (ffebld_arity_op_): Likewise. + +2001-12-20 Joseph S. Myers + + * config-lang.in (diff_excludes): Remove. + +2001-12-17 Joseph S. Myers + + * g77.texi, invoke.texi: Update links to GCC manual. + +Sun Dec 16 16:08:57 2001 Joseph S. Myers + + * news.texi: Fix spelling errors. + +Sun Dec 16 10:36:51 2001 Kaveh R. Ghazi + + * 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 + + * 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 + + * 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 + + * g77.texi: Don't condition menus on @ifinfo. + +Wed Dec 5 06:49:21 2001 Richard Kenner + + * com.c (ffecom_1): Properly handle TREE_READONLY for INDIRECT_REF. + +Mon Dec 3 18:56:04 2001 Neil Booth + + * com.c: Remove leading capital from diagnostic messages, as + per GNU coding standards. + * g77spec.c: Similarly. + * lex.c: Similarly. + +2001-12-01 Zack Weinberg + + * f/fini.c: Use xmalloc. + +Fri Nov 30 20:54:02 2001 Kaveh R. Ghazi + + * Make-lang.in: Delete references to proj.[co], proj-h.[co]. + * proj.c: Delete file. + +2001-11-29 Zack Weinberg + + * 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 + + * 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 + + PR fortran/3957 + * lang-specs.h: Correct !pipe conditional in tradcpp0 invocation. + +2001-11-21 Toon Moene + + * 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 + + * Make-lang.in: Complete ``Build g77.1 in $(srcdir)''. + +2001-11-19 Geoffrey Keating + + * 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 + + * .cvsignore: Ignore g77.1 + * g77.texi: Substitute `@command' for `@code' + where appropriate. + * invoke.texi: Ditto. + +2001-11-18 Toon Moene + + * 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 + + * com.c (finish_parse): Remove. + (ffe_finish): Move body of finish_parse. + +Thu Nov 15 10:06:38 2001 Neil Booth + + * 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 + + * g77.texi: Update to use `@command', `@option. + * invoke.texi: Ditto + +2001-11-14 Joseph S. Myers + + * Make-lang.in: Change all uses of $(manext) to $(man1ext). + +2001-11-14 Toon Moene + + * 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 + + * 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 + + * 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 + + * com.c (language_string, lang_identify): Remove. + (struct lang_hooks): Constify. + (LANG_HOOKS_NAME): Override. + (init_parse): Update. + +2001-11-08 Andreas Franck + + * Make-lang.in (G77_INSTALL_NAME, G77_CROSS_NAME): Handle + program_transform_name the way suggested by autoconf. + +2001-11-08 Toon Moene + + * 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 + + * com.c: Include langhooks-def.h. + * Make-lang.in: Update. + +2001-11-04 Toon Moene + + * 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 + + * 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 + + * news.texi: Document new ability to compile programs with + arrays larger than 512 Mbyte on 32-bit targets. + +2001-10-24 Toon Moene + + * com.c (ffecom_check_size_overflow_): Only check for TREE_OVERFLOW. + +Tue Oct 23 14:01:27 2001 Richard Kenner + + * com.c (LANG_HOOKS_GET_ALIAS_SET): New macro. + (lang_get_alias_set): Delete. + +2001-10-23 Joseph S. Myers + + * g77.texi (Sending Patches): Remove. + +2001-10-22 Zack Weinberg + + * Make-lang.in (f/intdoc): Depend on safe-ctype.o. + +Sun Oct 21 17:28:17 2001 Kaveh R. Ghazi + + * 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 + + * target.h (FFETARGET_32bit_longs): Don't define + for 64-bit hppa. + +2001-10-17 Richard Henderson + + * std.c (ffestd_labeldef_format): Fix variable/stmt ordering. + (ffestd_R737A): Likewise. + +2001-10-17 Richard Henderson + + * 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 + + * 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 + + * 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 + + * 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 + + * Make-lang.in: Remove reference to FORTRAN_INIT. + * g77spec.c: Add reference to FORTRAN_INIT. + +2001-09-29 Juergen Pfeifer + + 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 + + * expr.c (ffeexpr_sym_rhs_dimlist_): Allow array elements + as bounds of adjustable arrays. + +Thu Sep 20 15:05:20 JST 2001 George Helffrich + + * 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 + + * 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 + + * 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 + + * parse.c (finput): Mark extern. + +2001-09-11 Jakub Jelinek + + * com.c (ffe_init_options): Default to -fmerge-all-constants + if optimizing. + +2000-08-14 Ulrich Weigand + + * target.h (FFETARGET_32bit_longs): Don't define + for 64-bit S/390. + +2001-07-20 Toon Moene + + * 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 + + * top.c (ffe_decode_option): Disallow lang-independent processing + for -ffixed-form. + +2001-07-19 Toon Moene + + * 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 + + * com.c (lang_print_error_function): Argument context + is unused. + +2001-07-14 Tim Josling + + * com.c (ffecom_overlap_): Remove references to EXPON_EXPR. + (ffecom_tree_canonize_ref_): Likewise. + +2001-07-10 James Smaby + + * intdoc.in: Fix the definition of COMPLEX ABS. + Remove `the' where inappropriate. + * intdoc.texi: Rebuilt. + +2001-07-04 Joseph S. Myers + + * 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 + + * 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 + + * BUGS: Remove. + * NEWS: Likewise. + +2001-06-10 Toon Moene + + * 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 + + * root.texi: Fix typo in patches e-mail address. + +2001-06-03 Toon Moene + Jan van Male + + * 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 + + * g77.texi: Move contents to just after title page. + +2001-06-02 Toon Moene + + * com.c (ffecom_init_0): Make CHARACTER*1 unsigned. + +2001-05-23 Theodore Papadopoulo + + * 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 + + * 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 + + * 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 + + * 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 + + * Make-lang.in (f/g77.dvi): Include $(srcdir) in TEXINPUTS. + +2001-05-19 Toon Moene + + * 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 + + * Make-lang.in: Replace all uses of `touch' with $(STAMP). + +Wed May 2 10:20:08 2001 Kaveh R. Ghazi + + * com.c: NULL_PTR -> NULL. + +Sun Apr 22 20:18:01 2001 Kaveh R. Ghazi + + * com.c (ffecom_subscript_check_): Use concat in lieu of + xmalloc/sprintf. + +2001-04-21 Toon Moene + + * news.texi: Update release information for 0.5.27. + +Thu Apr 19 12:49:24 2001 Mark Mitchell + + * 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 + + * bad.c (inhibit_warnings): Delete redundant declaration. + + * com.c (skip_redundant_dir_prefix): Likewise. + + * com.h (mark_addressable): Likewise. + +2001-04-02 Jakub Jelinek + + * lex.c (ffelex_hash_): Avoid eating one whole line after + #line. + +Mon Apr 2 22:38:09 2001 Toon Moene + + * 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 + + * Make-lang.in: Depend on $(SYSTEM_H), not system.h. + +Mon Mar 26 18:13:30 2001 Mark Mitchell + + * com.c (duplicate_decls): Don't copy DECL_FRAME_SIZE. + +Mon Mar 19 15:05:39 2001 Mark Mitchell + + * com.c (builtin_function): Use SET_DECL_ASSEMBLER_NAME. + +Wed Mar 14 09:29:27 2001 Mark Mitchell + + * 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 + + * fini.c (main): Use really_call_malloc, not malloc. + +Thu Mar 8 13:27:47 2001 Kaveh R. Ghazi + + * com.c: Don't rely on the POSIX macro to define autoconf stuff. + +2001-03-07 Brad Lucier + + * g77.texi: Document new options -funsafe-math-optimizations + and -fno-trapping-math. Revise documentation for -ffast-math. + +2001-03-01 Zack Weinberg + + * 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 + + * lang-specs.h: Add zero initializer for cpp_spec field to all + array elements. + +2001-02-24 Zack Weinberg + + * com.c: Don't define STDC_HEADERS, autoconf handles it. + +Fri Feb 23 15:28:39 2001 Richard Kenner + + * com.c (set_block): Set NAMES and BLOCKS from BLOCK. + +2001-02-19 Joseph S. Myers + + * 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 + + * 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 + + * Make-lang.in: Remove all dependencies on defaults.h. + * com.c: Don't include defaults.h. + +2001-01-23 Michael Sokolov + + * com.c: Don't explicitly include any time headers, the right ones are + already included by proj.h. + +2001-01-15 Mark Mitchell + + * 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 + + * g77spec.c (lang_specific_driver): Update copyright year to 2001. + +Wed Jan 10 14:39:45 2001 Mark Mitchell + + * 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 + + * 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 + + * g77install.texi: Adjust wording of an EGCS reference. + +Thu Dec 21 20:00:48 2000 Joseph S. Myers + + * BUGS, NEWS: Regenerate. + +2000-12-18 Joseph S. Myers + + * com.c [VMS]: Remove definition of BSTRING. + +2000-12-18 Joseph S. Myers + + * g77.texi: Update GPL copy not to refer to years 19@var{yy}. + +2000-12-18 Toon Moene + + * bugs.texi: Correct copyright years. + * g77.texi: Likewise. + * news.texi: Likewise. + +2000-12-18 Joseph S. Myers + + * 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 + + * .cvsignore: New file; add info files. + +2000-12-08 Joseph S. Myers + + * 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 + + * 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 + + * com.c (ffecom_member_phase2_): Set TREE_USED on the debugging decl. + +2000-11-26 Joseph S. Myers + + * 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 + + * g77spec.c (lang_specific_driver): Update copyright year to 2000. + +Thu Nov 23 02:18:57 2000 J"orn Rennecke + + * Make-lang.in (g77spec.o): Depend on $(CONFIG_H). + +2000-11-21 David Billinghurst + + * 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 + + * g77.texi (Floating-point precision): Adjust example + to work with glibc (>= 2.1). + +Sat Nov 18 13:54:49 2000 Matthias Klose + + * g77.texi (Floating-point Exception Handling): Adjust + example to work with glibc (>= 2.1). + +2000-11-18 Alexandre Oliva + + * 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 + + * lex.c (ffelex_hash_): Change ggc_alloc_string (var, -1) to + ggc_strdup (var). + +Thu Nov 16 23:14:07 2000 Kaveh R. Ghazi + + * malloc.c (malloc_init): Call xmalloc, not malloc. + +2000-11-10 Rodney Brown + + * Make-lang.in: Remove OUTPUT_OPTION from g77version.o target. + +2000-11-10 Toon Moene + + * root.texi: Remove non-historical EGCS reference. + Set current g77 version to 0.5.26. + +2000-11-10 Toon Moene + + * com.c (ffecom_stabilize_aggregate_) case RTL_EXPR: Abort. + +2000-11-10 Zack Weinberg + + * 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 + + * root.texi, news.texi, g77install.texi, g77.texi, bugs.texi: + Remove non-historical references to egcs/EGCS. + +2000-11-05 Joseph S. Myers + + * Make-lang.in: Remove f77.distdir and f/INSTALL. + * INSTALL, install0.texi: Remove. + +2000-11-02 Joseph S. Myers + + * com.c (open_include_file, ffecom_open_include_): Use strchr () + and strrchr () instead of index () and rindex (). + +2000-10-27 Zack Weinberg + + * 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 + + * Makefile.in, g77spec.c: Remove EGCS references in comments. + +Thu Oct 12 22:28:51 2000 Mark Mitchell + + * 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 + + * com.c (finish_function): Don't init can_reach_end. + +Sun Oct 1 11:43:44 2000 Mark Mitchell + + * com.c (lang_mark_false_label_stack): Remove. + +2000-09-10 Zack Weinberg + + * com.c: Include defaults.h. + * com.h: Don't define the *_TYPE_SIZE macros. + * Makefile.in: Update dependencies. + +2000-08-29 Zack Weinberg + + * ansify.c: Use #line, not # . + +2000-08-24 Greg McGary + + * 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 + + * 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 + + * 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 + + * lang-specs.h: Pass -I* options to f771. + +2000-08-19 Toon Moene + + * 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 + + * bugs.texi: Describe new ability to emit debug info + for EQUIVALENCE members. + * news.texi: Ditto. + +2000-08-11 G. Helffrich + Toon Moene + + * 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 + + * g77spec.c (lang_specific_driver): Clearer g77 version message. + +2000-08-04 Zack Weinberg + + * 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 + + * 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 + + * lang-specs.h: Rename cpp to cpp0 and/or tradcpp to tradcpp0. + +Thu Jul 27 11:50:08 2000 Kaveh R. Ghazi + + * fini.c (main): Avoid automatic aggregate initialization. + + * proj.h: Indent #error directive. + +2000-07-26 Toon Moene + + * lang-specs.h: Remove one /dev/null from tradcpp invocation. + +Sun Jul 23 15:47:30 2000 Billinghurst, David + + * Make-lang.in: Put $(build_exeext) suffix on programs which run + on the build machine. + +2000-07-22 Toon Moene + + * com.c (ffecom_expr_intrinsic_): case FFEINTRIN_impFGETC_subr, + FFEINTRIN_impFPUTC_subr: Check for arg3 being NULL. + +2000-07-13 Zack Weinberg + + * lang-specs.h: Use the new named specs. Remove unnecessary braces. + +2000-07-02 Toon Moene + + * version.c: Bump version number. + +2000-06-21 Zack Weinberg + + * 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 + + * ste.c (gbe_block): Constify. + +2000-06-13 Jakub Jelinek + + * 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 + + * com.c (lang_get_alias_set): Mark parameter with ATTRIBUTE_UNUSED. + +2000-06-04 Philipp Thomas + + * Makefile.in(INTLLIBS): New macro. + (LIBS): Add INTLLIBS. + (DEPLIBS): Likewise. + +2000-06-02 Richard Henderson + + * com.c (lang_get_alias_set): New. + +2000-05-28 Toon Moene + + * bugs.texi: Note that debugging information for + common block items is emitted now. + * news.texi: Ditto. + +2000-05-18 Chris Demetriou + + * 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 + + * top.c (ffe_decode_option): Update -Wall unused flags by calling + set_Wunused. + +2000-05-09 Zack Weinberg + + * 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 + + * 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 + + * lex.c: Remove references to cccp.c. + * g77install.texi: Remove references to cexp.c/cexp.y. + +2000-04-15 David Edelsohn + + * target.h (FFETARGET_32bit_longs): Define for 64-bit PowerPC + as well. + +Wed Apr 12 15:15:26 2000 Mark Mitchell + + * 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 + + * Makefile.in (GGC_H): Add varray.h. + +2000-04-03 Zack Weinberg + + * lang-specs.h: Pass -fno-show-column to the preprocessor. + +2000-03-28 Franz Sirl + + * 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 + + * com.c (ffecom_tree_canonize_ptr_): Use bitsize_zero_node. + (ffecom_tree_canonize_ref_): Likewise. + +Mon Mar 20 15:49:40 2000 Jim Wilson + + * 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 + + * com.c (ffecom_stabilize_aggregate_): Don't refer to TREE_RAISES. + +Mon Mar 6 18:05:19 2000 Richard Kenner + + * 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 + + * 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 + + * com.c (current_function_decl): Move to toplev.c. + +Sun Feb 27 16:40:33 2000 Richard Kenner + + * 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 + + * 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 + + * 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 + + * g77spec.c (lang_specific_driver): Use GCCBUGURL. + +2000-02-17 Andy Vaught + + * 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 + + * Make-lang.in (g77spec.o): Depend on $(GCC_H), not gcc.h. + +2000-02-15 Jonathan Larmour + + * lang-specs.h: Add new __GNUC_PATCHLEVEL__ define to default spec. + +Tue Feb 15 11:14:17 2000 Kaveh R. Ghazi + + * g77spec.c: Don't declare `version_string'. + +Sat Feb 5 23:27:25 2000 Kaveh R. Ghazi + + * com.c (mark_tracker_head, mark_binding_level): Protoize. + + * where.c (mark_ffewhere_head): Likewise. + +Wed Jan 12 09:32:59 2000 Zack Weinberg + + * lang-specs.h: Pass -lang-fortran to preprocessor. + +Thu Dec 30 13:14:31 1999 Richard Henderson + + * stw.h (struct _ffestw_): Change type of uses_ to int. + +Thu Dec 30 11:42:05 1999 Geoff Keating + + * 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 + + * g77.texi (C Interfacing Tools): Fix an incorrect link. + +1999-12-13 Jakub Jelinek + + * target.h: Handle sparc64 the same way as alpha. + +Sun Nov 28 21:39:05 1999 Kaveh R. Ghazi + + * 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 + + * 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 + Kaveh R. Ghazi + + * proj.h: Test `GCC_VERSION', not `HAVE_GCC_VERSION'. + +Tue Oct 26 01:32:19 1999 Mark Mitchell + + * com.c (poplevel): Don't call remember_end_note. + +Fri Oct 15 15:18:12 1999 Greg McGary + + * 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 + + * 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 + + * 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 + + * g77spec.c (lang_specific_driver): Initialize return value. + +Thu Sep 16 18:07:11 1999 Kaveh R. Ghazi + + * 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 + + * g77spec.c (lang_specific_driver): Remove unnecessary argument in + call to function `fatal'. + +Sun Sep 12 23:29:47 1999 Kaveh R. Ghazi + + * 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 + + * 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 + + * 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 + + * com.c (language_string): Constify. + +Mon Aug 30 20:29:30 1999 Kaveh R. Ghazi + + * 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 + + * com.c (lang_printable_name): Constify a char*. + +Wed Aug 25 01:21:06 1999 Rainer Orth + + * lang-specs.h: Pass cc1 spec to f771. + +Mon Aug 9 19:44:08 1999 Kaveh R. Ghazi + + * 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 + + * com.c (ptr_type_node, va_list_type_node): New. + (ffecom_init_0): Init and use ptr_type_node. + +1999-07-17 Alexandre Oliva + + * 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 + + * 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 + + * news.texi: Describe DATE intrinsic fix. + +Mon Jun 28 21:44:19 1999 Craig Burley + + * version.c: Denote experimental version. + +Mon Jun 28 10:43:11 1999 Craig Burley + + * 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 + + * 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 + + * bugs.texi: Describe K(5)=10*3 NAMELIST-read bug. + +Mon Jun 21 12:40:17 1999 Gerald Pfeifer + + * 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 + + * news.texi: Doc TtyNam fix. + +Fri Jun 18 11:26:50 1999 Craig Burley + + * news.texi: New heading for development version. + Doc upgrade to netlib libf2c as of today. + +Wed Jun 16 11:43:02 1999 Craig Burley + + * news.texi: Mention BACKSPACE fix to libg2c. + +Mon Jun 7 08:42:40 1999 Craig Burley + + * Make-lang.in: Any target using libsubdir must depend + on installdirs. + +Sat Jun 5 23:50:36 1999 Craig Burley + + * g77.texi: Describe a few more missing features people + have emailed me about. + +Sat Jun 5 17:03:23 1999 Craig Burley + + 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 + + * Make-lang.in: Use libsubdir, not prefix, to store + temporary lang-f77 `flag' file. + +Fri Jun 4 10:26:04 1999 Craig Burley + + * 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 + + * g77.texi (Missing Features): Add `Better Warnings' + item. + +Fri May 28 16:51:41 1999 Craig Burley + + * g77.texi: Fix thinko. + +Wed May 26 14:43:27 1999 Craig Burley + + * news.texi: Document Tue May 18 03:52:04 1999 patch. + Fix a grammo. + +Wed May 26 14:25:07 1999 Craig Burley + + * 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 + + 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 + + * com.c (FFECOM_FASTER_ARRAY_REFS): Delete this vestige, + now that -fflatten-arrays exists. + +Tue May 25 17:48:34 1999 Craig Burley + + 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 + + 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 + + * lang-specs.h: Define __GNUC__ and __GNUC_MINOR__ only if -no-gcc + was not given. + +Thu May 13 12:23:20 1999 Craig Burley + + 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 + + * 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 + + * lang-specs.h: Pass -$ to the preprocessor. + +Mon May 10 18:14:28 1999 Craig Burley + + * 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 + + * news.texi: Doc upgrade to netlib libf2c as of today. + +Sun May 9 18:52:13 1999 Hans-Peter Nilsson + + * f/g77spec.c (lang_specific_driver): Correct bug-report address + and point to the FAQ. + +Thu May 6 12:40:21 1999 Craig Burley + + * 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 + + * bugs.texi, news.texi: Automatic arrays reportedly working + on HP-UX systems. + +Thu May 6 08:19:31 1999 Craig Burley + + * g77.texi (Advantages Over f2c): Expand on this topic. + +Mon May 3 19:41:48 1999 Craig Burley + + * com.c (ffecom_expr_intrinsic_): Fix test of CTIME_subr. + +Mon May 3 18:11:48 1999 Craig Burley + + 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 + + * news.texi: Doc upgrade to netlib libf2c as of today. + +Sun May 2 17:04:28 1999 Craig Burley + + * version.c: Bump version. + +Sun May 2 16:53:01 1999 Craig Burley + + 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 + + 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 + + * 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 + + * g77.texi (Compiler Prototypes): Replace "missing" subscript- + checking option with something else. + +Fri Apr 23 01:48:28 1999 Craig Burley + + 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 + + * bugs.texi, news.texi: Clarify -malign-double situation. + +Tue Apr 20 01:15:25 1999 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + 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 + + 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * 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 + + * g77.texi (Funding GNU Fortran): Dude's got a web page. + * root.texi: Ditto. + +Tue Mar 30 12:04:11 1999 Kaveh R. Ghazi + + * 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 + + * 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 + + * Make-lang.in: Remove all references to g77.o/g77.c. + Link g77 from gcc.o. + +1999-03-21 Manfred Hollstein + + * Makefile.in (g77$(exeext)): Depend on intl.o. Link in intl.o. + +Wed Mar 17 11:39:44 1999 Craig Burley + + * news.texi: Editorial fix. + +Mon Mar 15 17:12:07 1999 Craig Burley + + * bugs.texi, g77.texi, news.texi: Editorial fixes. + +Sat Mar 13 17:51:55 1999 Craig Burley + + 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 + + * 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 + + * g77.texi: Add AUTOMATIC to list of unsupported extensions. + +Sat Mar 6 02:28:35 1999 Craig Burley + + 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 + + * 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 + + * news.texi: IDATE (VXT) fixed to return year as 0..99. + +Wed Mar 3 00:43:49 1999 Craig Burley + + * g77.texi: Add remaining changes pending from Dave Love. + +Wed Mar 3 00:38:42 1999 Craig Burley + + * 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 + + * 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 + + * news.texi: Copy over 1.1.2 news. + +1999-03-02 Craig Burley + + * g77.texi (Bug Reporting): Clarify whether to use -E. + Clarify other instructions. + +1999-02-27 Craig Burley + + * lang-specs.h: Fix specs to pass `-ax' as well as `-a' option. + +1999-02-26 Craig Burley + + * 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 + + * intdoc.in (DATE_AND_TIME): Explain that VALUES(7) holds + seconds, and VALUES(8), therefore, milliseconds. + +1999-02-26 Craig Burley + + * news.texi: Clarify IOSTAT= fix. + +1999-02-25 Richard Henderson + + * lang-specs.h: Define __FAST_MATH__ when appropriate. + +1999-02-25 Craig Burley + + * g77.texi: Clarify/index lack of run-time allocation for + concatenation. + +1999-02-25 Andreas Jaeger + + * f/intdoc.in: Add missing `,' after cross references. + +1999-02-20 Craig Burley + + * 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 + + * g77.texi: Properly attribute Priest document; clarify + that it is in the .ps version of the Goldberg document. + +1999-02-19 Craig Burley + + * 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 + + * 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 + + * 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 + + * g77.texi: Clarify -fno-globals vs. -Wno-globals. + +1999-02-18 Craig Burley + + * intdoc.in (LOG10): Fix typo. + +1999-02-17 Ulrich Drepper + + * intdoc.in: Fix typo. + +1999-02-17 Craig Burley + + * 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 + + * intdoc.in: Say `common' logarithm for log10. + +1999-02-16 Ulrich Drepper + + * g77.texi: Add missing @ in email addresses. + +1999-02-15 Craig Burley + + * *.*: Delete my (old) email address in most places, change it + in a few. + +1999-02-14 Craig Burley + + * version.c: Bump. + +1999-02-14 Craig Burley + + * version.c: Bump for 1998-10-02 change (forgot to do this + before). + +1999-02-14 Craig Burley + + * lang-specs.h, g77.1, g77.texi, news.texi: Recognize `.FOR' + and `.FPP' as well as `.for' and `.fpp'. + +1999-02-14 Craig Burley + + * intdoc.in (LOG10): Fix description. + +1999-02-14 Craig Burley + + * news.texi: Mention fix for SIGNAL invocation circa egcs-1.1. + +1999-02-14 Craig Burley + + * g77.texi, g77install.texi, bugs.texi, g77install.texi: Clean + up and improve indexing, and some other areas of docs. + +1999-02-14 Craig Burley + + * 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 + + * Make-lang.in (g77$(exeext)): Get choose-temp.o, pexecute.o and + mkstemp.o from libiberty. + +1999-02-01 Zack Weinberg + + * 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 + + * lang-specs.h: Map -Qn to -fno-ident. + +Tue Jan 5 22:12:41 1999 Kaveh R. Ghazi + + * Make-lang.in (g77.o): Depend on prefix.h. + +Fri Nov 27 13:10:32 1998 Kaveh R. Ghazi + + * 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 + + * g77.texi: Assorted minor changes. + +1998-11-19 Dave Love + + * bugs.texi: Formatting changes from Craig. + + * intdoc.in: Terminate some @xrefs with `,'. + +1998-11-19 Manfred Hollstein + + * 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 + + * Makefile.in (INCLUDES): Add "-I$(srcdir)/../../include". + +Sat Nov 7 15:58:54 1998 Kaveh R. Ghazi + + * g77spec.c: Don't include gansidecl.h. + * output.j: Likewise. + +1998-11-04 Dave Love + + * g77.texi: Small formatting/indexing fixes. + +Mon Oct 12 20:41:59 1998 Kaveh R. Ghazi + + * 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 + + * com.c (ffecom_expr_intrinsic_): Fix return type for RAND. + +Thu Oct 1 10:43:45 1998 Nick Clifton + + * 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 + + * g77.texi: Additions about `/*', trailing comments and cpp. + +1998-09-18 Dave Love + + * g77.texi: Various additions and some small fixes. + +Thu Sep 10 14:55:44 1998 Kamil Iskra + + * Make-lang.in (f77.install-common): Add missing "else true;". + +1998-09-07 Dave Love + + * ChangeLog.egcs: Deleted. Entries merged here. + +1998-09-05 Dave Love + + * Makefile.in (LDFLAGS): Set from BOOT_LDFLAGS. + (F771_LDFLAGS): Variable dispensed with. + +Fri Sep 4 19:53:34 1998 Craig Burley + + * intdoc.in: Minor editorial tweaks. + +Fri Sep 4 18:35:52 1998 Craig Burley + + * 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 + + * 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 + + * 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 + + * bugs.texi, g77.1, g77.texi, intdoc.in, news.texi: Doc updates + from Craig. + +1998-08-23 Dave Love + + * 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 + + * 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 + + * 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 + + * BUGS, INSTALL, NEWS: Rebuilt. + +Sat Jul 25 17:23:55 1998 Craig Burley + + Fix 980615-0.f: + * stc.c (ffestc_R1229_start): Set info to ANY as well. + +Tue Jul 21 04:33:37 1998 Craig Burley + + * 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 + + * 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 + + * 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 + + * intdoc.texi: Regenerated. + +Mon Jul 13 18:45:06 1998 Craig Burley + + * 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 + + 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 + + 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 + + * lang-options.h: Format changed to work with --help support added + to gcc/toplev.c + +Mon Jul 13 11:54:03 1998 Craig Burley + + * 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 + + * version.c: Bump version. + +Sat Jul 11 19:24:32 1998 Craig Burley + + 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 + + * 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 + + * intdoc.in (HOSTNM_func, HOSTNM_subr): Update last change. + +Thu Jul 9 00:45:59 1998 Craig Burley + + 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 + + * Make-lang.in (f77.stage?): Use mv -f instead of just mv so that + we can move g77.c. + +1998-07-06 Dave Love + + * intdoc.in (HOSTNM_func, HOSTNM_subr): Note possible need for + -lsocket. + +1998-07-05 Dave Love + + * 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 + + 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 + + * f/Make-lang.in ($(srcdir)/f/BUGS): Add include path for + gcc-common.texi. + ($(srcdir)/f/NEWS): Likewise. + +2002-12-28 Joseph S. Myers + + * g77.texi: Use @copying. + +2002-12-23 Joseph S. Myers + + * 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 + + * intdoc.in: Fix typos. + +2002-12-18 Kazu Hirata + + * g77.texi: Fix typos. + * intdoc.texi: Likewise. + * news.texi: Follow spelling conventions. + +Mon Dec 16 13:53:18 2002 Mark Mitchell + + * root.texi: Change version number to 3.4. + +2002-12-15 Zack Weinberg + + * target.h: Don't define HOST_WIDE_INT. + +2002-12-02 Nathanael Nerode + + * 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 + + * proj.h, ansify.c, g77spec.c, intdoc.c: + Include coretypes.h and tm.h. + * Make-lang.in: Update dependencies. + +2002-11-20 Toon Moene + + * invoke.texi: Explain the purpose of -fmove-all-movables, + -freduce-all-givs and -frerun-loop-opts better. + +2002-11-19 Nathanael Nerode + + * Make-lang.in: Correct BUILD/HOST confusion. + +2002-11-19 Toon Moene + + PR fortran/8587 + * news.texi: Show PR fortran/8587 fixed. + +2002-11-19 Jason Thorpe + + * g77spec.c (lang_specific_spec_functions): New. + +2002-11-02 Toon Moene + + * 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 + + * 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 + + * lang-specs.h: Fix ratfor specs. + +2002-10-15 Richard Henderson + + * target.h (ffetarget_print_real1, ffetarget_print_real2): Use + real_to_decimal directly, and with the new arguments. + +2002-09-23 Zack Weinberg + + * 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 + + * 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 + + * com.c (union lang_tree_node): Add chain_next option. + +2002-09-16 Richard Henderson + + * 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 + + * intdoc.texi: Regenerate. + +2002-09-15 Kazu Hirata + + * ChangeLog: Follow spelling conventions. + * intdoc.in: Likewise. + +2002-09-09 Gerald Pfeifer + + 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 + + * com.c (ffe_type_for_mode): Handle long double. + +2002-09-04 Richard Henderson + + * target.h (ffetarget_print_real1, ffetarget_print_real2): Update + call to REAL_VALUE_TO_DECIMAL. + +2002-08-31 Toon Moene + + * 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 + + * 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 + + * target.h (FFETARGET_32bit_longs): Don't define for powerpc64 or + mmix. + +2002-08-28 Joseph S. Myers + + * bugs.texi, news.texi: Update URLs for online news and bugs + lists. + +2002-08-22 Hans-Peter Nilsson + + * 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 + + * where.c (ffewhere_track): Remove impossible if-then clause. + +Thu Aug 8 10:06:14 2002 Nathan Sidwell + + * f/Make-lang.in (f.mostlyclean): Remove coverage files. + +2002-08-06 Gerald Pfeifer + + * g77.texi (Top): Rename Index to Keyword Index. + +2002-08-05 Toon Moene + + * invoke.texi: Improve description of + -fno-finite-math-only flag. + +Sun Aug 4 16:45:49 2002 Joseph S. Myers + + * root.texi (version-gcc): Increase to 3.3. + +2002-07-30 Toon Moene + + * 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 + + * com.c (read_name_map): Use concat in lieu of xmalloc/strcpy. + +2002-07-25 Toon Moene + + * news.texi: Document better handling of (no-)alias + information of dummy arguments and induction variables + on loop unrolling. + +2002-07-01 Roger Sayle + + * 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 + + * 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 + + * lang-specs.h: Use cc1 for traditional preprocessing. + +2002-06-20 Andreas Jaeger + + * com.c (ffecom_prepare_expr_,ffecom_expr_power_integer_): + Remove #ifdefed HAHA sections. + +2002-06-20 Nathanael Nerode + + * com.c: Remove #ifdef HOHO sections. + +2002-06-17 Jason Thorpe + + * bit.c: Don't include glimits.h. + * target.c: Likewise. + * where.h: Likewise. + +2002-06-12 Gabriel Dos Reis + + * bad.c (ffebad_start_): Adjust calls to diagnostic_count_error. + +2002-06-04 Gabriel Dos Reis + + * 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 + + * 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 + + * lang-specs.h: Use cpp_debug_options. + +2002-05-28 Zack Weinberg + + * bld.c, com.c, expr.c, target.c: Include real.h. + * Make-lang.in: Update dependency lists. + +2002-05-16 Rainer Orth + + * Make-lang.in: Allow for PWDCMD to override hardcoded pwd. + +2002-05-09 Hassan Aurag + + * expr.c (ffeexpr_reduced_ugly2log_): Allow logicals-as-integers + under -fugly-logint as arguments of .and., .or., .xor. + +2002-05-07 Jan Hubicka + + * target.h (FFETARGET_32bit_longs): Undefine for x86-64. + +2002-04-29 Joseph S. Myers + + * 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 + + * com.h (ffe_parse_file): Update. + * lex.c (ffe_parse_file): Update. + +2002-04-20 Toon Moene + + * root.texi: Remove variable version-g77. + * g77.texi: Remove the single use of that variable. + +Thu Apr 18 19:10:44 2002 Neil Booth + + * com.c (incomplete_type_error): Remove. + +Tue Apr 16 14:55:47 2002 Mark Mitchell + + * 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 + + * g77.texi: Remove Chill reference. + +2002-04-13 Toon Moene + + * news.texi: Deprecate frontend version number; + update list of fixed bugs. + +2002-04-08 Hans-Peter Nilsson + + * 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 + + * 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 + + * com.c (LANG_HOOKS_MARK_ADDRESSABLE): Redefine. + (mark_addressable): Rename. + (ffecom_arrayref_, ffecom_1): Update. + +Mon Apr 1 09:59:53 2002 Neil Booth + + * 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 + + * 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 + + * 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 + + * invoke.texi (Warning Options): Mention -Wswitch-enum. + Fix PR c/5044. + +Tue Mar 26 07:30:51 2002 Neil Booth + + * 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 + + * com.c (maybe_build_cleanup): Remove. + +2002-03-23 Toon Moene + + * 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 + + * invoke.texi (Warning Options): Mention -Wswitch-default. + +Thu Mar 21 18:55:41 2002 Neil Booth + + * cp-tree.h (pushdecl, pushlevel, poplevel, set_block, + insert_block, getdecls, global_bindings_p): New. + +Wed Mar 20 08:03:42 2002 Neil Booth + + * 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 + + * com.h (ffe_parse_file): Prototype. + +Sun Mar 17 20:57:30 2002 Neil Booth + + * 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 + + * com.c (tree_code_type, tree_code_length, tree_code_name): + Define. + +Sun Mar 10 12:37:42 2002 Kaveh R. Ghazi + + * target.c (ffetarget_print_hex): Const-ify. + +2002-03-06 Phil Edwards + + * version.c: Fix misplaced leading blanks on first line. + +2002-03-03 Zack Weinberg + + * 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 + + * com.c (copy_lang_decl): Delete. + +2002-02-27 Zack Weinberg + + * 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 + + * news.texi: List Problem Reports fixed in 3.1. + +2002-02-13 Toon Moene + + * 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 + + * data.c (ffedata_eval_offset_): Convert non-default integer + constants to default integer kind if necessary. + +2002-02-09 Toon Moene + + * invoke.texi: Add a short debugging session + as an example to the documentation of -g. + +2002-02-06 Toon Moene + + 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 + + * implic.c lex.c stb.c ste.c stu.c: Update copyright dates. + +2002-02-04 Philipp Thomas + + * 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 + + * expr.c (ffeexpr_sym_impdoitem_): Allow other than + default INTEGER implied-do loop counts. + +2002-02-01 Toon Moene + + * 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 + + * g77spec.c (lang_specific_driver): Follow GNU Coding Standards + for --version. + +2002-01-30 Richard Henderson + + * ste.c (ffeste_begin_iterdo_): Use expand_exit_loop_top_cond. + (ffeste_R819B): Likewise. + +2002-01-30 Toon Moene + + * intrin.c (upcasecmp_): New function. + (ffeintrin_cmp_name_): Use it to correctly compare name + and table entry for bsearch. + +2002-01-26 Toon Moene + + * intrin.c (ffeintrin_cmp_name_): Correct comparison + for intrinsics in intrinsic table (intrin.def). + +2002-01-22 Zack Weinberg + + * 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 + + 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 + + * g77spec.c (lookup_option): Handle -fversion. + (lang_specific_driver): Update copyright date in --version output. + +Mon Jan 7 00:03:42 2002 Gerald Pfeifer + + * 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 + + * 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 + + * 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 + + * bld.c (ffebld_arity_op_): Declare array size explicitly. + * bld.h (ffebld_arity_op_): Likewise. + +2001-12-20 Joseph S. Myers + + * config-lang.in (diff_excludes): Remove. + +2001-12-17 Joseph S. Myers + + * g77.texi, invoke.texi: Update links to GCC manual. + +Sun Dec 16 16:08:57 2001 Joseph S. Myers + + * news.texi: Fix spelling errors. + +Sun Dec 16 10:36:51 2001 Kaveh R. Ghazi + + * 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 + + * 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 + + * 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 + + * g77.texi: Don't condition menus on @ifinfo. + +Wed Dec 5 06:49:21 2001 Richard Kenner + + * com.c (ffecom_1): Properly handle TREE_READONLY for INDIRECT_REF. + +Mon Dec 3 18:56:04 2001 Neil Booth + + * com.c: Remove leading capital from diagnostic messages, as + per GNU coding standards. + * g77spec.c: Similarly. + * lex.c: Similarly. + +2001-12-01 Zack Weinberg + + * f/fini.c: Use xmalloc. + +Fri Nov 30 20:54:02 2001 Kaveh R. Ghazi + + * Make-lang.in: Delete references to proj.[co], proj-h.[co]. + * proj.c: Delete file. + +2001-11-29 Zack Weinberg + + * 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 + + * 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 + + PR fortran/3957 + * lang-specs.h: Correct !pipe conditional in tradcpp0 invocation. + +2001-11-21 Toon Moene + + * 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 + + * Make-lang.in: Complete ``Build g77.1 in $(srcdir)''. + +2001-11-19 Geoffrey Keating + + * 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 + + * .cvsignore: Ignore g77.1 + * g77.texi: Substitute `@command' for `@code' + where appropriate. + * invoke.texi: Ditto. + +2001-11-18 Toon Moene + + * 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 + + * com.c (finish_parse): Remove. + (ffe_finish): Move body of finish_parse. + +Thu Nov 15 10:06:38 2001 Neil Booth + + * 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 + + * g77.texi: Update to use `@command', `@option. + * invoke.texi: Ditto + +2001-11-14 Joseph S. Myers + + * Make-lang.in: Change all uses of $(manext) to $(man1ext). + +2001-11-14 Toon Moene + + * 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 + + * 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 + + * 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 + + * com.c (language_string, lang_identify): Remove. + (struct lang_hooks): Constify. + (LANG_HOOKS_NAME): Override. + (init_parse): Update. + +2001-11-08 Andreas Franck + + * Make-lang.in (G77_INSTALL_NAME, G77_CROSS_NAME): Handle + program_transform_name the way suggested by autoconf. + +2001-11-08 Toon Moene + + * 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 + + * com.c: Include langhooks-def.h. + * Make-lang.in: Update. + +2001-11-04 Toon Moene + + * 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 + + * 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 + + * news.texi: Document new ability to compile programs with + arrays larger than 512 Mbyte on 32-bit targets. + +2001-10-24 Toon Moene + + * com.c (ffecom_check_size_overflow_): Only check for TREE_OVERFLOW. + +Tue Oct 23 14:01:27 2001 Richard Kenner + + * com.c (LANG_HOOKS_GET_ALIAS_SET): New macro. + (lang_get_alias_set): Delete. + +2001-10-23 Joseph S. Myers + + * g77.texi (Sending Patches): Remove. + +2001-10-22 Zack Weinberg + + * Make-lang.in (f/intdoc): Depend on safe-ctype.o. + +Sun Oct 21 17:28:17 2001 Kaveh R. Ghazi + + * 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 + + * target.h (FFETARGET_32bit_longs): Don't define + for 64-bit hppa. + +2001-10-17 Richard Henderson + + * std.c (ffestd_labeldef_format): Fix variable/stmt ordering. + (ffestd_R737A): Likewise. + +2001-10-17 Richard Henderson + + * 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 + + * 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 + + * 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 + + * 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 + + * Make-lang.in: Remove reference to FORTRAN_INIT. + * g77spec.c: Add reference to FORTRAN_INIT. + +2001-09-29 Juergen Pfeifer + + 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 + + * expr.c (ffeexpr_sym_rhs_dimlist_): Allow array elements + as bounds of adjustable arrays. + +Thu Sep 20 15:05:20 JST 2001 George Helffrich + + * 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 + + * 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 + + * 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 + + * parse.c (finput): Mark extern. + +2001-09-11 Jakub Jelinek + + * com.c (ffe_init_options): Default to -fmerge-all-constants + if optimizing. + +2000-08-14 Ulrich Weigand + + * target.h (FFETARGET_32bit_longs): Don't define + for 64-bit S/390. + +2001-07-20 Toon Moene + + * 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 + + * top.c (ffe_decode_option): Disallow lang-independent processing + for -ffixed-form. + +2001-07-19 Toon Moene + + * 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 + + * com.c (lang_print_error_function): Argument context + is unused. + +2001-07-14 Tim Josling + + * com.c (ffecom_overlap_): Remove references to EXPON_EXPR. + (ffecom_tree_canonize_ref_): Likewise. + +2001-07-10 James Smaby + + * intdoc.in: Fix the definition of COMPLEX ABS. + Remove `the' where inappropriate. + * intdoc.texi: Rebuilt. + +2001-07-04 Joseph S. Myers + + * 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 + + * 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 + + * BUGS: Remove. + * NEWS: Likewise. + +2001-06-10 Toon Moene + + * 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 + + * root.texi: Fix typo in patches e-mail address. + +2001-06-03 Toon Moene + Jan van Male + + * 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 + + * g77.texi: Move contents to just after title page. + +2001-06-02 Toon Moene + + * com.c (ffecom_init_0): Make CHARACTER*1 unsigned. + +2001-05-23 Theodore Papadopoulo + + * 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 + + * 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 + + * 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 + + * 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 + + * Make-lang.in (f/g77.dvi): Include $(srcdir) in TEXINPUTS. + +2001-05-19 Toon Moene + + * 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 + + * Make-lang.in: Replace all uses of `touch' with $(STAMP). + +Wed May 2 10:20:08 2001 Kaveh R. Ghazi + + * com.c: NULL_PTR -> NULL. + +Sun Apr 22 20:18:01 2001 Kaveh R. Ghazi + + * com.c (ffecom_subscript_check_): Use concat in lieu of + xmalloc/sprintf. + +2001-04-21 Toon Moene + + * news.texi: Update release information for 0.5.27. + +Thu Apr 19 12:49:24 2001 Mark Mitchell + + * 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 + + * bad.c (inhibit_warnings): Delete redundant declaration. + + * com.c (skip_redundant_dir_prefix): Likewise. + + * com.h (mark_addressable): Likewise. + +2001-04-02 Jakub Jelinek + + * lex.c (ffelex_hash_): Avoid eating one whole line after + #line. + +Mon Apr 2 22:38:09 2001 Toon Moene + + * 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 + + * Make-lang.in: Depend on $(SYSTEM_H), not system.h. + +Mon Mar 26 18:13:30 2001 Mark Mitchell + + * com.c (duplicate_decls): Don't copy DECL_FRAME_SIZE. + +Mon Mar 19 15:05:39 2001 Mark Mitchell + + * com.c (builtin_function): Use SET_DECL_ASSEMBLER_NAME. + +Wed Mar 14 09:29:27 2001 Mark Mitchell + + * 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 + + * fini.c (main): Use really_call_malloc, not malloc. + +Thu Mar 8 13:27:47 2001 Kaveh R. Ghazi + + * com.c: Don't rely on the POSIX macro to define autoconf stuff. + +2001-03-07 Brad Lucier + + * g77.texi: Document new options -funsafe-math-optimizations + and -fno-trapping-math. Revise documentation for -ffast-math. + +2001-03-01 Zack Weinberg + + * 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 + + * lang-specs.h: Add zero initializer for cpp_spec field to all + array elements. + +2001-02-24 Zack Weinberg + + * com.c: Don't define STDC_HEADERS, autoconf handles it. + +Fri Feb 23 15:28:39 2001 Richard Kenner + + * com.c (set_block): Set NAMES and BLOCKS from BLOCK. + +2001-02-19 Joseph S. Myers + + * 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 + + * 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 + + * Make-lang.in: Remove all dependencies on defaults.h. + * com.c: Don't include defaults.h. + +2001-01-23 Michael Sokolov + + * com.c: Don't explicitly include any time headers, the right ones are + already included by proj.h. + +2001-01-15 Mark Mitchell + + * 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 + + * g77spec.c (lang_specific_driver): Update copyright year to 2001. + +Wed Jan 10 14:39:45 2001 Mark Mitchell + + * 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 + + * 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 + + * g77install.texi: Adjust wording of an EGCS reference. + +Thu Dec 21 20:00:48 2000 Joseph S. Myers + + * BUGS, NEWS: Regenerate. + +2000-12-18 Joseph S. Myers + + * com.c [VMS]: Remove definition of BSTRING. + +2000-12-18 Joseph S. Myers + + * g77.texi: Update GPL copy not to refer to years 19@var{yy}. + +2000-12-18 Toon Moene + + * bugs.texi: Correct copyright years. + * g77.texi: Likewise. + * news.texi: Likewise. + +2000-12-18 Joseph S. Myers + + * 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 + + * .cvsignore: New file; add info files. + +2000-12-08 Joseph S. Myers + + * 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 + + * 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 + + * com.c (ffecom_member_phase2_): Set TREE_USED on the debugging decl. + +2000-11-26 Joseph S. Myers + + * 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 + + * g77spec.c (lang_specific_driver): Update copyright year to 2000. + +Thu Nov 23 02:18:57 2000 J"orn Rennecke + + * Make-lang.in (g77spec.o): Depend on $(CONFIG_H). + +2000-11-21 David Billinghurst + + * 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 + + * g77.texi (Floating-point precision): Adjust example + to work with glibc (>= 2.1). + +Sat Nov 18 13:54:49 2000 Matthias Klose + + * g77.texi (Floating-point Exception Handling): Adjust + example to work with glibc (>= 2.1). + +2000-11-18 Alexandre Oliva + + * 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 + + * lex.c (ffelex_hash_): Change ggc_alloc_string (var, -1) to + ggc_strdup (var). + +Thu Nov 16 23:14:07 2000 Kaveh R. Ghazi + + * malloc.c (malloc_init): Call xmalloc, not malloc. + +2000-11-10 Rodney Brown + + * Make-lang.in: Remove OUTPUT_OPTION from g77version.o target. + +2000-11-10 Toon Moene + + * root.texi: Remove non-historical EGCS reference. + Set current g77 version to 0.5.26. + +2000-11-10 Toon Moene + + * com.c (ffecom_stabilize_aggregate_) case RTL_EXPR: Abort. + +2000-11-10 Zack Weinberg + + * 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 + + * root.texi, news.texi, g77install.texi, g77.texi, bugs.texi: + Remove non-historical references to egcs/EGCS. + +2000-11-05 Joseph S. Myers + + * Make-lang.in: Remove f77.distdir and f/INSTALL. + * INSTALL, install0.texi: Remove. + +2000-11-02 Joseph S. Myers + + * com.c (open_include_file, ffecom_open_include_): Use strchr () + and strrchr () instead of index () and rindex (). + +2000-10-27 Zack Weinberg + + * 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 + + * Makefile.in, g77spec.c: Remove EGCS references in comments. + +Thu Oct 12 22:28:51 2000 Mark Mitchell + + * 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 + + * com.c (finish_function): Don't init can_reach_end. + +Sun Oct 1 11:43:44 2000 Mark Mitchell + + * com.c (lang_mark_false_label_stack): Remove. + +2000-09-10 Zack Weinberg + + * com.c: Include defaults.h. + * com.h: Don't define the *_TYPE_SIZE macros. + * Makefile.in: Update dependencies. + +2000-08-29 Zack Weinberg + + * ansify.c: Use #line, not # . + +2000-08-24 Greg McGary + + * 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 + + * 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 + + * 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 + + * lang-specs.h: Pass -I* options to f771. + +2000-08-19 Toon Moene + + * 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 + + * bugs.texi: Describe new ability to emit debug info + for EQUIVALENCE members. + * news.texi: Ditto. + +2000-08-11 G. Helffrich + Toon Moene + + * 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 + + * g77spec.c (lang_specific_driver): Clearer g77 version message. + +2000-08-04 Zack Weinberg + + * 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 + + * 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 + + * lang-specs.h: Rename cpp to cpp0 and/or tradcpp to tradcpp0. + +Thu Jul 27 11:50:08 2000 Kaveh R. Ghazi + + * fini.c (main): Avoid automatic aggregate initialization. + + * proj.h: Indent #error directive. + +2000-07-26 Toon Moene + + * lang-specs.h: Remove one /dev/null from tradcpp invocation. + +Sun Jul 23 15:47:30 2000 Billinghurst, David + + * Make-lang.in: Put $(build_exeext) suffix on programs which run + on the build machine. + +2000-07-22 Toon Moene + + * com.c (ffecom_expr_intrinsic_): case FFEINTRIN_impFGETC_subr, + FFEINTRIN_impFPUTC_subr: Check for arg3 being NULL. + +2000-07-13 Zack Weinberg + + * lang-specs.h: Use the new named specs. Remove unnecessary braces. + +2000-07-02 Toon Moene + + * version.c: Bump version number. + +2000-06-21 Zack Weinberg + + * 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 + + * ste.c (gbe_block): Constify. + +2000-06-13 Jakub Jelinek + + * 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 + + * com.c (lang_get_alias_set): Mark parameter with ATTRIBUTE_UNUSED. + +2000-06-04 Philipp Thomas + + * Makefile.in(INTLLIBS): New macro. + (LIBS): Add INTLLIBS. + (DEPLIBS): Likewise. + +2000-06-02 Richard Henderson + + * com.c (lang_get_alias_set): New. + +2000-05-28 Toon Moene + + * bugs.texi: Note that debugging information for + common block items is emitted now. + * news.texi: Ditto. + +2000-05-18 Chris Demetriou + + * 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 + + * top.c (ffe_decode_option): Update -Wall unused flags by calling + set_Wunused. + +2000-05-09 Zack Weinberg + + * 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 + + * 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 + + * lex.c: Remove references to cccp.c. + * g77install.texi: Remove references to cexp.c/cexp.y. + +2000-04-15 David Edelsohn + + * target.h (FFETARGET_32bit_longs): Define for 64-bit PowerPC + as well. + +Wed Apr 12 15:15:26 2000 Mark Mitchell + + * 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 + + * Makefile.in (GGC_H): Add varray.h. + +2000-04-03 Zack Weinberg + + * lang-specs.h: Pass -fno-show-column to the preprocessor. + +2000-03-28 Franz Sirl + + * 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 + + * com.c (ffecom_tree_canonize_ptr_): Use bitsize_zero_node. + (ffecom_tree_canonize_ref_): Likewise. + +Mon Mar 20 15:49:40 2000 Jim Wilson + + * 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 + + * com.c (ffecom_stabilize_aggregate_): Don't refer to TREE_RAISES. + +Mon Mar 6 18:05:19 2000 Richard Kenner + + * 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 + + * 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 + + * com.c (current_function_decl): Move to toplev.c. + +Sun Feb 27 16:40:33 2000 Richard Kenner + + * 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 + + * 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 + + * 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 + + * g77spec.c (lang_specific_driver): Use GCCBUGURL. + +2000-02-17 Andy Vaught + + * 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 + + * Make-lang.in (g77spec.o): Depend on $(GCC_H), not gcc.h. + +2000-02-15 Jonathan Larmour + + * lang-specs.h: Add new __GNUC_PATCHLEVEL__ define to default spec. + +Tue Feb 15 11:14:17 2000 Kaveh R. Ghazi + + * g77spec.c: Don't declare `version_string'. + +Sat Feb 5 23:27:25 2000 Kaveh R. Ghazi + + * com.c (mark_tracker_head, mark_binding_level): Protoize. + + * where.c (mark_ffewhere_head): Likewise. + +Wed Jan 12 09:32:59 2000 Zack Weinberg + + * lang-specs.h: Pass -lang-fortran to preprocessor. + +Thu Dec 30 13:14:31 1999 Richard Henderson + + * stw.h (struct _ffestw_): Change type of uses_ to int. + +Thu Dec 30 11:42:05 1999 Geoff Keating + + * 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 + + * g77.texi (C Interfacing Tools): Fix an incorrect link. + +1999-12-13 Jakub Jelinek + + * target.h: Handle sparc64 the same way as alpha. + +Sun Nov 28 21:39:05 1999 Kaveh R. Ghazi + + * 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 + + * 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 + Kaveh R. Ghazi + + * proj.h: Test `GCC_VERSION', not `HAVE_GCC_VERSION'. + +Tue Oct 26 01:32:19 1999 Mark Mitchell + + * com.c (poplevel): Don't call remember_end_note. + +Fri Oct 15 15:18:12 1999 Greg McGary + + * 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 + + * 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 + + * 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 + + * g77spec.c (lang_specific_driver): Initialize return value. + +Thu Sep 16 18:07:11 1999 Kaveh R. Ghazi + + * 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 + + * g77spec.c (lang_specific_driver): Remove unnecessary argument in + call to function `fatal'. + +Sun Sep 12 23:29:47 1999 Kaveh R. Ghazi + + * 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 + + * 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 + + * 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 + + * com.c (language_string): Constify. + +Mon Aug 30 20:29:30 1999 Kaveh R. Ghazi + + * 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 + + * com.c (lang_printable_name): Constify a char*. + +Wed Aug 25 01:21:06 1999 Rainer Orth + + * lang-specs.h: Pass cc1 spec to f771. + +Mon Aug 9 19:44:08 1999 Kaveh R. Ghazi + + * 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 + + * com.c (ptr_type_node, va_list_type_node): New. + (ffecom_init_0): Init and use ptr_type_node. + +1999-07-17 Alexandre Oliva + + * 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 + + * 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 + + * news.texi: Describe DATE intrinsic fix. + +Mon Jun 28 21:44:19 1999 Craig Burley + + * version.c: Denote experimental version. + +Mon Jun 28 10:43:11 1999 Craig Burley + + * 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 + + * 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 + + * bugs.texi: Describe K(5)=10*3 NAMELIST-read bug. + +Mon Jun 21 12:40:17 1999 Gerald Pfeifer + + * 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 + + * news.texi: Doc TtyNam fix. + +Fri Jun 18 11:26:50 1999 Craig Burley + + * news.texi: New heading for development version. + Doc upgrade to netlib libf2c as of today. + +Wed Jun 16 11:43:02 1999 Craig Burley + + * news.texi: Mention BACKSPACE fix to libg2c. + +Mon Jun 7 08:42:40 1999 Craig Burley + + * Make-lang.in: Any target using libsubdir must depend + on installdirs. + +Sat Jun 5 23:50:36 1999 Craig Burley + + * g77.texi: Describe a few more missing features people + have emailed me about. + +Sat Jun 5 17:03:23 1999 Craig Burley + + 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 + + * Make-lang.in: Use libsubdir, not prefix, to store + temporary lang-f77 `flag' file. + +Fri Jun 4 10:26:04 1999 Craig Burley + + * 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 + + * g77.texi (Missing Features): Add `Better Warnings' + item. + +Fri May 28 16:51:41 1999 Craig Burley + + * g77.texi: Fix thinko. + +Wed May 26 14:43:27 1999 Craig Burley + + * news.texi: Document Tue May 18 03:52:04 1999 patch. + Fix a grammo. + +Wed May 26 14:25:07 1999 Craig Burley + + * 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 + + 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 + + * com.c (FFECOM_FASTER_ARRAY_REFS): Delete this vestige, + now that -fflatten-arrays exists. + +Tue May 25 17:48:34 1999 Craig Burley + + 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 + + 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 + + * lang-specs.h: Define __GNUC__ and __GNUC_MINOR__ only if -no-gcc + was not given. + +Thu May 13 12:23:20 1999 Craig Burley + + 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 + + * 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 + + * lang-specs.h: Pass -$ to the preprocessor. + +Mon May 10 18:14:28 1999 Craig Burley + + * 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 + + * news.texi: Doc upgrade to netlib libf2c as of today. + +Sun May 9 18:52:13 1999 Hans-Peter Nilsson + + * f/g77spec.c (lang_specific_driver): Correct bug-report address + and point to the FAQ. + +Thu May 6 12:40:21 1999 Craig Burley + + * 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 + + * bugs.texi, news.texi: Automatic arrays reportedly working + on HP-UX systems. + +Thu May 6 08:19:31 1999 Craig Burley + + * g77.texi (Advantages Over f2c): Expand on this topic. + +Mon May 3 19:41:48 1999 Craig Burley + + * com.c (ffecom_expr_intrinsic_): Fix test of CTIME_subr. + +Mon May 3 18:11:48 1999 Craig Burley + + 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 + + * news.texi: Doc upgrade to netlib libf2c as of today. + +Sun May 2 17:04:28 1999 Craig Burley + + * version.c: Bump version. + +Sun May 2 16:53:01 1999 Craig Burley + + 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 + + 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 + + * 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 + + * g77.texi (Compiler Prototypes): Replace "missing" subscript- + checking option with something else. + +Fri Apr 23 01:48:28 1999 Craig Burley + + 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 + + * bugs.texi, news.texi: Clarify -malign-double situation. + +Tue Apr 20 01:15:25 1999 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + 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 + + 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * 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 + + * g77.texi (Funding GNU Fortran): Dude's got a web page. + * root.texi: Ditto. + +Tue Mar 30 12:04:11 1999 Kaveh R. Ghazi + + * 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 + + * 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 + + * Make-lang.in: Remove all references to g77.o/g77.c. + Link g77 from gcc.o. + +1999-03-21 Manfred Hollstein + + * Makefile.in (g77$(exeext)): Depend on intl.o. Link in intl.o. + +Wed Mar 17 11:39:44 1999 Craig Burley + + * news.texi: Editorial fix. + +Mon Mar 15 17:12:07 1999 Craig Burley + + * bugs.texi, g77.texi, news.texi: Editorial fixes. + +Sat Mar 13 17:51:55 1999 Craig Burley + + 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 + + * 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 + + * g77.texi: Add AUTOMATIC to list of unsupported extensions. + +Sat Mar 6 02:28:35 1999 Craig Burley + + 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 + + * 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 + + * news.texi: IDATE (VXT) fixed to return year as 0..99. + +Wed Mar 3 00:43:49 1999 Craig Burley + + * g77.texi: Add remaining changes pending from Dave Love. + +Wed Mar 3 00:38:42 1999 Craig Burley + + * 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 + + * 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 + + * news.texi: Copy over 1.1.2 news. + +1999-03-02 Craig Burley + + * g77.texi (Bug Reporting): Clarify whether to use -E. + Clarify other instructions. + +1999-02-27 Craig Burley + + * lang-specs.h: Fix specs to pass `-ax' as well as `-a' option. + +1999-02-26 Craig Burley + + * 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 + + * intdoc.in (DATE_AND_TIME): Explain that VALUES(7) holds + seconds, and VALUES(8), therefore, milliseconds. + +1999-02-26 Craig Burley + + * news.texi: Clarify IOSTAT= fix. + +1999-02-25 Richard Henderson + + * lang-specs.h: Define __FAST_MATH__ when appropriate. + +1999-02-25 Craig Burley + + * g77.texi: Clarify/index lack of run-time allocation for + concatenation. + +1999-02-25 Andreas Jaeger + + * f/intdoc.in: Add missing `,' after cross references. + +1999-02-20 Craig Burley + + * 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 + + * g77.texi: Properly attribute Priest document; clarify + that it is in the .ps version of the Goldberg document. + +1999-02-19 Craig Burley + + * 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 + + * 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 + + * 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 + + * g77.texi: Clarify -fno-globals vs. -Wno-globals. + +1999-02-18 Craig Burley + + * intdoc.in (LOG10): Fix typo. + +1999-02-17 Ulrich Drepper + + * intdoc.in: Fix typo. + +1999-02-17 Craig Burley + + * 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 + + * intdoc.in: Say `common' logarithm for log10. + +1999-02-16 Ulrich Drepper + + * g77.texi: Add missing @ in email addresses. + +1999-02-15 Craig Burley + + * *.*: Delete my (old) email address in most places, change it + in a few. + +1999-02-14 Craig Burley + + * version.c: Bump. + +1999-02-14 Craig Burley + + * version.c: Bump for 1998-10-02 change (forgot to do this + before). + +1999-02-14 Craig Burley + + * lang-specs.h, g77.1, g77.texi, news.texi: Recognize `.FOR' + and `.FPP' as well as `.for' and `.fpp'. + +1999-02-14 Craig Burley + + * intdoc.in (LOG10): Fix description. + +1999-02-14 Craig Burley + + * news.texi: Mention fix for SIGNAL invocation circa egcs-1.1. + +1999-02-14 Craig Burley + + * g77.texi, g77install.texi, bugs.texi, g77install.texi: Clean + up and improve indexing, and some other areas of docs. + +1999-02-14 Craig Burley + + * 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 + + * Make-lang.in (g77$(exeext)): Get choose-temp.o, pexecute.o and + mkstemp.o from libiberty. + +1999-02-01 Zack Weinberg + + * 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 + + * lang-specs.h: Map -Qn to -fno-ident. + +Tue Jan 5 22:12:41 1999 Kaveh R. Ghazi + + * Make-lang.in (g77.o): Depend on prefix.h. + +Fri Nov 27 13:10:32 1998 Kaveh R. Ghazi + + * 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 + + * g77.texi: Assorted minor changes. + +1998-11-19 Dave Love + + * bugs.texi: Formatting changes from Craig. + + * intdoc.in: Terminate some @xrefs with `,'. + +1998-11-19 Manfred Hollstein + + * 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 + + * Makefile.in (INCLUDES): Add "-I$(srcdir)/../../include". + +Sat Nov 7 15:58:54 1998 Kaveh R. Ghazi + + * g77spec.c: Don't include gansidecl.h. + * output.j: Likewise. + +1998-11-04 Dave Love + + * g77.texi: Small formatting/indexing fixes. + +Mon Oct 12 20:41:59 1998 Kaveh R. Ghazi + + * 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 + + * com.c (ffecom_expr_intrinsic_): Fix return type for RAND. + +Thu Oct 1 10:43:45 1998 Nick Clifton + + * 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 + + * g77.texi: Additions about `/*', trailing comments and cpp. + +1998-09-18 Dave Love + + * g77.texi: Various additions and some small fixes. + +Thu Sep 10 14:55:44 1998 Kamil Iskra + + * Make-lang.in (f77.install-common): Add missing "else true;". + +1998-09-07 Dave Love + + * ChangeLog.egcs: Deleted. Entries merged here. + +1998-09-05 Dave Love + + * Makefile.in (LDFLAGS): Set from BOOT_LDFLAGS. + (F771_LDFLAGS): Variable dispensed with. + +Fri Sep 4 19:53:34 1998 Craig Burley + + * intdoc.in: Minor editorial tweaks. + +Fri Sep 4 18:35:52 1998 Craig Burley + + * 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 + + * 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 + + * 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 + + * bugs.texi, g77.1, g77.texi, intdoc.in, news.texi: Doc updates + from Craig. + +1998-08-23 Dave Love + + * 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 + + * 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 + + * 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 + + * BUGS, INSTALL, NEWS: Rebuilt. + +Sat Jul 25 17:23:55 1998 Craig Burley + + Fix 980615-0.f: + * stc.c (ffestc_R1229_start): Set info to ANY as well. + +Tue Jul 21 04:33:37 1998 Craig Burley + + * 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 + + * 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 + + * 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 + + * intdoc.texi: Regenerated. + +Mon Jul 13 18:45:06 1998 Craig Burley + + * 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 + + 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 + + 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 + + * lang-options.h: Format changed to work with --help support added + to gcc/toplev.c + +Mon Jul 13 11:54:03 1998 Craig Burley + + * 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 + + * version.c: Bump version. + +Sat Jul 11 19:24:32 1998 Craig Burley + + 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 + + * 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 + + * intdoc.in (HOSTNM_func, HOSTNM_subr): Update last change. + +Thu Jul 9 00:45:59 1998 Craig Burley + + 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 + + * Make-lang.in (f77.stage?): Use mv -f instead of just mv so that + we can move g77.c. + +1998-07-06 Dave Love + + * intdoc.in (HOSTNM_func, HOSTNM_subr): Note possible need for + -lsocket. + +1998-07-05 Dave Love + + * 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 + + 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: diff --git a/gcc/f/ChangeLog.0 b/gcc/f/ChangeLog.0 new file mode 100644 index 00000000000..3d6675e5d37 --- /dev/null +++ b/gcc/f/ChangeLog.0 @@ -0,0 +1,4806 @@ +Mon Jun 29 09:47:33 1998 Craig Burley + + 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * Version 0.5.23 released. + +Tue May 19 14:52:41 1998 Craig Burley + + * 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 + + * Make-lang.in (f77.install-info, f77.uninstall): + Use install-info as appropriate. + +Tue May 19 12:56:54 1998 Craig Burley + + * 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 + + * 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 + + * Make-lang.in (f77.mostlyclean): Add missing exeext. + +Thu May 14 13:30:59 1998 Craig Burley + + * 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * com.c (ffecom_check_size_overflow_): Ignore overflow + as well if dummy argument. + +Fri Apr 17 17:18:04 1998 Craig Burley + + * 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 + + * com.c (init_parse): Now returns char* containing filename; + +Tue Apr 14 14:40:40 1998 Craig Burley + + * 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 + + * 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 + + * 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 + + * Make-lang.in (f771$(exeext)): Fix typo. + +1998-03-24 Martin von Loewis + + * com.c (lang_print_xnode): New function. + +Mon Mar 23 21:20:35 1998 Craig Burley + + * 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 + + * bugs.texi: Various updates. + + * com.c (ffecom_tree_canonize_ptr_): Fix up spacing a bit. + +Sun Mar 22 00:50:42 1998 Nick Clifton + Geoff Noer + + * Makefile.in: Various fixes for building cygwin32 native toolchains. + * Make-lang.in: Likewise. + +Mon Mar 16 21:20:35 1998 Craig Burley + + * 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 + + * Version 0.5.22 released. + +Mon Mar 16 14:36:02 1998 Craig Burley + + 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 + + * intrin.def: Fix spelling of mixed-case form + of `CPU_Time' (was `Cpu_Time'). + +Thu Mar 12 13:50:21 1998 Craig Burley + + * lang-options.h: Sort all -f*-intrinsics-* options, + for consistency with other g77 versions. + +Thu Mar 12 09:39:40 1998 Manfred Hollstein + + * lang-specs.h: Properly put brackets around array elements in initializer. + +1998-03-09 Dave Love + + * 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 + + * 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 + + * g77.texi: Use @url for citing URLs. + +Sat Feb 28 15:24:38 1998 Craig Burley + + * intrin.def: Make CPU_TIME's arg generic real to be just + like SECOND_subr. + +Fri Feb 20 12:45:53 1998 Craig Burley + + * expr.c (ffeexpr_token_arguments_): Make sure + outer exprstack isn't null. + +1998-02-16 Dave Love + + * Makefile.in (f/fini): Don't use -W -Wall with HOST_CC. + +Fri Feb 13 00:14:56 1998 Kaveh R. Ghazi + + * 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 + + * config-lang.in: Remove references to runtime/. + +Sun Feb 1 12:43:49 1998 J"orn Rennecke + + * 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 + + * 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 + + * 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 + + * 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 + + 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 + .) + +Fri Jan 9 19:09:07 1998 Craig Burley + + 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 + + * 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 + + * intrin.c (ffeintrin_init_0): Remove duplicate + check for `!'. + +Fri Dec 19 00:12:01 1997 Richard Henderson + + * com.c (ffecom_sym_transform_): Assumed arrays have no upper bound. + +Mon Dec 15 17:35:35 1997 Richard Henderson + + * com.c (ffecom_type_vardesc_): Vardesc.dims is a `ftnlen*'. + +Sun Dec 14 02:49:58 1997 Craig Burley + + * 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 + + * 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 + + * intrin.c (ffeintrin_check_): Fix up indentation a bit more. + +Mon Dec 1 16:21:08 1997 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + * intrin.def: Supply gfrt for CPU_TIME. Generalize arg types of + INT2, INT8, per doc. + +1997-11-06 Dave Love + + * intrin.def: Allow non-integer args for INT2 and INT8 (per + documentation). + +Sun Nov 2 19:49:51 1997 Richard Henderson + + * 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 + + * lang-options.h: Add -fgnu-intrinsics-* and + -fbadu77-intrinsics-* options. + +Sun Oct 26 02:36:21 1997 Craig Burley + + * 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 + + 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * g77.c (pexecute, main): Use unlink, not remove. + +Mon Sep 29 16:18:21 1997 Craig Burley + + * 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 + + * Make-lang.in: install.texi was renamed to g77install.texi + * install0.texi: Likewise. + +Fri Sep 19 01:12:27 1997 Craig Burley + + * 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 + + * 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 + + * config-lang.in: Remove the messages about possible build problems. + +Wed Sep 10 16:39:47 1997 Jim Wilson + + * Make-lang.in (LN, LN_S): New macros, use where appropriate. + +Tue Sep 9 13:20:40 1997 Jim Wilson + + * g77.c (pexecute, doit): Add checks for __CYGWIN32__. + +Tue Sep 9 01:59:35 1997 Craig Burley + + * Version 0.5.21 released. + +Tue Sep 9 00:31:01 1997 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + 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 + + 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 + + * 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 + + 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 + + * 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 + + * 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 + + * intdoc.texi: Readd generated file. + +Mon Aug 18 14:27:18 1997 Craig Burley + + 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 + + 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 + + * com.c (ffecom_make_gfrt_): For rttypeREAL_F2C_, return + double_type_node; for rttypeREAL_GNU_, return + _real_type_node. + +1997-08-13 Dave Love + + * config-lang.in (diff_excludes): Add some hints about known + problematic platforms. + +1997-08-13 Dave Love + + * 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 + + * Make-lang.in ($(RUNTIMESTAGESTUFF)): Add + f/runtime/stamp-lib. + +Mon Aug 11 01:52:03 1997 Craig Burley + + * 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 + + 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 + + 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 + + * 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 + + * intrin.def: Fix IDATE_vxt argument order. + * intdoc.h: Likewise. + +Thu Jul 31 22:22:03 1997 Craig Burley + + * 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 + + * 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 + + 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 + + * 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 + + 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + 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 + + 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 + + * 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 + + * intrin.def (FFEINTRIN_impCTIME): Accept `I*' expression + for STime instead of requiring `I2'. + +Tue May 20 16:14:40 1997 Craig Burley + + * 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 + + * 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 + + * 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 + + From Uwe F. Mayer : + * Make-lang.in (g77-cross): Fix typo in g77.c path. + + From Brian McIlwrath : + * 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 + + * 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 + + 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 + + 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 + + * 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 + + * expr.c (ffeexpr_declare_parenthesized_): INCLUDE + context can't be an intrinsic invocation either. + +Fri Mar 28 10:43:28 1997 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * intdoc.c: Fix so any C compiler can compile this. + +Fri Feb 28 13:16:50 1997 Craig Burley + + * Version 0.5.20 released. + +Fri Feb 28 01:45:25 1997 Craig Burley + + * 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 + + * 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 + + * 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 + + 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 . + * intrin.def (FFEINTRIN_impBIT_SIZE, FFEINTRIN_impLEN): + Mark args with `i'. + +Sat Feb 22 13:34:09 1997 Craig Burley + + 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * 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 + + Add libU77 library from Dave Love : + * 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * top.c [BUILT_FOR_270] (ffe_decode_option): Make + -fargument-noalias-global the default. + +Fri Jan 10 07:42:27 1997 Craig Burley + + 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + Patch from Alexandre Oliva : + * 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 + + * Version 0.5.19 released. + +Fri Dec 6 12:23:55 1996 Craig Burley + + * 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 + + * 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 + + * 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 + + 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 + + * 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 + + 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 + + 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 + + * lex.c: Fix last change. + +1996-11-14 Dave Love + + * Make-lang.in, config-lang.in: Remove the (broken) libU77 stuff, + pending 0.5.20. + +Thu Nov 14 15:40:59 1996 Craig Burley + + * bad.def (FFEBAD_UNIMPL_STMT): Explain that invalid + intrinsic references can trigger this message, too. + +1996-11-12 Dave Love + + * lex.c: Declare dwarfout routines. + + * config-lang.in: Sink grep o/p. + +Mon Nov 11 14:21:13 1996 Craig Burley + + * g77.c (main): Might as well print version number + for --verbose as well. + +Thu Nov 7 18:41:41 1996 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + * bad.def (FFEBAD_TYPELESS_TOO_LARGE): Remove this + unused and redundant diagnostic. + +Sat Oct 26 00:45:42 1996 Craig Burley + + * target.c (ffetarget_integerhex): Fix dumb bug. + +1996-10-20 Dave Love + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * Make-lang.in (f77-runtime): + `stmp-hdrs' should have been `stmp-headers'. + +1996-08-20 Dave Love + + * 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 + + * 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 + + * 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 + + 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 + + * 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 + + * 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 + + 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 + + * top.c (ffe_decode_option): -Wall no longer implies + -Wsurprising. + +Sat Apr 13 14:50:06 1996 Craig Burley + + * 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 + + * Version 0.5.18 released. + +Mon Mar 25 20:52:24 1996 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 . + * 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 . + * target.c: Ditto. + * target.h: Ditto. + +Wed Mar 6 14:08:45 1996 Craig Burley + + * top.c (ffe_init_gbe_): Make -frerun-loop-opt the default. + +Mon Mar 4 12:27:00 1996 Craig Burley + + * 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 + + * com.c (ffecom_get_identifier_): Eliminate needless + comparison of results of strchr. + +Tue Dec 26 11:41:56 1995 Craig Burley + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 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 + + * 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 + + * com.h: Make ffecom_f2c_logical_type_node long, consistent with + integer. + +Fri Dec 2 20:07:37 1994 Dave Love + + * 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 + + * Makefile.in (FLAGS_TO_PASS): pass $(CROSS) + * Make-lang.in: more changes to runtime targets + +Thu Nov 24 18:03:21 1994 Dave Love + + * 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 + + * bad.c (ffebad_finish): kluge to fool emacs19 into finding errors: + add trailing space to :: + +Tue Nov 22 11:30:50 1994 Dave Love + + * runtime/libF77/signal_.c (RETSIGTYPE): added + +Mon Nov 21 13:04:13 1994 Dave Love + + * 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 + + * 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: diff --git a/gcc/f/Make-lang.in b/gcc/f/Make-lang.in new file mode 100644 index 00000000000..47585b0e242 --- /dev/null +++ b/gcc/f/Make-lang.in @@ -0,0 +1,516 @@ +# 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/). +# +# 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 > + +# +# 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 + +# +# 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 + +# +# 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* +# +# 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 +# +# 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 +# +# .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) diff --git a/gcc/f/RELEASE-PREP b/gcc/f/RELEASE-PREP new file mode 100644 index 00000000000..71eebf614c4 --- /dev/null +++ b/gcc/f/RELEASE-PREP @@ -0,0 +1,5 @@ +1999-03-13 RELEASE-PREP + +Things to do to prepare a g77 release. + +- Update root.texi: clear DEVELOPMENT flag, set version info. diff --git a/gcc/f/ansify.c b/gcc/f/ansify.c new file mode 100644 index 00000000000..b03206d79e3 --- /dev/null +++ b/gcc/f/ansify.c @@ -0,0 +1,190 @@ +/* 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; +} diff --git a/gcc/f/bad.c b/gcc/f/bad.c new file mode 100644 index 00000000000..bed9734ecc7 --- /dev/null +++ b/gcc/f/bad.c @@ -0,0 +1,537 @@ +/* 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)) + + +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 :: 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); +} diff --git a/gcc/f/bad.def b/gcc/f/bad.def new file mode 100644 index 00000000000..92d7e233030 --- /dev/null +++ b/gcc/f/bad.def @@ -0,0 +1,1103 @@ +/* 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 diff --git a/gcc/f/bad.h b/gcc/f/bad.h new file mode 100644 index 00000000000..bd7581e50d9 --- /dev/null +++ b/gcc/f/bad.h @@ -0,0 +1,106 @@ +/* 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 */ diff --git a/gcc/f/bit.c b/gcc/f/bit.c new file mode 100644 index 00000000000..00f064b1da2 --- /dev/null +++ b/gcc/f/bit.c @@ -0,0 +1,200 @@ +/* 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. */ + + +/* 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 to # bits at through set to + . If is 0, 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 bits in 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 through to . */ + +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 through in + . If is already at the end of the bit array (if + offset == ffebit_size(b)), is set to 0 and 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; + } +} diff --git a/gcc/f/bit.h b/gcc/f/bit.h new file mode 100644 index 00000000000..6b559efe668 --- /dev/null +++ b/gcc/f/bit.h @@ -0,0 +1,84 @@ +/* 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 */ diff --git a/gcc/f/bld-op.def b/gcc/f/bld-op.def new file mode 100644 index 00000000000..737dcc7e2f6 --- /dev/null +++ b/gcc/f/bld-op.def @@ -0,0 +1,69 @@ +/* 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) diff --git a/gcc/f/bld.c b/gcc/f/bld.c new file mode 100644 index 00000000000..ec7c5cd683e --- /dev/null +++ b/gcc/f/bld.c @@ -0,0 +1,3135 @@ +/* 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) + +/* 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; + } +} diff --git a/gcc/f/bld.h b/gcc/f/bld.h new file mode 100644 index 00000000000..900b5dea019 --- /dev/null +++ b/gcc/f/bld.h @@ -0,0 +1,748 @@ +/* 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 */ diff --git a/gcc/f/bugs.texi b/gcc/f/bugs.texi new file mode 100644 index 00000000000..fdc4f159deb --- /dev/null +++ b/gcc/f/bugs.texi @@ -0,0 +1,260 @@ +@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 diff --git a/gcc/f/bugs0.texi b/gcc/f/bugs0.texi new file mode 100644 index 00000000000..9636f4da3d4 --- /dev/null +++ b/gcc/f/bugs0.texi @@ -0,0 +1,9 @@ +\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 diff --git a/gcc/f/com-rt.def b/gcc/f/com-rt.def new file mode 100644 index 00000000000..185aef52d05 --- /dev/null +++ b/gcc/f/com-rt.def @@ -0,0 +1,289 @@ +/* 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) diff --git a/gcc/f/com.c b/gcc/f/com.c new file mode 100644 index 00000000000..a64ef86b172 --- /dev/null +++ b/gcc/f/com.c @@ -0,0 +1,16525 @@ +/* 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 +#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; + +/* 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 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 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; + + /* 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 " + == 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_; +} + +/* 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; +} + +/* 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; +} + +/* 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 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" diff --git a/gcc/f/com.h b/gcc/f/com.h new file mode 100644 index 00000000000..d23db6687a2 --- /dev/null +++ b/gcc/f/com.h @@ -0,0 +1,290 @@ +/* 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 */ diff --git a/gcc/f/config-lang.in b/gcc/f/config-lang.in new file mode 100644 index 00000000000..92ba5cca73e --- /dev/null +++ b/gcc/f/config-lang.in @@ -0,0 +1,36 @@ +# 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" diff --git a/gcc/f/data.c b/gcc/f/data.c new file mode 100644 index 00000000000..2040f0ab6dc --- /dev/null +++ b/gcc/f/data.c @@ -0,0 +1,1877 @@ +/* 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. */ + + +/* 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_ (); +} diff --git a/gcc/f/data.h b/gcc/f/data.h new file mode 100644 index 00000000000..a99369d0b04 --- /dev/null +++ b/gcc/f/data.h @@ -0,0 +1,74 @@ +/* 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 */ diff --git a/gcc/f/equiv.c b/gcc/f/equiv.c new file mode 100644 index 00000000000..bd7ac6d4d24 --- /dev/null +++ b/gcc/f/equiv.c @@ -0,0 +1,1484 @@ +/* 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. */ + + +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 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 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; + } + } + } +} diff --git a/gcc/f/equiv.h b/gcc/f/equiv.h new file mode 100644 index 00000000000..59abfc875ca --- /dev/null +++ b/gcc/f/equiv.h @@ -0,0 +1,100 @@ +/* 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 */ diff --git a/gcc/f/expr.c b/gcc/f/expr.c new file mode 100644 index 00000000000..ef7661dc3ec --- /dev/null +++ b/gcc/f/expr.c @@ -0,0 +1,18571 @@ +/* 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) + +/* 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) case -- it assumes it knows which tokens 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) case -- it assumes it knows which tokens 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 + + 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); +} diff --git a/gcc/f/expr.h b/gcc/f/expr.h new file mode 100644 index 00000000000..b82173bbf0e --- /dev/null +++ b/gcc/f/expr.h @@ -0,0 +1,194 @@ +/* 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 */ diff --git a/gcc/f/ffe.texi b/gcc/f/ffe.texi new file mode 100644 index 00000000000..fd5d3bf349a --- /dev/null +++ b/gcc/f/ffe.texi @@ -0,0 +1,2063 @@ +@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 diff --git a/gcc/f/fini.c b/gcc/f/fini.c new file mode 100644 index 00000000000..167837b461f --- /dev/null +++ b/gcc/f/fini.c @@ -0,0 +1,772 @@ +/* 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]); +} diff --git a/gcc/f/g77.texi b/gcc/f/g77.texi new file mode 100644 index 00000000000..3d5f83d3da6 --- /dev/null +++ b/gcc/f/g77.texi @@ -0,0 +1,11848 @@ +\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) +@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 } 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)}, +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_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)} 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) +@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) +@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) +@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 +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.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 diff --git a/gcc/f/g77spec.c b/gcc/f/g77spec.c new file mode 100644 index 00000000000..3dca7bc4483 --- /dev/null +++ b/gcc/f/g77spec.c @@ -0,0 +1,541 @@ +/* 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 + 2 => last two args were -l -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. */ + 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 -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. */ + 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 } +}; diff --git a/gcc/f/global.c b/gcc/f/global.c new file mode 100644 index 00000000000..8793f62c4a7 --- /dev/null +++ b/gcc/f/global.c @@ -0,0 +1,1586 @@ +/* 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. */ + + +/* 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) +{ +} diff --git a/gcc/f/global.h b/gcc/f/global.h new file mode 100644 index 00000000000..dc499df9eb7 --- /dev/null +++ b/gcc/f/global.h @@ -0,0 +1,193 @@ +/* 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 */ + diff --git a/gcc/f/implic.c b/gcc/f/implic.c new file mode 100644 index 00000000000..c7a28cbc42a --- /dev/null +++ b/gcc/f/implic.c @@ -0,0 +1,383 @@ +/* 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. */ + + +/* 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) +{ +} diff --git a/gcc/f/implic.h b/gcc/f/implic.h new file mode 100644 index 00000000000..44fbfac4e4f --- /dev/null +++ b/gcc/f/implic.h @@ -0,0 +1,74 @@ +/* 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 */ diff --git a/gcc/f/info-b.def b/gcc/f/info-b.def new file mode 100644 index 00000000000..088d108f055 --- /dev/null +++ b/gcc/f/info-b.def @@ -0,0 +1,36 @@ +/* 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", "~") diff --git a/gcc/f/info-k.def b/gcc/f/info-k.def new file mode 100644 index 00000000000..9e6052d6150 --- /dev/null +++ b/gcc/f/info-k.def @@ -0,0 +1,41 @@ +/* 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 ": In function `foo': ". */ + +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", "~") diff --git a/gcc/f/info-w.def b/gcc/f/info-w.def new file mode 100644 index 00000000000..57e3f8c6d62 --- /dev/null +++ b/gcc/f/info-w.def @@ -0,0 +1,41 @@ +/* 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", "~") diff --git a/gcc/f/info.c b/gcc/f/info.c new file mode 100644 index 00000000000..3c0030f27f8 --- /dev/null +++ b/gcc/f/info.c @@ -0,0 +1,303 @@ +/* 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. */ + + +/* 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 diff --git a/gcc/f/info.h b/gcc/f/info.h new file mode 100644 index 00000000000..69defd27ab6 --- /dev/null +++ b/gcc/f/info.h @@ -0,0 +1,186 @@ +/* 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 */ diff --git a/gcc/f/intdoc.c b/gcc/f/intdoc.c new file mode 100644 index 00000000000..b24c79a4811 --- /dev/null +++ b/gcc/f/intdoc.c @@ -0,0 +1,1325 @@ +/* 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; + } +} diff --git a/gcc/f/intdoc.in b/gcc/f/intdoc.in new file mode 100644 index 00000000000..6f2423f6cac --- /dev/null +++ b/gcc/f/intdoc.in @@ -0,0 +1,2705 @@ +/* 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. +") diff --git a/gcc/f/intdoc.texi b/gcc/f/intdoc.texi new file mode 100644 index 00000000000..e657510a060 --- /dev/null +++ b/gcc/f/intdoc.texi @@ -0,0 +1,10931 @@ +@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 diff --git a/gcc/f/intrin.c b/gcc/f/intrin.c new file mode 100644 index 00000000000..a379684ae4c --- /dev/null +++ b/gcc/f/intrin.c @@ -0,0 +1,2119 @@ +/* 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 +}; + + +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; + } +} diff --git a/gcc/f/intrin.def b/gcc/f/intrin.def new file mode 100644 index 00000000000..5d712ba21c0 --- /dev/null +++ b/gcc/f/intrin.def @@ -0,0 +1,3358 @@ +/* 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: + + ::[,...] + + is: + + [] + + 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 + + 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 + + is: + + * Valid for of `A' only, means program may + declare any length for return value, default being (*) + + is: + + + + 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 + + is: + + =[][][][] + + is the standard keyword name for the argument. + + 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 + + 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) + + 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 + + is: + + (Default) CHARACTER*(*) + [n] CHARACTER*n + + is: + + (default) Rank-0 (variable or array element) + (n) Rank-1 array n elements long + & Any (arg-extra is &) + + 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", ,,, "") diff --git a/gcc/f/intrin.h b/gcc/f/intrin.h new file mode 100644 index 00000000000..e741e69b4ec --- /dev/null +++ b/gcc/f/intrin.h @@ -0,0 +1,135 @@ +/* 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 */ diff --git a/gcc/f/invoke.texi b/gcc/f/invoke.texi new file mode 100644 index 00000000000..fd1b80412a6 --- /dev/null +++ b/gcc/f/invoke.texi @@ -0,0 +1,2233 @@ +@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 diff --git a/gcc/f/lab.c b/gcc/f/lab.c new file mode 100644 index 00000000000..1d278748b21 --- /dev/null +++ b/gcc/f/lab.c @@ -0,0 +1,157 @@ +/* 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. */ + + +/* 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; +} diff --git a/gcc/f/lab.h b/gcc/f/lab.h new file mode 100644 index 00000000000..f3f89868a54 --- /dev/null +++ b/gcc/f/lab.h @@ -0,0 +1,152 @@ +/* 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 */ diff --git a/gcc/f/lang-specs.h b/gcc/f/lang-specs.h new file mode 100644 index 00000000000..9ed51ef5a60 --- /dev/null +++ b/gcc/f/lang-specs.h @@ -0,0 +1,47 @@ +/* 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}, diff --git a/gcc/f/lang.opt b/gcc/f/lang.opt new file mode 100644 index 00000000000..d6a53b7dcd1 --- /dev/null +++ b/gcc/f/lang.opt @@ -0,0 +1,402 @@ +; 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- Set the maximum line length to + +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. diff --git a/gcc/testsuite/g77.f-torture/execute/io1.f b/gcc/testsuite/g77.f-torture/execute/io1.f new file mode 100644 index 00000000000..c5242446a49 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/io1.f @@ -0,0 +1,10 @@ +* 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 diff --git a/gcc/testsuite/g77.f-torture/execute/io1.x b/gcc/testsuite/g77.f-torture/execute/io1.x new file mode 100644 index 00000000000..6a69a3aadab --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/io1.x @@ -0,0 +1,13 @@ +# 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 diff --git a/gcc/testsuite/g77.f-torture/execute/labug1.f b/gcc/testsuite/g77.f-torture/execute/labug1.f new file mode 100644 index 00000000000..032fa41f899 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/labug1.f @@ -0,0 +1,57 @@ + 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 + + + + + + + + + + diff --git a/gcc/testsuite/g77.f-torture/execute/large_vec.f b/gcc/testsuite/g77.f-torture/execute/large_vec.f new file mode 100644 index 00000000000..0af5b1b0b3f --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/large_vec.f @@ -0,0 +1,3 @@ + parameter (nmax=165000) + double precision x(nmax) + end diff --git a/gcc/testsuite/g77.f-torture/execute/le.f b/gcc/testsuite/g77.f-torture/execute/le.f new file mode 100644 index 00000000000..74e42750d55 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/le.f @@ -0,0 +1,29 @@ + 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 diff --git a/gcc/testsuite/g77.f-torture/execute/select.f b/gcc/testsuite/g77.f-torture/execute/select.f new file mode 100644 index 00000000000..f1024330a71 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/select.f @@ -0,0 +1,173 @@ +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 + + + + + diff --git a/gcc/testsuite/g77.f-torture/execute/short.f b/gcc/testsuite/g77.f-torture/execute/short.f new file mode 100644 index 00000000000..89ae273891c --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/short.f @@ -0,0 +1,57 @@ + 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 + diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f new file mode 100644 index 00000000000..f502bc72833 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/u77-test.f @@ -0,0 +1,421 @@ +*** 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 diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.x b/gcc/testsuite/g77.f-torture/execute/u77-test.x new file mode 100644 index 00000000000..e4b89008c25 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/u77-test.x @@ -0,0 +1,12 @@ +# 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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f new file mode 100644 index 00000000000..0cc9087d6cb --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f @@ -0,0 +1,89 @@ +* Resent-From: Craig Burley +* 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 +* 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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f new file mode 100644 index 00000000000..25b7c5b2b52 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f @@ -0,0 +1,13 @@ + 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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f b/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f new file mode 100644 index 00000000000..86d2a939064 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f @@ -0,0 +1,648 @@ +* 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" +* To: Craig Burley +* 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) diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f new file mode 100644 index 00000000000..026d05e4b3c --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f @@ -0,0 +1,8 @@ +* =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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/9263.f b/gcc/testsuite/g77.f-torture/noncompile/9263.f new file mode 100644 index 00000000000..e68b3e0a65f --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/9263.f @@ -0,0 +1,7 @@ + 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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/970626-2.f b/gcc/testsuite/g77.f-torture/noncompile/970626-2.f new file mode 100644 index 00000000000..c1e2348646f --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/970626-2.f @@ -0,0 +1,4 @@ + SUBROUTINE A(A,ALPHA,IA) + COMPLEX A(IA,*), ALPHA(*) + ALPHA(I)=A(I,I).ZERO) + END diff --git a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f new file mode 100644 index 00000000000..316969f6aa8 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f @@ -0,0 +1,10 @@ +* Fixed by JCB 1998-07-25 change to stc.c. + +* Date: Thu, 11 Jun 1998 22:35:20 -0500 +* From: Ian A Watson +* Subject: crash +* + CaLL foo(W) + END + SUBROUTINE foo(W) + yy(I)=A(I)Q(X) diff --git a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f new file mode 100644 index 00000000000..bd5e74022a3 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f @@ -0,0 +1,8 @@ +* 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 +* Subject: Mangler Crash + EQUIVALENCE(I,glerf(P)) + COMMON /foo/ glerf(3) diff --git a/gcc/testsuite/g77.f-torture/noncompile/check0.f b/gcc/testsuite/g77.f-torture/noncompile/check0.f new file mode 100644 index 00000000000..fc3c6ca730e --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/check0.f @@ -0,0 +1,11 @@ +CCC Abort fixed by: +CCC1998-04-21 Jim Wilson +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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp new file mode 100644 index 00000000000..fadd1fbbe5a --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp @@ -0,0 +1,36 @@ +# 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 + diff --git a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f new file mode 100644 index 00000000000..f7dad339a81 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f @@ -0,0 +1,10 @@ + integer*1 one + integer*2 two + parameter (one=1) + parameter (two=2) + select case (I) + case (one) + case (two) + end select + end + diff --git a/libjava/doc/cni.sgml b/libjava/doc/cni.sgml new file mode 100644 index 00000000000..495e3e9c5a5 --- /dev/null +++ b/libjava/doc/cni.sgml @@ -0,0 +1,996 @@ + +
+ +The Cygnus Native Interface for C++/Java Integration +Writing native Java methods in natural C++ + +Cygnus Solutions + +March, 2000 + + + +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). + + +Basic Concepts + +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. + + +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 +gcj uses the same compiler technology as +g++ (the GNU C++ compiler), it is possible +to make the intersection of the two languages use the same +ABI (object representation and calling conventions). +The key idea in CNI 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. + + +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++.) + +You start with: + +#include <gcj/cni.h> + + + +You then include header files for the various Java classes you need +to use: + +#include <java/lang/Character.h> +#include <java/util/Date.h> +#include <java/lang/IndexOutOfBoundsException.h> + + + +In general, CNI functions and macros start with the +`Jv' prefix, for example the function +`JvNewObjectArray'. This convention is used to +avoid conflicts with other libraries. +Internal functions in CNI start with the prefix +`_Jv_'. 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 _Jv_AllocBytes +as an example; CNI should instead provide +a JvAllocBytes function.) + +These header files are automatically generated by gcjh. + + + +Packages + +The only global names in Java are class names, and packages. +A package 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. + + +A Java package is mapped to a C++ namespace. +The Java class java.lang.String +is in the package java.lang, which is a sub-package +of java. The C++ equivalent is the +class java::lang::String, +which is in the namespace java::lang, +which is in the namespace java. + + +Here is how you could express this: + +// 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 +{ + ... +}; + + + +The gcjh tool automatically generates the +nessary namespace declarations. + +Nested classes as a substitute for namespaces + + +It is not that long since g++ got complete namespace support, +and it was very recent (end of February 1999) that libgcj +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: + +class java { + class lang { + class Object; + class String; + }; +}; + +The obvious difference is the use of class instead +of namespace. 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: + +class java::lang::String : public java::lang::Object +{ ... } + +Note that the generated code (including name mangling) +using nested classes is the same as that using namespaces. + + +Leaving out package names + + +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 package declaration specifies that the +following class declarations are in the named package, without having +to explicitly name the full package qualifiers. +The package declaration can be followed by zero or +more import 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 using declaration and directive. + + +A Java simple-type-import declaration: + +import PackageName.TypeName; + +allows using TypeName as a shorthand for +PackageName.TypeName. +The C++ (more-or-less) equivalent is a using-declaration: + +using PackageName::TypeName; + + + +A Java import-on-demand declaration: + +import PackageName.*; + +allows using TypeName as a shorthand for +PackageName.TypeName +The C++ (more-or-less) equivalent is a using-directive: + +using namespace PackageName; + + + + + +Primitive types + +Java provides 8 primitives types: +byte, short, int, +long, float, double, +char, and boolean. +These are the same as the following C++ typedefs +(which are defined by gcj/cni.h): +jbyte, jshort, jint, +jlong, jfloat, +jdouble, +jchar, and jboolean. +You should use the C++ typenames +(e.g. jint), +and not the Java types names +(e.g. int), +even if they are the same. +This is because there is no guarantee that the C++ type +int is a 32-bit type, but jint +is guaranteed to be a 32-bit type. + + + + + +Java type +C/C++ typename +Description + + + +byte +jbyte +8-bit signed integer + + +short +jshort +16-bit signed integer + + +int +jint +32-bit signed integer + + +long +jlong +64-bit signed integer + + +float +jfloat +32-bit IEEE floating-point number + + +double +jdouble +64-bit IEEE floating-point number + + +char +jchar +16-bit Unicode character + + +boolean +jboolean +logical (Boolean) values + + +void +void +no value + + + + + + + +JvPrimClass +primtype + +This is a macro whose argument should be the name of a primitive +type, e.g. +byte. +The macro expands to a pointer to the Class object +corresponding to the primitive type. +E.g., +JvPrimClass(void) +has the same value as the Java expression +Void.TYPE (or void.class). + + + + +Objects and Classes +Classes + +All Java classes are derived from java.lang.Object. +C++ does not have a unique rootclass, but we use +a C++ java::lang::Object as the C++ version +of the java.lang.Object Java class. All +other Java classes are mapped into corresponding C++ classes +derived from java::lang::Object. + +Interface inheritance (the implements +keyword) is currently not reflected in the C++ mapping. + +Object references + +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 null Java reference maps to the NULL +C++ pointer. + + +Note that in some Java implementations an object reference is implemented as +a pointer to a two-word handle. 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. + + +Object fields + +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 in front of 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.) + + +The fields are laid out in the same order, alignment, and size +as in C++. Specifically, 8-bite and 16-bit native types +(byte, short, char, +and boolean) are not +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. + +If you include the gcjh-generated header for a +class, you can access fields of Java classes in the natural +way. Given the following Java class: + +public class Int +{ + public int i; + public Integer (int i) { this.i = i; } + public static zero = new Integer(0); +} + +you can write: + +#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); +} + + + +CNI 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. + + + + +Arrays + +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 +java.lang.Object). An array-valued variable +is one that contains a reference (pointer) to an array object. + + +Referencing a Java array in C++ code is done using the +JArray template, which as defined as follows: + +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]; } +}; + + + + template<class T> T *elements + JArray<T> &array + + This template function can be used to get a pointer to the + elements of the array. + For instance, you can fetch a pointer + to the integers that make up an int[] like so: + +extern jintArray foo; +jint *intp = elements (foo); + +The name of this function may change in the future. + +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: + +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; + + + + You can create an array of objects using this function: + + jobjectArray JvNewObjectArray + jint length + jclass klass + jobject init + + Here klass is the type of elements of the array; + init is the initial + value to be put into every slot in the array. + + +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 + `JvNew<Type>Array', + where `<Type>' is the name of + the primitive type, with its initial letter in upper-case. For + instance, `JvNewBooleanArray' can be used to create + a new array of booleans. + Each such function follows this example: + + jbooleanArray JvNewBooleanArray + jint length + + + + + jsize JvGetArrayLength + jarray array + + Returns the length of array. + + +Methods + + +Java methods are mapped directly into C++ methods. +The header files generated by gcjh +include the appropriate method definitions. +Basically, the generated methods have the same names and +corresponding types as the Java methods, +and are called in the natural manner. + +Overloading + +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 gcjh the C++ compiler will choose +the expected one. + +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 mangling, +and the encoded name is the mangled name. +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 same encoding scheme. + + + +Static methods + +Static Java methods are invoked in CNI using the standard +C++ syntax, using the `::' operator rather +than the `.' operator. For example: + + +jint i = java::lang::Math::round((jfloat) 2.3); + + + +Defining a static native method uses standard C++ method +definition syntax. For example: + +#include <java/lang/Integer.h> +java::lang::Integer* +java::lang::Integer::getInteger(jstring str) +{ + ... +} + + + +Object Constructors + +Constructors are called implicitly as part of object allocation +using the new operator. For example: + +java::lang::Int x = new java::lang::Int(234); + + + + +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. + + + +Instance methods + + +Virtual method dispatch is handled essentially the same way +in C++ and Java -- i.e. 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 gcj. +During 1999, G++ will switch to a new ABI that is compatible with +gcj. Some platforms (including Linux) have already +changed. On other platforms, you will have to pass +the -fvtable-thunks flag to g++ when +compiling CNI code. Note that you must also compile +your C++ source code with -fno-rtti. + + +Calling a Java instance method in CNI is done +using the standard C++ syntax. For example: + + java::lang::Number *x; + if (x->doubleValue() > 0.0) ... + + + +Defining a Java native instance method is also done the natural way: + +#include <java/lang/Integer.h> +jdouble +java::lang:Integer::doubleValue() +{ + return (jdouble) value; +} + + + + +Interface method calls + +In Java you can call a method using an interface reference. +This is not yet supported in CNI. + + + +Object allocation + + +New Java objects are allocated using a +class-instance-creation-expression: + +new Type ( arguments ) + +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 CNI, 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: + +java::util::Hashtable *ht = new java::util::Hashtable(120); + + + + + void *_Jv_AllocBytes + jsize size + + Allocate size 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. + + + +Interfaces + +A Java class can implement zero or more +interfaces, in addition to inheriting from +a single base class. +An interface is a collection of constants and method specifications; +it is similar to the signatures 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 gcj. + + + +Strings + +CNI provides a number of utility functions for +working with Java String objects. +The names and interfaces are analogous to those of JNI. + + + + + jstring JvNewString + const jchar *chars + jsize len + + Creates a new Java String object, where + chars are the contents, and + len is the number of characters. + + + + + jstring JvNewStringLatin1 + const char *bytes + jsize len + + Creates a new Java String object, where bytes + are the Latin-1 encoded + characters, and len is the length of + bytes, in bytes. + + + + + jstring JvNewStringLatin1 + const char *bytes + + Like the first JvNewStringLatin1, but computes len + using strlen. + + + + + jstring JvNewStringUTF + const char *bytes + + Creates a new Java String object, where bytes are + the UTF-8 encoded characters of the string, terminated by a null byte. + + + + + jchar *JvGetStringChars + jstring str + + Returns a pointer to the array of characters which make up a string. + + + + + int JvGetStringUTFLength + jstring str + + Returns number of bytes required to encode contents + of str as UTF-8. + + + + + jsize JvGetStringUTFRegion + jstring str + jsize start + jsize len + char *buf + + This puts the UTF-8 encoding of a region of the + string str into + the buffer buf. + The region of the string to fetch is specifued by + start and len. + It is assumed that buf is big enough + to hold the result. Note + that buf is not null-terminated. + + + +Class Initialization + +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 +String objects corresponding to string literals in +the code. + +The Gcj compiler inserts calls to JvInitClass (actually +_Jv_InitClass) 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. + +First, libgcj will make sure a class is initialized +before an instance of that object is created. This is one +of the responsibilities of the new operation. This is +taken care of both in Java code, and in C++ code. (When the G++ +compiler sees a new of a Java class, it will call +a routine in libgcj 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. + +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 JvInitClass +before doing anything else in the method (unless you are sure +it is safe to leave it out). + +Accessing a static field also requires the class of the +field to be initialized. The Java compiler will generate code +to call _Jv_InitClass 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. + +Exception Handling + +While C++ and Java share a common exception handling framework, +things are not yet perfectly integrated. The main issue is that the +run-time type information facilities of the two +languages are not integrated. + +Still, things work fairly well. You can throw a Java exception from +C++ using the ordinary throw construct, and this +exception can be caught by Java code. Similarly, you can catch an +exception thrown from Java using the C++ catch +construct. + +Note that currently you cannot mix C++ catches and Java catches in +a single C++ translation unit. We do intend to fix this eventually. + + +Here is an example: + +if (i >= count) + throw new java::lang::IndexOutOfBoundsException(); + + + +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: + + struct S { ~S(); }; + extern void bar(); // is implemented in Java and may throw exceptions + void foo() + { + S s; + bar(); + } + +The usual effect of an incorrect guess is a link failure, complaining of +a missing routine called __gxx_personality_v0. + + +You can inform the compiler that Java exceptions are to be used in a +translation unit, irrespective of what it might think, by writing +#pragma GCC java_exceptions at the head of the +file. This #pragma must appear before any +functions that throw or catch exceptions, or run destructors when +exceptions are thrown through them. + + +Synchronization + +Each Java object has an implicit monitor. +The Java VM uses the instruction monitorenter to acquire +and lock a monitor, and monitorexit to release it. +The JNI has corresponding methods MonitorEnter +and MonitorExit. The corresponding CNI macros +are JvMonitorEnter and JvMonitorExit. + + +The Java source language does not provide direct access to these primitives. +Instead, there is a synchronized statement that does an +implicit monitorenter before entry to the block, +and does a monitorexit 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 +try-finally. + + +From C++, it makes sense to use a destructor to release a lock. +CNI defines the following utility class. + +class JvSynchronize() { + jobject obj; + JvSynchronize(jobject o) { obj = o; JvMonitorEnter(o); } + ~JvSynchronize() { JvMonitorExit(obj); } +}; + +The equivalent of Java's: + +synchronized (OBJ) { CODE; } + +can be simply expressed: + +{ JvSynchronize dummy(OBJ); CODE; } + + + +Java also has methods with the synchronized attribute. +This is equivalent to wrapping the entire method body in a +synchronized 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 gcj +the synchronized 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 JvSynchronize +in a native synchornized method. + + +Reflection +The types jfieldID and jmethodID +are as in JNI. + +The function JvFromReflectedField, +JvFromReflectedMethod, +JvToReflectedField, and +JvToFromReflectedMethod (as in Java 2 JNI) +will be added shortly, as will other functions corresponding to JNI. + +Using gcjh + + The gcjh is used to generate C++ header files from + Java class files. By default, gcjh 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: + + + +--classpath path +--CLASSPATH path +-I dir + + 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. + + + + +-d directory + +Puts the generated .h files +beneath directory. + + + + +-o file + + Sets the name of the .h file to be generated. + By default the .h file is named after the class. + This option only really makes sense if just a single class file + is specified. + + + + +--verbose + + gcjh will print information to stderr as it works. + + + + +-M +-MM +-MD +-MMD + + These options can be used to generate dependency information + for the generated header file. They work the same way as the + corresponding compiler options. + + + + +-prepend text + +This causes the text 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. + + + + +-friend text + +This causes the text to be put into the class +declaration after a friend 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. + + + + +-add text + +The text is inserted into the class declaration. +This option should be used with caution. + + + + +-append text + +The text 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. + + + + +All other options not beginning with a - are treated +as the names of classes for which headers should be generated. + +gcjh will generate all the required namespace declarations and +#include's for the header file. +In some situations, gcjh will generate simple inline member +functions. Note that, while gcjh puts #pragma +interface in the generated header file, you should +not put #pragma implementation +into your C++ source file. If you do, duplicate definitions of +inline functions will sometimes be created, leading to link-time +errors. + + +There are a few cases where gcjh will fail to work properly: + +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. + +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. + +Eventually we hope to change the C++ compiler so that these +restrictions can be lifted. + + +
diff --git a/libjava/gnu/javax/rmi/CORBA/DelegateFactory.java b/libjava/gnu/javax/rmi/CORBA/DelegateFactory.java new file mode 100644 index 00000000000..c98549b4059 --- /dev/null +++ b/libjava/gnu/javax/rmi/CORBA/DelegateFactory.java @@ -0,0 +1,74 @@ +/* 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); + } + } +} diff --git a/libjava/gnu/javax/rmi/CORBA/GetDelegateInstanceException.java b/libjava/gnu/javax/rmi/CORBA/GetDelegateInstanceException.java new file mode 100644 index 00000000000..27b84f12239 --- /dev/null +++ b/libjava/gnu/javax/rmi/CORBA/GetDelegateInstanceException.java @@ -0,0 +1,58 @@ +/* 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); + } +} diff --git a/libjava/gnu/javax/rmi/CORBA/PortableRemoteObjectDelegateImpl.java b/libjava/gnu/javax/rmi/CORBA/PortableRemoteObjectDelegateImpl.java new file mode 100644 index 00000000000..973c4c4f89f --- /dev/null +++ b/libjava/gnu/javax/rmi/CORBA/PortableRemoteObjectDelegateImpl.java @@ -0,0 +1,133 @@ +/* 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); + } + +} diff --git a/libjava/gnu/javax/rmi/CORBA/StubDelegateImpl.java b/libjava/gnu/javax/rmi/CORBA/StubDelegateImpl.java new file mode 100644 index 00000000000..894e50236fd --- /dev/null +++ b/libjava/gnu/javax/rmi/CORBA/StubDelegateImpl.java @@ -0,0 +1,113 @@ +/* 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"); + } + +} diff --git a/libjava/gnu/javax/rmi/CORBA/UtilDelegateImpl.java b/libjava/gnu/javax/rmi/CORBA/UtilDelegateImpl.java new file mode 100644 index 00000000000..70b2e60c673 --- /dev/null +++ b/libjava/gnu/javax/rmi/CORBA/UtilDelegateImpl.java @@ -0,0 +1,152 @@ +/* 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"); + } +} diff --git a/libjava/gnu/javax/rmi/CORBA/ValueHandlerImpl.java b/libjava/gnu/javax/rmi/CORBA/ValueHandlerImpl.java new file mode 100644 index 00000000000..6935aa68c4c --- /dev/null +++ b/libjava/gnu/javax/rmi/CORBA/ValueHandlerImpl.java @@ -0,0 +1,82 @@ +/* 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"); + } +} diff --git a/libjava/gnu/javax/rmi/PortableServer.java b/libjava/gnu/javax/rmi/PortableServer.java new file mode 100644 index 00000000000..b5022cab7b3 --- /dev/null +++ b/libjava/gnu/javax/rmi/PortableServer.java @@ -0,0 +1,142 @@ +/* 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; + } +} diff --git a/libjava/javax/rmi/BAD_OPERATION.java b/libjava/javax/rmi/BAD_OPERATION.java new file mode 100644 index 00000000000..36081a47c57 --- /dev/null +++ b/libjava/javax/rmi/BAD_OPERATION.java @@ -0,0 +1,4 @@ +package javax.rmi; + +/** XXX - Stub till we have org.omg.CORBA */ +public class BAD_OPERATION extends Exception { } diff --git a/libjava/javax/rmi/CORBA/ClassDesc.java b/libjava/javax/rmi/CORBA/ClassDesc.java new file mode 100644 index 00000000000..052046df926 --- /dev/null +++ b/libjava/javax/rmi/CORBA/ClassDesc.java @@ -0,0 +1,55 @@ +/* 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() + { + } +} diff --git a/libjava/javax/rmi/CORBA/ObjectImpl.java b/libjava/javax/rmi/CORBA/ObjectImpl.java new file mode 100644 index 00000000000..d76d673cede --- /dev/null +++ b/libjava/javax/rmi/CORBA/ObjectImpl.java @@ -0,0 +1,9 @@ +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; } +} diff --git a/libjava/javax/rmi/CORBA/PortableRemoteObjectDelegate.java b/libjava/javax/rmi/CORBA/PortableRemoteObjectDelegate.java new file mode 100644 index 00000000000..a073cf4705c --- /dev/null +++ b/libjava/javax/rmi/CORBA/PortableRemoteObjectDelegate.java @@ -0,0 +1,63 @@ +/* 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; +} diff --git a/libjava/javax/rmi/CORBA/Stub.java b/libjava/javax/rmi/CORBA/Stub.java new file mode 100644 index 00000000000..c79b85cb46e --- /dev/null +++ b/libjava/javax/rmi/CORBA/Stub.java @@ -0,0 +1,120 @@ +/* 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); + } + +} diff --git a/libjava/javax/rmi/CORBA/StubDelegate.java b/libjava/javax/rmi/CORBA/StubDelegate.java new file mode 100644 index 00000000000..6c7f69fe7dc --- /dev/null +++ b/libjava/javax/rmi/CORBA/StubDelegate.java @@ -0,0 +1,65 @@ +/* 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; +} diff --git a/libjava/javax/rmi/CORBA/SystemException.java b/libjava/javax/rmi/CORBA/SystemException.java new file mode 100644 index 00000000000..f8afdc35e35 --- /dev/null +++ b/libjava/javax/rmi/CORBA/SystemException.java @@ -0,0 +1,4 @@ +package javax.rmi.CORBA; + +/** XXX - Stub till we have org.omg.CORBA */ +public class SystemException extends Exception { } diff --git a/libjava/javax/rmi/CORBA/Tie.java b/libjava/javax/rmi/CORBA/Tie.java new file mode 100644 index 00000000000..ca14e3d4236 --- /dev/null +++ b/libjava/javax/rmi/CORBA/Tie.java @@ -0,0 +1,62 @@ +/* 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(); +} diff --git a/libjava/javax/rmi/CORBA/Util.java b/libjava/javax/rmi/CORBA/Util.java new file mode 100644 index 00000000000..45a189d97c5 --- /dev/null +++ b/libjava/javax/rmi/CORBA/Util.java @@ -0,0 +1,187 @@ +/* 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); + } + +} diff --git a/libjava/javax/rmi/CORBA/UtilDelegate.java b/libjava/javax/rmi/CORBA/UtilDelegate.java new file mode 100644 index 00000000000..4d611bc8bfb --- /dev/null +++ b/libjava/javax/rmi/CORBA/UtilDelegate.java @@ -0,0 +1,84 @@ +/* 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); +} diff --git a/libjava/javax/rmi/CORBA/ValueHandler.java b/libjava/javax/rmi/CORBA/ValueHandler.java new file mode 100644 index 00000000000..3a008f18cca --- /dev/null +++ b/libjava/javax/rmi/CORBA/ValueHandler.java @@ -0,0 +1,63 @@ +/* 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); +} diff --git a/libjava/javax/rmi/ORB.java b/libjava/javax/rmi/ORB.java new file mode 100644 index 00000000000..be7a894e65a --- /dev/null +++ b/libjava/javax/rmi/ORB.java @@ -0,0 +1,4 @@ +package javax.rmi; + +/** XXX - Stub till we have org.omg.CORBA */ +public class ORB { } diff --git a/libjava/javax/rmi/PortableRemoteObject.java b/libjava/javax/rmi/PortableRemoteObject.java new file mode 100644 index 00000000000..ee40d9c9e74 --- /dev/null +++ b/libjava/javax/rmi/PortableRemoteObject.java @@ -0,0 +1,114 @@ +/* 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); + } + +} diff --git a/libstdc++-v3/testsuite/20_util/allocator/1.cc b/libstdc++-v3/testsuite/20_util/allocator/1.cc new file mode 100644 index 00000000000..d34c8daf9c9 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/allocator/1.cc @@ -0,0 +1,71 @@ +// 2001-06-14 Benjamin Kosnik + +// 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 +#include +#include +#include + +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; +#endif + +void test01() +{ + bool test __attribute__((unused)) = true; + std::allocator 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; +} + diff --git a/libstdc++-v3/testsuite/20_util/allocator/10378.cc b/libstdc++-v3/testsuite/20_util/allocator/10378.cc new file mode 100644 index 00000000000..2ac77eaaf16 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/allocator/10378.cc @@ -0,0 +1,51 @@ +// 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 +#include +#include + +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 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 >; +#endif + +int main() +{ + test01(); + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/allocator/14176.cc b/libstdc++-v3/testsuite/20_util/allocator/14176.cc new file mode 100644 index 00000000000..cb8a2f5c4bf --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/allocator/14176.cc @@ -0,0 +1,42 @@ +// 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 +#include + +// libstdc++/14176 +void test02() +{ + unsigned int len = 0; + std::allocator 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; +#endif + +int main() +{ + test02(); + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/allocator/8230.cc b/libstdc++-v3/testsuite/20_util/allocator/8230.cc new file mode 100644 index 00000000000..95b6cbee55f --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/allocator/8230.cc @@ -0,0 +1,59 @@ +// 2001-06-14 Benjamin Kosnik + +// 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 +#include +#include + +// libstdc++/8230 +void test02() +{ + bool test __attribute__((unused)) = true; + try + { + std::allocator alloc; + const std::allocator::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; +#endif + +int main() +{ + test02(); + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/1.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/1.cc new file mode 100644 index 00000000000..8e150b0187c --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/1.cc @@ -0,0 +1,95 @@ +// 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 +#include + +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_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_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_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; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/2.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/2.cc new file mode 100644 index 00000000000..6ce31d1fe88 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/2.cc @@ -0,0 +1,85 @@ +// 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 +#include + +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_from_A(new A); + std::auto_ptr B_from_B(new B); + + std::auto_ptr A_from_ptr_A(A_from_A); + std::auto_ptr 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; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/3.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/3.cc new file mode 100644 index 00000000000..8090d277783 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/3.cc @@ -0,0 +1,87 @@ +// 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 +#include + +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_from_ptr_A; + std::auto_ptr A_from_ptr_B; + std::auto_ptr A_from_A(new A); + std::auto_ptr 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; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/3946.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/3946.cc new file mode 100644 index 00000000000..191ba6f9306 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/3946.cc @@ -0,0 +1,45 @@ +// 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 +#include + +// libstdc++/3946 +// http://gcc.gnu.org/ml/libstdc++/2002-07/msg00024.html +struct Base { }; +struct Derived : public Base { }; + +std::auto_ptr +conversiontest08() { return std::auto_ptr(new Derived); } + +void +test08() +{ + std::auto_ptr ptr; + ptr = conversiontest08(); +} + + +int +main() +{ + test08(); + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/4.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/4.cc new file mode 100644 index 00000000000..18148005573 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/4.cc @@ -0,0 +1,83 @@ +// 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 +#include + +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_from_A(new A); + std::auto_ptr A_from_B(new B); + std::auto_ptr 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; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/5.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/5.cc new file mode 100644 index 00000000000..77969816496 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/5.cc @@ -0,0 +1,87 @@ +// 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 +#include + +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 +class pimpl +{ +public: + pimpl() : p_impl(new T) {} +private: + std::auto_ptr p_impl; +}; + +int +test05() +{ + bool test __attribute__((unused)) = true; + reset_count_struct __attribute__((unused)) reset; + + pimpl(); + pimpl(); + 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; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/6.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/6.cc new file mode 100644 index 00000000000..e4e13d9d6b0 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/6.cc @@ -0,0 +1,91 @@ +// 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 +#include + +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_from_A(new A); + std::auto_ptr 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; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/7.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/7.cc new file mode 100644 index 00000000000..a77ba51cb58 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/7.cc @@ -0,0 +1,91 @@ +// 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 +#include + +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 +static std::auto_ptr source() +{ + return std::auto_ptr(new T); +} + +template +static void drain(std::auto_ptr) +{} + +int +test07() +{ + bool test __attribute__((unused)) = true; + reset_count_struct __attribute__((unused)) reset; + + drain(source()); + // The resolution of core issue 84, now a DR, breaks this call. + // drain(source()); + drain(source()); + 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; +} diff --git a/libstdc++-v3/testsuite/20_util/auto_ptr/assign_neg.cc b/libstdc++-v3/testsuite/20_util/auto_ptr/assign_neg.cc new file mode 100644 index 00000000000..55291676f3d --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/auto_ptr/assign_neg.cc @@ -0,0 +1,50 @@ +// { 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 +#include + +// via Jack Reeves +// libstdc++/3946 +// http://gcc.gnu.org/ml/libstdc++/2002-07/msg00024.html +struct Base { }; +struct Derived : public Base { }; + +std::auto_ptr +foo() { return std::auto_ptr(new Derived); } + +int +test01() +{ + std::auto_ptr 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 } diff --git a/libstdc++-v3/testsuite/20_util/pair/1.cc b/libstdc++-v3/testsuite/20_util/pair/1.cc new file mode 100644 index 00000000000..7ccee6dd569 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/pair/1.cc @@ -0,0 +1,79 @@ +// 2001-06-18 Benjamin Kosnik + +// 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 +#include + +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 + 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 p_bl_1(true, 433); + std::pair p_bl_2 = std::make_pair(true, 433); + VERIFY( p_bl_1 == p_bl_2 ); + VERIFY( !(p_bl_1 < p_bl_2) ); + + std::pair p_sf_1("total enlightenment", 433.00); + std::pair 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 p_sg_1("enlightenment", gnu_obj(5)); + std::pair 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_obj> p_st_1(gnu_t(false), gnu_obj(5)); + std::pair, gnu_obj> p_st_2 = std::make_pair(gnu_t(false), + gnu_obj(5)); + VERIFY( p_st_1 == p_st_2 ); + VERIFY( !(p_st_1 < p_st_2) ); +} + +int main() +{ + test01(); + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/pair/2.cc b/libstdc++-v3/testsuite/20_util/pair/2.cc new file mode 100644 index 00000000000..82d928c2d01 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/pair/2.cc @@ -0,0 +1,60 @@ +// 2001-06-18 Benjamin Kosnik + +// 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 +#include + +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 + 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 p_bb_1(true, false); + std::pair 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; +} diff --git a/libstdc++-v3/testsuite/20_util/pair/3.cc b/libstdc++-v3/testsuite/20_util/pair/3.cc new file mode 100644 index 00000000000..bac0e7eb974 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/pair/3.cc @@ -0,0 +1,79 @@ +// 2001-06-18 Benjamin Kosnik + +// 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 +#include + +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 + 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 p_bl_1(true, 433); + const std::pair 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 p_sf_1("total enlightenment", 433.00); + const std::pair 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 p_sg_1("enlightenment", gnu_obj(5)); + const std::pair 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_obj> p_st_1(gnu_t(false), gnu_obj(5)); + const std::pair, gnu_obj> p_st_2 = + std::make_pair(gnu_t(false), gnu_obj(5)); + VERIFY( p_st_1 == p_st_2 ); + VERIFY( !(p_st_1 < p_st_2) ); +} + +int main() +{ + test03(); + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/pair/4.cc b/libstdc++-v3/testsuite/20_util/pair/4.cc new file mode 100644 index 00000000000..f6a1b5697d7 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/pair/4.cc @@ -0,0 +1,67 @@ +// 2001-06-18 Benjamin Kosnik + +// 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 +#include + +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 + 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 p_sg_1("enlightenment", obj1); + const std::pair 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& tmpl1 = gnu_t(false); + const std::pair, gnu_obj> p_st_1(tmpl1, obj1); + const std::pair, 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; +} diff --git a/zlib/contrib/asm386/gvmat32.asm b/zlib/contrib/asm386/gvmat32.asm new file mode 100644 index 00000000000..28d527f47f8 --- /dev/null +++ b/zlib/contrib/asm386/gvmat32.asm @@ -0,0 +1,559 @@ +; +; 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Â’t 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Â’t 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 diff --git a/zlib/contrib/asm386/gvmat32c.c b/zlib/contrib/asm386/gvmat32c.c new file mode 100644 index 00000000000..d853bb7ce8a --- /dev/null +++ b/zlib/contrib/asm386/gvmat32c.c @@ -0,0 +1,200 @@ +/* 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 + +#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 */ diff --git a/zlib/contrib/asm386/mkgvmt32.bat b/zlib/contrib/asm386/mkgvmt32.bat new file mode 100644 index 00000000000..6c5ffd7a024 --- /dev/null +++ b/zlib/contrib/asm386/mkgvmt32.bat @@ -0,0 +1 @@ +c:\masm611\bin\ml /coff /Zi /c /Flgvmat32.lst gvmat32.asm diff --git a/zlib/contrib/asm386/zlibvc.def b/zlib/contrib/asm386/zlibvc.def new file mode 100644 index 00000000000..7e9d60d55d9 --- /dev/null +++ b/zlib/contrib/asm386/zlibvc.def @@ -0,0 +1,74 @@ +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 diff --git a/zlib/contrib/asm386/zlibvc.dsp b/zlib/contrib/asm386/zlibvc.dsp new file mode 100644 index 00000000000..a70d4d4a6b0 --- /dev/null +++ b/zlib/contrib/asm386/zlibvc.dsp @@ -0,0 +1,651 @@ +# 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 diff --git a/zlib/contrib/asm386/zlibvc.dsw b/zlib/contrib/asm386/zlibvc.dsw new file mode 100644 index 00000000000..493cd870365 --- /dev/null +++ b/zlib/contrib/asm386/zlibvc.dsw @@ -0,0 +1,41 @@ +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> +{{{ +}}} + +############################################################################### + diff --git a/zlib/contrib/delphi2/d_zlib.bpr b/zlib/contrib/delphi2/d_zlib.bpr new file mode 100644 index 00000000000..78bb254088a --- /dev/null +++ b/zlib/contrib/delphi2/d_zlib.bpr @@ -0,0 +1,224 @@ +# --------------------------------------------------------------------------- +!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$@ $< +# --------------------------------------------------------------------------- diff --git a/zlib/contrib/delphi2/d_zlib.cpp b/zlib/contrib/delphi2/d_zlib.cpp new file mode 100644 index 00000000000..f5dea59b762 --- /dev/null +++ b/zlib/contrib/delphi2/d_zlib.cpp @@ -0,0 +1,17 @@ +#include +#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'. + diff --git a/zlib/contrib/delphi2/readme.txt b/zlib/contrib/delphi2/readme.txt new file mode 100644 index 00000000000..cbd31620d87 --- /dev/null +++ b/zlib/contrib/delphi2/readme.txt @@ -0,0 +1,17 @@ +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. + diff --git a/zlib/contrib/delphi2/zlib.bpg b/zlib/contrib/delphi2/zlib.bpg new file mode 100644 index 00000000000..b6c9acdf8c9 --- /dev/null +++ b/zlib/contrib/delphi2/zlib.bpg @@ -0,0 +1,26 @@ +#------------------------------------------------------------------------------ +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) + + diff --git a/zlib/contrib/delphi2/zlib.bpr b/zlib/contrib/delphi2/zlib.bpr new file mode 100644 index 00000000000..cf3945b2523 --- /dev/null +++ b/zlib/contrib/delphi2/zlib.bpr @@ -0,0 +1,225 @@ +# --------------------------------------------------------------------------- +!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$@ $< +# --------------------------------------------------------------------------- diff --git a/zlib/contrib/delphi2/zlib.cpp b/zlib/contrib/delphi2/zlib.cpp new file mode 100644 index 00000000000..bf6953ba198 --- /dev/null +++ b/zlib/contrib/delphi2/zlib.cpp @@ -0,0 +1,22 @@ +#include +#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'. + diff --git a/zlib/contrib/delphi2/zlib.pas b/zlib/contrib/delphi2/zlib.pas new file mode 100644 index 00000000000..10ae4cae256 --- /dev/null +++ b/zlib/contrib/delphi2/zlib.pas @@ -0,0 +1,534 @@ +{*******************************************************} +{ } +{ Delphi Supplemental Components } +{ ZLIB Data Compression Interface Unit } +{ } +{ Copyright (c) 1997 Borland International } +{ } +{*******************************************************} + +{ Modified for zlib 1.1.3 by Davide Moretti 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. diff --git a/zlib/contrib/delphi2/zlib32.bpr b/zlib/contrib/delphi2/zlib32.bpr new file mode 100644 index 00000000000..cabcec44947 --- /dev/null +++ b/zlib/contrib/delphi2/zlib32.bpr @@ -0,0 +1,174 @@ +# --------------------------------------------------------------------------- +!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$@ $< +# --------------------------------------------------------------------------- diff --git a/zlib/contrib/delphi2/zlib32.cpp b/zlib/contrib/delphi2/zlib32.cpp new file mode 100644 index 00000000000..7372f6b985f --- /dev/null +++ b/zlib/contrib/delphi2/zlib32.cpp @@ -0,0 +1,42 @@ + +#include +#pragma hdrstop +#include + + +//--------------------------------------------------------------------------- +// 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; +} diff --git a/zlib/nt/Makefile.emx b/zlib/nt/Makefile.emx new file mode 100644 index 00000000000..2d475b1847e --- /dev/null +++ b/zlib/nt/Makefile.emx @@ -0,0 +1,138 @@ +# 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 diff --git a/zlib/nt/Makefile.gcc b/zlib/nt/Makefile.gcc new file mode 100644 index 00000000000..cdd652f2360 --- /dev/null +++ b/zlib/nt/Makefile.gcc @@ -0,0 +1,87 @@ +# 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 diff --git a/zlib/nt/Makefile.nt b/zlib/nt/Makefile.nt new file mode 100644 index 00000000000..b250f2ac7d2 --- /dev/null +++ b/zlib/nt/Makefile.nt @@ -0,0 +1,88 @@ +# Makefile for zlib + +!include + +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 diff --git a/zlib/nt/zlib.dnt b/zlib/nt/zlib.dnt new file mode 100644 index 00000000000..7f9475cfb0e --- /dev/null +++ b/zlib/nt/zlib.dnt @@ -0,0 +1,47 @@ +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 diff --git a/zlib/os2/Makefile.os2 b/zlib/os2/Makefile.os2 new file mode 100644 index 00000000000..4f569471eca --- /dev/null +++ b/zlib/os2/Makefile.os2 @@ -0,0 +1,136 @@ +# 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 diff --git a/zlib/os2/zlib.def b/zlib/os2/zlib.def new file mode 100644 index 00000000000..4c753f1a3b9 --- /dev/null +++ b/zlib/os2/zlib.def @@ -0,0 +1,51 @@ +; +; 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