From: zack Date: Wed, 2 Feb 2005 22:09:16 +0000 (+0000) Subject: Revert bad import X-Git-Tag: upstream/4.9.2~63992 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=90c82b1db1ad1a6a552a9ef82b17328e4b7723fd;p=platform%2Fupstream%2Flinaro-gcc.git Revert bad import git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@94621 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/config/dsp16xx/dsp16xx-modes.def b/gcc/config/dsp16xx/dsp16xx-modes.def deleted file mode 100644 index 968e271..0000000 --- a/gcc/config/dsp16xx/dsp16xx-modes.def +++ /dev/null @@ -1,23 +0,0 @@ -/* 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 deleted file mode 100644 index 802c69b..0000000 --- a/gcc/config/dsp16xx/dsp16xx-protos.h +++ /dev/null @@ -1,86 +0,0 @@ -/* 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 deleted file mode 100644 index 14d9c5e..0000000 --- a/gcc/config/dsp16xx/dsp16xx.c +++ /dev/null @@ -1,2632 +0,0 @@ -/* 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 deleted file mode 100644 index 472ba1f..0000000 --- a/gcc/config/dsp16xx/dsp16xx.h +++ /dev/null @@ -1,1768 +0,0 @@ -/* 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 deleted file mode 100644 index fffd2a9..0000000 --- a/gcc/config/dsp16xx/dsp16xx.md +++ /dev/null @@ -1,3049 +0,0 @@ -;;- 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 deleted file mode 100644 index 56c6342..0000000 --- a/gcc/config/i370/README +++ /dev/null @@ -1,125 +0,0 @@ - -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 deleted file mode 100644 index fe39191..0000000 --- a/gcc/config/i370/i370-c.c +++ /dev/null @@ -1,64 +0,0 @@ -/* 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 deleted file mode 100644 index 666db0b..0000000 --- a/gcc/config/i370/i370-protos.h +++ /dev/null @@ -1,55 +0,0 @@ -/* 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 deleted file mode 100644 index 2cfe4fe..0000000 --- a/gcc/config/i370/i370.c +++ /dev/null @@ -1,1514 +0,0 @@ -/* 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 deleted file mode 100644 index 5d7037f..0000000 --- a/gcc/config/i370/i370.h +++ /dev/null @@ -1,1863 +0,0 @@ -/* 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 deleted file mode 100644 index f402fbd..0000000 --- a/gcc/config/i370/linux.h +++ /dev/null @@ -1,113 +0,0 @@ -/* 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 deleted file mode 100644 index dfb4cba..0000000 --- a/gcc/config/i370/mvs.h +++ /dev/null @@ -1,49 +0,0 @@ -/* 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 deleted file mode 100644 index 088c043..0000000 --- a/gcc/config/i370/oe.h +++ /dev/null @@ -1,53 +0,0 @@ -/* 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 deleted file mode 100644 index fccd163..0000000 --- a/gcc/config/i370/t-i370 +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 index 6c1199e..0000000 --- a/gcc/config/i960/i960-c.c +++ /dev/null @@ -1,117 +0,0 @@ -/* 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 deleted file mode 100644 index 465ea33..0000000 --- a/gcc/config/i960/i960-coff.h +++ /dev/null @@ -1,43 +0,0 @@ -/* 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 deleted file mode 100644 index e999390..0000000 --- a/gcc/config/i960/i960-modes.def +++ /dev/null @@ -1,33 +0,0 @@ -/* 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 deleted file mode 100644 index 269a40b..0000000 --- a/gcc/config/i960/i960-protos.h +++ /dev/null @@ -1,102 +0,0 @@ -/* 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 deleted file mode 100644 index 3d976b6..0000000 --- a/gcc/config/i960/i960.c +++ /dev/null @@ -1,2917 +0,0 @@ -/* 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 deleted file mode 100644 index 67c34e2..0000000 --- a/gcc/config/i960/i960.h +++ /dev/null @@ -1,1404 +0,0 @@ -/* 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 deleted file mode 100644 index ad1678a..0000000 --- a/gcc/config/i960/i960.md +++ /dev/null @@ -1,2818 +0,0 @@ -;;- 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 deleted file mode 100644 index 092b7920a..0000000 --- a/gcc/config/i960/rtems.h +++ /dev/null @@ -1,29 +0,0 @@ -/* 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 deleted file mode 100644 index 9cbaa9f..0000000 --- a/gcc/config/i960/t-960bare +++ /dev/null @@ -1,30 +0,0 @@ -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 deleted file mode 100644 index c93c5fe..0000000 --- a/gcc/f/ChangeLog +++ /dev/null @@ -1,7315 +0,0 @@ -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 deleted file mode 100644 index 3d6675e..0000000 --- a/gcc/f/ChangeLog.0 +++ /dev/null @@ -1,4806 +0,0 @@ -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 deleted file mode 100644 index 47585b0..0000000 --- a/gcc/f/Make-lang.in +++ /dev/null @@ -1,516 +0,0 @@ -# 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 deleted file mode 100644 index 71eebf6..0000000 --- a/gcc/f/RELEASE-PREP +++ /dev/null @@ -1,5 +0,0 @@ -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 deleted file mode 100644 index b03206d..0000000 --- a/gcc/f/ansify.c +++ /dev/null @@ -1,190 +0,0 @@ -/* 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 deleted file mode 100644 index bed9734..0000000 --- a/gcc/f/bad.c +++ /dev/null @@ -1,537 +0,0 @@ -/* 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 deleted file mode 100644 index 92d7e23..0000000 --- a/gcc/f/bad.def +++ /dev/null @@ -1,1103 +0,0 @@ -/* 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 deleted file mode 100644 index bd7581e..0000000 --- a/gcc/f/bad.h +++ /dev/null @@ -1,106 +0,0 @@ -/* 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 deleted file mode 100644 index 00f064b..0000000 --- a/gcc/f/bit.c +++ /dev/null @@ -1,200 +0,0 @@ -/* 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 deleted file mode 100644 index 6b559ef..0000000 --- a/gcc/f/bit.h +++ /dev/null @@ -1,84 +0,0 @@ -/* 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 deleted file mode 100644 index 737dcc7..0000000 --- a/gcc/f/bld-op.def +++ /dev/null @@ -1,69 +0,0 @@ -/* 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 deleted file mode 100644 index ec7c5cd..0000000 --- a/gcc/f/bld.c +++ /dev/null @@ -1,3135 +0,0 @@ -/* 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 deleted file mode 100644 index 900b5de..0000000 --- a/gcc/f/bld.h +++ /dev/null @@ -1,748 +0,0 @@ -/* 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 deleted file mode 100644 index fdc4f15..0000000 --- a/gcc/f/bugs.texi +++ /dev/null @@ -1,260 +0,0 @@ -@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 deleted file mode 100644 index 9636f4d..0000000 --- a/gcc/f/bugs0.texi +++ /dev/null @@ -1,9 +0,0 @@ -\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 deleted file mode 100644 index 185aef5..0000000 --- a/gcc/f/com-rt.def +++ /dev/null @@ -1,289 +0,0 @@ -/* 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 deleted file mode 100644 index a64ef86..0000000 --- a/gcc/f/com.c +++ /dev/null @@ -1,16525 +0,0 @@ -/* 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 deleted file mode 100644 index d23db66..0000000 --- a/gcc/f/com.h +++ /dev/null @@ -1,290 +0,0 @@ -/* 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 deleted file mode 100644 index 92ba5cc..0000000 --- a/gcc/f/config-lang.in +++ /dev/null @@ -1,36 +0,0 @@ -# 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 deleted file mode 100644 index 2040f0a..0000000 --- a/gcc/f/data.c +++ /dev/null @@ -1,1877 +0,0 @@ -/* 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 deleted file mode 100644 index a99369d..0000000 --- a/gcc/f/data.h +++ /dev/null @@ -1,74 +0,0 @@ -/* 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 deleted file mode 100644 index bd7ac6d..0000000 --- a/gcc/f/equiv.c +++ /dev/null @@ -1,1484 +0,0 @@ -/* 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 deleted file mode 100644 index 59abfc8..0000000 --- a/gcc/f/equiv.h +++ /dev/null @@ -1,100 +0,0 @@ -/* 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 deleted file mode 100644 index ef7661d..0000000 --- a/gcc/f/expr.c +++ /dev/null @@ -1,18571 +0,0 @@ -/* 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 deleted file mode 100644 index b82173b..0000000 --- a/gcc/f/expr.h +++ /dev/null @@ -1,194 +0,0 @@ -/* 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 deleted file mode 100644 index fd5d3bf..0000000 --- a/gcc/f/ffe.texi +++ /dev/null @@ -1,2063 +0,0 @@ -@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 deleted file mode 100644 index 167837b..0000000 --- a/gcc/f/fini.c +++ /dev/null @@ -1,772 +0,0 @@ -/* 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 deleted file mode 100644 index 3d5f83d..0000000 --- a/gcc/f/g77.texi +++ /dev/null @@ -1,11848 +0,0 @@ -\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 deleted file mode 100644 index 3dca7bc..0000000 --- a/gcc/f/g77spec.c +++ /dev/null @@ -1,541 +0,0 @@ -/* 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 deleted file mode 100644 index 8793f62..0000000 --- a/gcc/f/global.c +++ /dev/null @@ -1,1586 +0,0 @@ -/* 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 deleted file mode 100644 index dc499df..0000000 --- a/gcc/f/global.h +++ /dev/null @@ -1,193 +0,0 @@ -/* 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 deleted file mode 100644 index c7a28cb..0000000 --- a/gcc/f/implic.c +++ /dev/null @@ -1,383 +0,0 @@ -/* 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 deleted file mode 100644 index 44fbfac..0000000 --- a/gcc/f/implic.h +++ /dev/null @@ -1,74 +0,0 @@ -/* 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 deleted file mode 100644 index 088d108..0000000 --- a/gcc/f/info-b.def +++ /dev/null @@ -1,36 +0,0 @@ -/* 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 deleted file mode 100644 index 9e6052d..0000000 --- a/gcc/f/info-k.def +++ /dev/null @@ -1,41 +0,0 @@ -/* 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 deleted file mode 100644 index 57e3f8c..0000000 --- a/gcc/f/info-w.def +++ /dev/null @@ -1,41 +0,0 @@ -/* 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 deleted file mode 100644 index 3c0030f..0000000 --- a/gcc/f/info.c +++ /dev/null @@ -1,303 +0,0 @@ -/* 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 deleted file mode 100644 index 69defd2..0000000 --- a/gcc/f/info.h +++ /dev/null @@ -1,186 +0,0 @@ -/* 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 deleted file mode 100644 index b24c79a..0000000 --- a/gcc/f/intdoc.c +++ /dev/null @@ -1,1325 +0,0 @@ -/* 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 deleted file mode 100644 index 6f2423f..0000000 --- a/gcc/f/intdoc.in +++ /dev/null @@ -1,2705 +0,0 @@ -/* 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 deleted file mode 100644 index e657510..0000000 --- a/gcc/f/intdoc.texi +++ /dev/null @@ -1,10931 +0,0 @@ -@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 deleted file mode 100644 index a379684..0000000 --- a/gcc/f/intrin.c +++ /dev/null @@ -1,2119 +0,0 @@ -/* 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 deleted file mode 100644 index 5d712ba..0000000 --- a/gcc/f/intrin.def +++ /dev/null @@ -1,3358 +0,0 @@ -/* 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 deleted file mode 100644 index e741e69..0000000 --- a/gcc/f/intrin.h +++ /dev/null @@ -1,135 +0,0 @@ -/* 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 deleted file mode 100644 index fd1b804..0000000 --- a/gcc/f/invoke.texi +++ /dev/null @@ -1,2233 +0,0 @@ -@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 deleted file mode 100644 index 1d27874..0000000 --- a/gcc/f/lab.c +++ /dev/null @@ -1,157 +0,0 @@ -/* 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 deleted file mode 100644 index f3f8986..0000000 --- a/gcc/f/lab.h +++ /dev/null @@ -1,152 +0,0 @@ -/* 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 deleted file mode 100644 index 9ed51ef..0000000 --- a/gcc/f/lang-specs.h +++ /dev/null @@ -1,47 +0,0 @@ -/* 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 deleted file mode 100644 index d6a53b7..0000000 --- a/gcc/f/lang.opt +++ /dev/null @@ -1,402 +0,0 @@ -; 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 deleted file mode 100644 index c524244..0000000 --- a/gcc/testsuite/g77.f-torture/execute/io1.f +++ /dev/null @@ -1,10 +0,0 @@ -* 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 deleted file mode 100644 index 6a69a3a..0000000 --- a/gcc/testsuite/g77.f-torture/execute/io1.x +++ /dev/null @@ -1,13 +0,0 @@ -# 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 deleted file mode 100644 index 032fa41..0000000 --- a/gcc/testsuite/g77.f-torture/execute/labug1.f +++ /dev/null @@ -1,57 +0,0 @@ - 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 deleted file mode 100644 index 0af5b1b..0000000 --- a/gcc/testsuite/g77.f-torture/execute/large_vec.f +++ /dev/null @@ -1,3 +0,0 @@ - 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 deleted file mode 100644 index 74e4275..0000000 --- a/gcc/testsuite/g77.f-torture/execute/le.f +++ /dev/null @@ -1,29 +0,0 @@ - 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 deleted file mode 100644 index f1024330..0000000 --- a/gcc/testsuite/g77.f-torture/execute/select.f +++ /dev/null @@ -1,173 +0,0 @@ -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 deleted file mode 100644 index 89ae273..0000000 --- a/gcc/testsuite/g77.f-torture/execute/short.f +++ /dev/null @@ -1,57 +0,0 @@ - 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 deleted file mode 100644 index f502bc7..0000000 --- a/gcc/testsuite/g77.f-torture/execute/u77-test.f +++ /dev/null @@ -1,421 +0,0 @@ -*** 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 deleted file mode 100644 index e4b8900..0000000 --- a/gcc/testsuite/g77.f-torture/execute/u77-test.x +++ /dev/null @@ -1,12 +0,0 @@ -# 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 deleted file mode 100644 index 0cc9087..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f +++ /dev/null @@ -1,89 +0,0 @@ -* 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 deleted file mode 100644 index 25b7c5b..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f +++ /dev/null @@ -1,13 +0,0 @@ - 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 deleted file mode 100644 index 86d2a93..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f +++ /dev/null @@ -1,648 +0,0 @@ -* 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 deleted file mode 100644 index 026d05e..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f +++ /dev/null @@ -1,8 +0,0 @@ -* =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 deleted file mode 100644 index e68b3e0..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/9263.f +++ /dev/null @@ -1,7 +0,0 @@ - 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 deleted file mode 100644 index c1e2348..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/970626-2.f +++ /dev/null @@ -1,4 +0,0 @@ - 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 deleted file mode 100644 index 316969f6..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f +++ /dev/null @@ -1,10 +0,0 @@ -* 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 deleted file mode 100644 index bd5e740..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f +++ /dev/null @@ -1,8 +0,0 @@ -* 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 deleted file mode 100644 index fc3c6ca..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/check0.f +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 index fadd1fb..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp +++ /dev/null @@ -1,36 +0,0 @@ -# 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 deleted file mode 100644 index f7dad33..0000000 --- a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f +++ /dev/null @@ -1,10 +0,0 @@ - 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 deleted file mode 100644 index 495e3e9..0000000 --- a/libjava/doc/cni.sgml +++ /dev/null @@ -1,996 +0,0 @@ - -
- -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 deleted file mode 100644 index c98549b..0000000 --- a/libjava/gnu/javax/rmi/CORBA/DelegateFactory.java +++ /dev/null @@ -1,74 +0,0 @@ -/* 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 deleted file mode 100644 index 27b84f1..0000000 --- a/libjava/gnu/javax/rmi/CORBA/GetDelegateInstanceException.java +++ /dev/null @@ -1,58 +0,0 @@ -/* 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 deleted file mode 100644 index 973c4c4..0000000 --- a/libjava/gnu/javax/rmi/CORBA/PortableRemoteObjectDelegateImpl.java +++ /dev/null @@ -1,133 +0,0 @@ -/* 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 deleted file mode 100644 index 894e502..0000000 --- a/libjava/gnu/javax/rmi/CORBA/StubDelegateImpl.java +++ /dev/null @@ -1,113 +0,0 @@ -/* 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 deleted file mode 100644 index 70b2e60..0000000 --- a/libjava/gnu/javax/rmi/CORBA/UtilDelegateImpl.java +++ /dev/null @@ -1,152 +0,0 @@ -/* 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 deleted file mode 100644 index 6935aa6..0000000 --- a/libjava/gnu/javax/rmi/CORBA/ValueHandlerImpl.java +++ /dev/null @@ -1,82 +0,0 @@ -/* 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 deleted file mode 100644 index b5022ca..0000000 --- a/libjava/gnu/javax/rmi/PortableServer.java +++ /dev/null @@ -1,142 +0,0 @@ -/* 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 deleted file mode 100644 index 36081a4..0000000 --- a/libjava/javax/rmi/BAD_OPERATION.java +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 index 052046d..0000000 --- a/libjava/javax/rmi/CORBA/ClassDesc.java +++ /dev/null @@ -1,55 +0,0 @@ -/* 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 deleted file mode 100644 index d76d673..0000000 --- a/libjava/javax/rmi/CORBA/ObjectImpl.java +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index a073cf4..0000000 --- a/libjava/javax/rmi/CORBA/PortableRemoteObjectDelegate.java +++ /dev/null @@ -1,63 +0,0 @@ -/* 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 deleted file mode 100644 index c79b85c..0000000 --- a/libjava/javax/rmi/CORBA/Stub.java +++ /dev/null @@ -1,120 +0,0 @@ -/* 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 deleted file mode 100644 index 6c7f69f..0000000 --- a/libjava/javax/rmi/CORBA/StubDelegate.java +++ /dev/null @@ -1,65 +0,0 @@ -/* 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 deleted file mode 100644 index f8afdc3..0000000 --- a/libjava/javax/rmi/CORBA/SystemException.java +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 index ca14e3d..0000000 --- a/libjava/javax/rmi/CORBA/Tie.java +++ /dev/null @@ -1,62 +0,0 @@ -/* 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 deleted file mode 100644 index 45a189d..0000000 --- a/libjava/javax/rmi/CORBA/Util.java +++ /dev/null @@ -1,187 +0,0 @@ -/* 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 deleted file mode 100644 index 4d611bc..0000000 --- a/libjava/javax/rmi/CORBA/UtilDelegate.java +++ /dev/null @@ -1,84 +0,0 @@ -/* 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 deleted file mode 100644 index 3a008f1..0000000 --- a/libjava/javax/rmi/CORBA/ValueHandler.java +++ /dev/null @@ -1,63 +0,0 @@ -/* 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 deleted file mode 100644 index be7a894..0000000 --- a/libjava/javax/rmi/ORB.java +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 index ee40d9c..0000000 --- a/libjava/javax/rmi/PortableRemoteObject.java +++ /dev/null @@ -1,114 +0,0 @@ -/* 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 deleted file mode 100644 index d34c8da..0000000 --- a/libstdc++-v3/testsuite/20_util/allocator/1.cc +++ /dev/null @@ -1,71 +0,0 @@ -// 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 deleted file mode 100644 index 2ac77ea..0000000 --- a/libstdc++-v3/testsuite/20_util/allocator/10378.cc +++ /dev/null @@ -1,51 +0,0 @@ -// 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 deleted file mode 100644 index cb8a2f5..0000000 --- a/libstdc++-v3/testsuite/20_util/allocator/14176.cc +++ /dev/null @@ -1,42 +0,0 @@ -// 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 deleted file mode 100644 index 95b6cbe..0000000 --- a/libstdc++-v3/testsuite/20_util/allocator/8230.cc +++ /dev/null @@ -1,59 +0,0 @@ -// 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 deleted file mode 100644 index 8e150b0..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/1.cc +++ /dev/null @@ -1,95 +0,0 @@ -// 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 deleted file mode 100644 index 6ce31d1..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/2.cc +++ /dev/null @@ -1,85 +0,0 @@ -// 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 deleted file mode 100644 index 8090d27..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/3.cc +++ /dev/null @@ -1,87 +0,0 @@ -// 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 deleted file mode 100644 index 191ba6f..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/3946.cc +++ /dev/null @@ -1,45 +0,0 @@ -// 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 deleted file mode 100644 index 1814800..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/4.cc +++ /dev/null @@ -1,83 +0,0 @@ -// 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 deleted file mode 100644 index 7796981..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/5.cc +++ /dev/null @@ -1,87 +0,0 @@ -// 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 deleted file mode 100644 index e4e13d9..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/6.cc +++ /dev/null @@ -1,91 +0,0 @@ -// 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 deleted file mode 100644 index a77ba51..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/7.cc +++ /dev/null @@ -1,91 +0,0 @@ -// 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 deleted file mode 100644 index 5529167..0000000 --- a/libstdc++-v3/testsuite/20_util/auto_ptr/assign_neg.cc +++ /dev/null @@ -1,50 +0,0 @@ -// { 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 deleted file mode 100644 index 7ccee6d..0000000 --- a/libstdc++-v3/testsuite/20_util/pair/1.cc +++ /dev/null @@ -1,79 +0,0 @@ -// 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 deleted file mode 100644 index 82d928c..0000000 --- a/libstdc++-v3/testsuite/20_util/pair/2.cc +++ /dev/null @@ -1,60 +0,0 @@ -// 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 deleted file mode 100644 index bac0e7e..0000000 --- a/libstdc++-v3/testsuite/20_util/pair/3.cc +++ /dev/null @@ -1,79 +0,0 @@ -// 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 deleted file mode 100644 index f6a1b56..0000000 --- a/libstdc++-v3/testsuite/20_util/pair/4.cc +++ /dev/null @@ -1,67 +0,0 @@ -// 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 deleted file mode 100644 index 28d527f..0000000 --- a/zlib/contrib/asm386/gvmat32.asm +++ /dev/null @@ -1,559 +0,0 @@ -; -; 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 deleted file mode 100644 index d853bb7..0000000 --- a/zlib/contrib/asm386/gvmat32c.c +++ /dev/null @@ -1,200 +0,0 @@ -/* 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 deleted file mode 100644 index 6c5ffd7..0000000 --- a/zlib/contrib/asm386/mkgvmt32.bat +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index 7e9d60d..0000000 --- a/zlib/contrib/asm386/zlibvc.def +++ /dev/null @@ -1,74 +0,0 @@ -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 deleted file mode 100644 index a70d4d4..0000000 --- a/zlib/contrib/asm386/zlibvc.dsp +++ /dev/null @@ -1,651 +0,0 @@ -# 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 deleted file mode 100644 index 493cd87..0000000 --- a/zlib/contrib/asm386/zlibvc.dsw +++ /dev/null @@ -1,41 +0,0 @@ -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 deleted file mode 100644 index 78bb254..0000000 --- a/zlib/contrib/delphi2/d_zlib.bpr +++ /dev/null @@ -1,224 +0,0 @@ -# --------------------------------------------------------------------------- -!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 deleted file mode 100644 index f5dea59..0000000 --- a/zlib/contrib/delphi2/d_zlib.cpp +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 index cbd3162..0000000 --- a/zlib/contrib/delphi2/readme.txt +++ /dev/null @@ -1,17 +0,0 @@ -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 deleted file mode 100644 index b6c9acd..0000000 --- a/zlib/contrib/delphi2/zlib.bpg +++ /dev/null @@ -1,26 +0,0 @@ -#------------------------------------------------------------------------------ -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 deleted file mode 100644 index cf3945b..0000000 --- a/zlib/contrib/delphi2/zlib.bpr +++ /dev/null @@ -1,225 +0,0 @@ -# --------------------------------------------------------------------------- -!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 deleted file mode 100644 index bf6953b..0000000 --- a/zlib/contrib/delphi2/zlib.cpp +++ /dev/null @@ -1,22 +0,0 @@ -#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 deleted file mode 100644 index 10ae4ca..0000000 --- a/zlib/contrib/delphi2/zlib.pas +++ /dev/null @@ -1,534 +0,0 @@ -{*******************************************************} -{ } -{ 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 deleted file mode 100644 index cabcec4..0000000 --- a/zlib/contrib/delphi2/zlib32.bpr +++ /dev/null @@ -1,174 +0,0 @@ -# --------------------------------------------------------------------------- -!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 deleted file mode 100644 index 7372f6b..0000000 --- a/zlib/contrib/delphi2/zlib32.cpp +++ /dev/null @@ -1,42 +0,0 @@ - -#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 deleted file mode 100644 index 2d475b1..0000000 --- a/zlib/nt/Makefile.emx +++ /dev/null @@ -1,138 +0,0 @@ -# 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 deleted file mode 100644 index cdd652f..0000000 --- a/zlib/nt/Makefile.gcc +++ /dev/null @@ -1,87 +0,0 @@ -# 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 deleted file mode 100644 index b250f2a..0000000 --- a/zlib/nt/Makefile.nt +++ /dev/null @@ -1,88 +0,0 @@ -# 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 deleted file mode 100644 index 7f9475c..0000000 --- a/zlib/nt/zlib.dnt +++ /dev/null @@ -1,47 +0,0 @@ -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 deleted file mode 100644 index 4f56947..0000000 --- a/zlib/os2/Makefile.os2 +++ /dev/null @@ -1,136 +0,0 @@ -# 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 deleted file mode 100644 index 4c753f1..0000000 --- a/zlib/os2/zlib.def +++ /dev/null @@ -1,51 +0,0 @@ -; -; 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