Initial Fortran language support, adapted from work by Farooq Butt

	(fmbutt@engage.sps.mot.com).
	* Makefile.in: Add Fortran-related files and dependencies.
	* defs.h (language_fortran): New language enum.
	* language.h (_LANG_fortran): Define.
	(MAX_FORTRAN_DIMS): Define.
	* expression.h: Reformat to standard.
	(MULTI_F77_SUBSCRIPT, OP_F77_UNDETERMINED_ARGLIST,
	OP_F77_LITERAL_COMPLEX, OP_F77_SUBSTR): New expression opcodes.
	* gdbtypes.h (TYPE_CODE_COMPLEX, TYPE_CODE_LITERAL_COMPLEX,
	TYPE_CODE_LITERAL_STRING): New type codes.
	(type): New fields upper_bound_type and lower_bound_type.
	(TYPE_ARRAY_UPPER_BOUND_TYPE, TYPE_ARRAY_LOWER_BOUND_TYPE,
	TYPE_ARRAY_UPPER_BOUND_VALUE, TYPE_ARRAY_LOWER_BOUND_VALUE): New
	macros.
	(builtin_type_f_character, etc): Declare.
	* value.h (VALUE_LITERAL_DATA, VALUE_SUBSTRING_START): Define.
	* f-exp.y: New file, Fortran expression grammar.
	* f-lang.c: New file, Fortran language support functions.
	* f-lang.h: New file, Fortran language support declarations.
	* f-typeprint.c: New file, Fortran type printing.
	* f-valprint.c: New file, Fortran value printing.
	* eval.c (evaluate_subexp): Add code for new expression opcodes,
	fix wording of error message.
	* gdbtypes.c (f77_create_literal_complex_type,
	f77_create_literal_string_type): New functions.
	* language.c (set_language_command): Add Fortran info.
	(calc_f77_array_dims): New function.
	* parse.c (length_of_subexp, prefixify_subexp): Add cases for new
	expression opcodes.
	* symfile.c (deduce_language_from_filename): Recognize .f and .F
	as Fortran source files.
	* valops.c (f77_value_literal_string, f77_value_substring,
	f77_value_literal_complex): New functions.

13 files changed, 4209 insertions, 118 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index fcdd266..a7cc010 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,40 @@
+Fri Aug 19 14:55:45 1994  Stan Shebs  (shebs@andros.cygnus.com)
+
+	Initial Fortran language support, adapted from work by Farooq Butt
+	(fmbutt@engage.sps.mot.com).
+	* Makefile.in: Add Fortran-related files and dependencies.
+	* defs.h (language_fortran): New language enum.
+	* language.h (_LANG_fortran): Define.
+	(MAX_FORTRAN_DIMS): Define.
+	* expression.h: Reformat to standard.
+	(MULTI_F77_SUBSCRIPT, OP_F77_UNDETERMINED_ARGLIST,
+	OP_F77_LITERAL_COMPLEX, OP_F77_SUBSTR): New expression opcodes.
+	* gdbtypes.h (TYPE_CODE_COMPLEX, TYPE_CODE_LITERAL_COMPLEX,
+	TYPE_CODE_LITERAL_STRING): New type codes.
+	(type): New fields upper_bound_type and lower_bound_type.
+	(TYPE_ARRAY_UPPER_BOUND_TYPE, TYPE_ARRAY_LOWER_BOUND_TYPE,
+	TYPE_ARRAY_UPPER_BOUND_VALUE, TYPE_ARRAY_LOWER_BOUND_VALUE): New
+	macros.
+	(builtin_type_f_character, etc): Declare.
+	* value.h (VALUE_LITERAL_DATA, VALUE_SUBSTRING_START): Define.
+	* f-exp.y: New file, Fortran expression grammar.
+	* f-lang.c: New file, Fortran language support functions.
+	* f-lang.h: New file, Fortran language support declarations.
+	* f-typeprint.c: New file, Fortran type printing.
+	* f-valprint.c: New file, Fortran value printing.
+	* eval.c (evaluate_subexp): Add code for new expression opcodes,
+	fix wording of error message.
+	* gdbtypes.c (f77_create_literal_complex_type,
+	f77_create_literal_string_type): New functions.
+	* language.c (set_language_command): Add Fortran info.
+	(calc_f77_array_dims): New function.
+	* parse.c (length_of_subexp, prefixify_subexp): Add cases for new
+	expression opcodes.
+	* symfile.c (deduce_language_from_filename): Recognize .f and .F
+	as Fortran source files.
+	* valops.c (f77_value_literal_string, f77_value_substring,
+	f77_value_literal_complex): New functions.
+
 Fri Aug 19 13:35:01 1994  Peter Schauer  (pes@regent.e-technik.tu-muenchen.de)
 
 	* c-typeprint.c (c_print_type):  Assume demangled arguments
diff --git a/gdb/f-exp.y b/gdb/f-exp.y
new file mode 100644
index 0000000..27eda23
--- /dev/null
+++ b/gdb/f-exp.y
@@ -0,0 +1,1246 @@
+/* YACC parser for Fortran expressions, for GDB.
+   Copyright 1986, 1989, 1990, 1991, 1993, 1994
+             Free Software Foundation, Inc.
+   Contributed by Motorola.  Adapted from the C parser by Farooq Butt
+   (fmbutt@engage.sps.mot.com).
+
+This file is part of GDB.
+
+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., 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+/* This was blantantly ripped off the C expression parser, please 
+   be aware of that as you look at its basic structure -FMB */ 
+
+/* Parse a F77 expression from text in a string,
+   and return the result as a  struct expression  pointer.
+   That structure contains arithmetic operations in reverse polish,
+   with constants represented by operations that are followed by special data.
+   See expression.h for the details of the format.
+   What is important here is that it can be built up sequentially
+   during the process of parsing; the lower levels of the tree always
+   come first in the result.
+
+   Note that malloc's and realloc's in this file are transformed to
+   xmalloc and xrealloc respectively by the same sed command in the
+   makefile that remaps any other malloc/realloc inserted by the parser
+   generator.  Doing this with #defines and trying to control the interaction
+   with include files (<malloc.h> and <stdlib.h> for example) just became
+   too messy, particularly when such includes can be inserted at random
+   times by the parser generator.  */
+   
+%{
+
+#include "defs.h"
+#include "expression.h"
+#include "parser-defs.h"
+#include "value.h"
+#include "language.h"
+#include "f-lang.h"
+#include "bfd.h" /* Required by objfiles.h.  */
+#include "symfile.h" /* Required by objfiles.h.  */
+#include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
+
+/* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
+   as well as gratuitiously global symbol names, so we can have multiple
+   yacc generated parsers in gdb.  Note that these are only the variables
+   produced by yacc.  If other parser generators (bison, byacc, etc) produce
+   additional global names that conflict at link time, then those parser
+   generators need to be fixed instead of adding those names to this list. */
+
+#define	yymaxdepth f_maxdepth
+#define	yyparse	f_parse
+#define	yylex	f_lex
+#define	yyerror	f_error
+#define	yylval	f_lval
+#define	yychar	f_char
+#define	yydebug	f_debug
+#define	yypact	f_pact	
+#define	yyr1	f_r1			
+#define	yyr2	f_r2			
+#define	yydef	f_def		
+#define	yychk	f_chk		
+#define	yypgo	f_pgo		
+#define	yyact	f_act		
+#define	yyexca	f_exca
+#define yyerrflag f_errflag
+#define yynerrs	f_nerrs
+#define	yyps	f_ps
+#define	yypv	f_pv
+#define	yys	f_s
+#define	yy_yys	f_yys
+#define	yystate	f_state
+#define	yytmp	f_tmp
+#define	yyv	f_v
+#define	yy_yyv	f_yyv
+#define	yyval	f_val
+#define	yylloc	f_lloc
+#define yyreds	f_reds		/* With YYDEBUG defined */
+#define yytoks	f_toks		/* With YYDEBUG defined */
+
+#ifndef YYDEBUG
+#define	YYDEBUG	1		/* Default to no yydebug support */
+#endif
+
+int yyparse PARAMS ((void));
+
+static int yylex PARAMS ((void));
+
+void yyerror PARAMS ((char *));
+
+%}
+
+/* Although the yacc "value" of an expression is not used,
+   since the result is stored in the structure being created,
+   other node types do have values.  */
+
+%union
+  {
+    LONGEST lval;
+    struct {
+      LONGEST val;
+      struct type *type;
+    } typed_val;
+    double dval;
+    struct symbol *sym;
+    struct type *tval;
+    struct stoken sval;
+    struct ttype tsym;
+    struct symtoken ssym;
+    int voidval;
+    struct block *bval;
+    enum exp_opcode opcode;
+    struct internalvar *ivar;
+
+    struct type **tvec;
+    int *ivec;
+  }
+
+%{
+/* YYSTYPE gets defined by %union */
+static int parse_number PARAMS ((char *, int, int, YYSTYPE *));
+%}
+
+%type <voidval> exp  type_exp start variable 
+%type <tval> type typebase
+%type <tvec> nonempty_typelist
+/* %type <bval> block */
+
+/* Fancy type parsing.  */
+%type <voidval> func_mod direct_abs_decl abs_decl
+%type <tval> ptype
+
+%token <typed_val> INT
+%token <dval> FLOAT
+
+/* Both NAME and TYPENAME tokens represent symbols in the input,
+   and both convey their data as strings.
+   But a TYPENAME is a string that happens to be defined as a typedef
+   or builtin type name (such as int or char)
+   and a NAME is any other symbol.
+   Contexts where this distinction is not important can use the
+   nonterminal "name", which matches either NAME or TYPENAME.  */
+
+%token <sval> STRING_LITERAL
+%token <lval> BOOLEAN_LITERAL
+%token <ssym> NAME 
+%token <tsym> TYPENAME
+%type <sval> name
+%type <ssym> name_not_typename
+%type <tsym> typename
+
+/* A NAME_OR_INT is a symbol which is not known in the symbol table,
+   but which would parse as a valid number in the current input radix.
+   E.g. "c" when input_radix==16.  Depending on the parse, it will be
+   turned into a name or into a number.  */
+
+%token <ssym> NAME_OR_INT 
+
+%token  SIZEOF 
+%token ERROR
+
+/* Special type cases, put in to allow the parser to distinguish different
+   legal basetypes.  */
+%token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD 
+%token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD 
+%token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD 
+%token BOOL_AND BOOL_OR BOOL_NOT   
+%token <lval> LAST REGNAME CHARACTER 
+
+%token <ivar> VARIABLE
+
+%token <opcode> ASSIGN_MODIFY
+
+%left ','
+%left ABOVE_COMMA
+%right '=' ASSIGN_MODIFY
+%right '?'
+%left BOOL_OR
+%right BOOL_NOT
+%left BOOL_AND
+%left '|'
+%left '^'
+%left '&'
+%left EQUAL NOTEQUAL
+%left LESSTHAN GREATERTHAN LEQ GEQ
+%left LSH RSH
+%left '@'
+%left '+' '-'
+%left '*' '/' '%'
+%right UNARY 
+%right '('
+
+
+%%
+
+start   :	exp
+	|	type_exp
+	;
+
+type_exp:	type
+			{ write_exp_elt_opcode(OP_TYPE);
+			  write_exp_elt_type($1);
+			  write_exp_elt_opcode(OP_TYPE); }
+	;
+
+
+exp     :       '(' exp ')'
+        		{ }
+        ;
+
+/* Expressions, not including the comma operator.  */
+exp	:	'*' exp    %prec UNARY
+			{ write_exp_elt_opcode (UNOP_IND); }
+
+exp	:	'&' exp    %prec UNARY
+			{ write_exp_elt_opcode (UNOP_ADDR); }
+
+exp	:	'-' exp    %prec UNARY
+			{ write_exp_elt_opcode (UNOP_NEG); }
+	;
+
+exp	:	BOOL_NOT exp    %prec UNARY
+			{ write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
+	;
+
+exp	:	'~' exp    %prec UNARY
+			{ write_exp_elt_opcode (UNOP_COMPLEMENT); }
+	;
+
+exp	:	SIZEOF exp       %prec UNARY
+			{ write_exp_elt_opcode (UNOP_SIZEOF); }
+	;
+
+/* No more explicit array operators, we treat everything in F77 as 
+   a function call.  The disambiguation as to whether we are 
+   doing a subscript operation or a function call is done 
+   later in eval.c.  */
+
+exp	:	exp '(' 
+			{ start_arglist (); }
+		arglist ')'	
+			{ write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST);
+			  write_exp_elt_longcst ((LONGEST) end_arglist ());
+			  write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); }
+	;
+
+arglist	:
+	;
+
+arglist	:	exp
+			{ arglist_len = 1; }
+	;
+
+arglist :      substring
+                        { arglist_len = 2;}
+   
+arglist	:	arglist ',' exp   %prec ABOVE_COMMA
+			{ arglist_len++; }
+	;
+
+substring:	exp ':' exp   %prec ABOVE_COMMA
+			{ } 
+	;
+
+
+complexnum:     exp ',' exp 
+                	{ }                          
+        ;
+
+exp	:	'(' complexnum ')'
+                	{ write_exp_elt_opcode(OP_F77_LITERAL_COMPLEX); }
+	;
+
+exp	:	'(' type ')' exp  %prec UNARY
+			{ write_exp_elt_opcode (UNOP_CAST);
+			  write_exp_elt_type ($2);
+			  write_exp_elt_opcode (UNOP_CAST); }
+	;
+
+/* Binary operators in order of decreasing precedence.  */
+
+exp	:	exp '@' exp
+			{ write_exp_elt_opcode (BINOP_REPEAT); }
+	;
+
+exp	:	exp '*' exp
+			{ write_exp_elt_opcode (BINOP_MUL); }
+	;
+
+exp	:	exp '/' exp
+			{ write_exp_elt_opcode (BINOP_DIV); }
+	;
+
+exp	:	exp '%' exp
+			{ write_exp_elt_opcode (BINOP_REM); }
+	;
+
+exp	:	exp '+' exp
+			{ write_exp_elt_opcode (BINOP_ADD); }
+	;
+
+exp	:	exp '-' exp
+			{ write_exp_elt_opcode (BINOP_SUB); }
+	;
+
+exp	:	exp LSH exp
+			{ write_exp_elt_opcode (BINOP_LSH); }
+	;
+
+exp	:	exp RSH exp
+			{ write_exp_elt_opcode (BINOP_RSH); }
+	;
+
+exp	:	exp EQUAL exp
+			{ write_exp_elt_opcode (BINOP_EQUAL); }
+	;
+
+exp	:	exp NOTEQUAL exp
+			{ write_exp_elt_opcode (BINOP_NOTEQUAL); }
+	;
+
+exp	:	exp LEQ exp
+			{ write_exp_elt_opcode (BINOP_LEQ); }
+	;
+
+exp	:	exp GEQ exp
+			{ write_exp_elt_opcode (BINOP_GEQ); }
+	;
+
+exp	:	exp LESSTHAN exp
+			{ write_exp_elt_opcode (BINOP_LESS); }
+	;
+
+exp	:	exp GREATERTHAN exp
+			{ write_exp_elt_opcode (BINOP_GTR); }
+	;
+
+exp	:	exp '&' exp
+			{ write_exp_elt_opcode (BINOP_BITWISE_AND); }
+	;
+
+exp	:	exp '^' exp
+			{ write_exp_elt_opcode (BINOP_BITWISE_XOR); }
+	;
+
+exp	:	exp '|' exp
+			{ write_exp_elt_opcode (BINOP_BITWISE_IOR); }
+	;
+
+exp     :       exp BOOL_AND exp
+			{ write_exp_elt_opcode (BINOP_LOGICAL_AND); }
+	;
+
+
+exp	:	exp BOOL_OR exp
+			{ write_exp_elt_opcode (BINOP_LOGICAL_OR); }
+	;
+
+exp	:	exp '=' exp
+			{ write_exp_elt_opcode (BINOP_ASSIGN); }
+	;
+
+exp	:	exp ASSIGN_MODIFY exp
+			{ write_exp_elt_opcode (BINOP_ASSIGN_MODIFY);
+			  write_exp_elt_opcode ($2);
+			  write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); }
+	;
+
+exp	:	INT
+			{ write_exp_elt_opcode (OP_LONG);
+			  write_exp_elt_type ($1.type);
+			  write_exp_elt_longcst ((LONGEST)($1.val));
+			  write_exp_elt_opcode (OP_LONG); }
+	;
+
+exp	:	NAME_OR_INT
+			{ YYSTYPE val;
+			  parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val);
+			  write_exp_elt_opcode (OP_LONG);
+			  write_exp_elt_type (val.typed_val.type);
+			  write_exp_elt_longcst ((LONGEST)val.typed_val.val);
+			  write_exp_elt_opcode (OP_LONG);
+			}
+	;
+
+exp	:	FLOAT
+			{ write_exp_elt_opcode (OP_DOUBLE);
+			  write_exp_elt_type (builtin_type_f_real_s8);
+			  write_exp_elt_dblcst ($1);
+			  write_exp_elt_opcode (OP_DOUBLE); }
+	;
+
+exp	:	variable
+	;
+
+exp	:	LAST
+			{ write_exp_elt_opcode (OP_LAST);
+			  write_exp_elt_longcst ((LONGEST) $1);
+			  write_exp_elt_opcode (OP_LAST); }
+	;
+
+exp	:	REGNAME
+			{ write_exp_elt_opcode (OP_REGISTER);
+			  write_exp_elt_longcst ((LONGEST) $1);
+			  write_exp_elt_opcode (OP_REGISTER); }
+	;
+
+exp	:	VARIABLE
+			{ write_exp_elt_opcode (OP_INTERNALVAR);
+			  write_exp_elt_intern ($1);
+			  write_exp_elt_opcode (OP_INTERNALVAR); }
+	;
+
+exp	:	SIZEOF '(' type ')'	%prec UNARY
+			{ write_exp_elt_opcode (OP_LONG);
+			  write_exp_elt_type (builtin_type_f_integer);
+			  write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
+			  write_exp_elt_opcode (OP_LONG); }
+	;
+
+exp     :       BOOLEAN_LITERAL
+			{ write_exp_elt_opcode (OP_BOOL);
+			  write_exp_elt_longcst ((LONGEST) $1);
+			  write_exp_elt_opcode (OP_BOOL);
+			}
+        ;
+
+exp	:	STRING_LITERAL
+			{  /* In F77, we encounter string literals 
+			      basically in only one place:
+			      when we are setting up manual parameter 
+			      lists to functions we call by hand or 
+			      when setting string vars to manual values. 
+			      These are character*N type variables.
+			      They are treated specially  behind the 
+			      scenes. Remember that the literal strings's 
+			      OPs are being emitted in reverse order, thus 
+			      we first have the elements and then 
+			      the array descriptor itself.  */ 
+			  char *sp = $1.ptr; int count = $1.length;
+
+			  while (count-- > 0)
+			    {
+			      write_exp_elt_opcode (OP_LONG);
+			      write_exp_elt_type (builtin_type_f_character);
+			      write_exp_elt_longcst ((LONGEST)(*sp++));
+			      write_exp_elt_opcode (OP_LONG);
+			    }
+			  write_exp_elt_opcode (OP_ARRAY);
+			  write_exp_elt_longcst ((LONGEST) 1);
+			  write_exp_elt_longcst ((LONGEST) ($1.length)); 
+			  write_exp_elt_opcode (OP_ARRAY); 
+			}
+
+	;
+
+variable:	name_not_typename
+			{ struct symbol *sym = $1.sym;
+
+			  if (sym)
+			    {
+			      if (symbol_read_needs_frame (sym))
+				{
+				  if (innermost_block == 0 ||
+				      contained_in (block_found, 
+						    innermost_block))
+				    innermost_block = block_found;
+				}
+			      write_exp_elt_opcode (OP_VAR_VALUE);
+			      write_exp_elt_sym (sym);
+			      write_exp_elt_opcode (OP_VAR_VALUE);
+			      break;
+			    }
+			  else
+			    {
+			      struct minimal_symbol *msymbol;
+			      register char *arg = copy_name ($1.stoken);
+
+			      msymbol = lookup_minimal_symbol (arg, NULL);
+			      if (msymbol != NULL)
+				{
+				  write_exp_msymbol (msymbol,
+						     lookup_function_type (builtin_type_int),
+						     builtin_type_int);
+				}
+			      else if (!have_full_symbols () && !have_partial_symbols ())
+				error ("No symbol table is loaded.  Use the \"file\" command.");
+			      else
+				error ("No symbol \"%s\" in current context.",
+				       copy_name ($1.stoken));
+			    }
+			}
+	;
+
+
+type    :       ptype
+        ;
+
+ptype	:	typebase
+	|	typebase abs_decl
+		{
+		  /* This is where the interesting stuff happens.  */
+		  int done = 0;
+		  int array_size;
+		  struct type *follow_type = $1;
+		  struct type *range_type;
+		  
+		  while (!done)
+		    switch (pop_type ())
+		      {
+		      case tp_end:
+			done = 1;
+			break;
+		      case tp_pointer:
+			follow_type = lookup_pointer_type (follow_type);
+			break;
+		      case tp_reference:
+			follow_type = lookup_reference_type (follow_type);
+			break;
+		      case tp_array:
+			array_size = pop_type_int ();
+			if (array_size != -1)
+			  {
+			    range_type =
+			      create_range_type ((struct type *) NULL,
+						 builtin_type_f_integer, 0,
+						 array_size - 1);
+			    follow_type =
+			      create_array_type ((struct type *) NULL,
+						 follow_type, range_type);
+			  }
+			else
+			  follow_type = lookup_pointer_type (follow_type);
+			break;
+		      case tp_function:
+			follow_type = lookup_function_type (follow_type);
+			break;
+		      }
+		  $$ = follow_type;
+		}
+	;
+
+abs_decl:	'*'
+			{ push_type (tp_pointer); $$ = 0; }
+	|	'*' abs_decl
+			{ push_type (tp_pointer); $$ = $2; }
+	|	'&'
+			{ push_type (tp_reference); $$ = 0; }
+	|	'&' abs_decl
+			{ push_type (tp_reference); $$ = $2; }
+	|	direct_abs_decl
+	;
+
+direct_abs_decl: '(' abs_decl ')'
+			{ $$ = $2; }
+	| 	direct_abs_decl func_mod
+			{ push_type (tp_function); }
+	|	func_mod
+			{ push_type (tp_function); }
+	;
+
+func_mod:	'(' ')'
+			{ $$ = 0; }
+	|	'(' nonempty_typelist ')'
+			{ free ((PTR)$2); $$ = 0; }
+	;
+
+typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
+	:	TYPENAME
+			{ $$ = $1.type; }
+	|	INT_KEYWORD
+			{ $$ = builtin_type_f_integer; }
+	|	INT_S2_KEYWORD 
+			{ $$ = builtin_type_f_integer_s2; }
+	|	CHARACTER 
+			{ $$ = builtin_type_f_character; }
+	|	LOGICAL_KEYWORD 
+			{ $$ = builtin_type_f_logical;} 
+	|	LOGICAL_S2_KEYWORD
+			{ $$ = builtin_type_f_logical_s2;}
+	|	LOGICAL_S1_KEYWORD 
+			{ $$ = builtin_type_f_logical_s1;}
+	|	REAL_KEYWORD 
+			{ $$ = builtin_type_f_real;}
+	|       REAL_S8_KEYWORD
+			{ $$ = builtin_type_f_real_s8;}
+	|	REAL_S16_KEYWORD
+			{ $$ = builtin_type_f_real_s16;}
+	|	COMPLEX_S8_KEYWORD
+			{ $$ = builtin_type_f_complex_s8;}
+	|	COMPLEX_S16_KEYWORD 
+			{ $$ = builtin_type_f_complex_s16;}
+	|	COMPLEX_S32_KEYWORD 
+			{ $$ = builtin_type_f_complex_s32;}
+	;
+
+typename:	TYPENAME
+	;
+
+nonempty_typelist
+	:	type
+		{ $$ = (struct type **) malloc (sizeof (struct type *) * 2);
+		  $<ivec>$[0] = 1;	/* Number of types in vector */
+		  $$[1] = $1;
+		}
+	|	nonempty_typelist ',' type
+		{ int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
+		  $$ = (struct type **) realloc ((char *) $1, len);
+		  $$[$<ivec>$[0]] = $3;
+		}
+	;
+
+name	:	NAME
+			{ $$ = $1.stoken; }
+	|	TYPENAME
+			{ $$ = $1.stoken; }
+	|	NAME_OR_INT
+			{ $$ = $1.stoken; }
+	;
+
+name_not_typename :	NAME
+/* These would be useful if name_not_typename was useful, but it is just
+   a fake for "variable", so these cause reduce/reduce conflicts because
+   the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
+   =exp) or just an exp.  If name_not_typename was ever used in an lvalue
+   context where only a name could occur, this might be useful.
+  	|	NAME_OR_INT
+   */
+	;
+
+%%
+
+/* Take care of parsing a number (anything that starts with a digit).
+   Set yylval and return the token type; update lexptr.
+   LEN is the number of characters in it.  */
+
+/*** Needs some error checking for the float case ***/
+
+static int
+parse_number (p, len, parsed_float, putithere)
+     register char *p;
+     register int len;
+     int parsed_float;
+     YYSTYPE *putithere;
+{
+  register LONGEST n = 0;
+  register LONGEST prevn = 0;
+  register int i;
+  register int c;
+  register int base = input_radix;
+  int unsigned_p = 0;
+  int long_p = 0;
+  unsigned LONGEST high_bit;
+  struct type *signed_type;
+  struct type *unsigned_type;
+
+  if (parsed_float)
+    {
+      /* It's a float since it contains a point or an exponent.  */
+      putithere->dval = atof (p);
+      return FLOAT;
+    }
+
+  /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
+  if (p[0] == '0')
+    switch (p[1])
+      {
+      case 'x':
+      case 'X':
+	if (len >= 3)
+	  {
+	    p += 2;
+	    base = 16;
+	    len -= 2;
+	  }
+	break;
+	
+      case 't':
+      case 'T':
+      case 'd':
+      case 'D':
+	if (len >= 3)
+	  {
+	    p += 2;
+	    base = 10;
+	    len -= 2;
+	  }
+	break;
+	
+      default:
+	base = 8;
+	break;
+      }
+  
+  while (len-- > 0)
+    {
+      c = *p++;
+      if (c >= 'A' && c <= 'Z')
+	c += 'a' - 'A';
+      if (c != 'l' && c != 'u')
+	n *= base;
+      if (c >= '0' && c <= '9')
+	n += i = c - '0';
+      else
+	{
+	  if (base > 10 && c >= 'a' && c <= 'f')
+	    n += i = c - 'a' + 10;
+	  else if (len == 0 && c == 'l') 
+            long_p = 1;
+	  else if (len == 0 && c == 'u')
+	    unsigned_p = 1;
+	  else
+	    return ERROR;	/* Char not a digit */
+	}
+      if (i >= base)
+	return ERROR;		/* Invalid digit in this base */
+      
+      /* Portably test for overflow (only works for nonzero values, so make
+	 a second check for zero).  */
+      if ((prevn >= n) && n != 0)
+	unsigned_p=1;		/* Try something unsigned */
+      /* If range checking enabled, portably test for unsigned overflow.  */
+      if (RANGE_CHECK && n != 0)
+	{
+	  if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
+	    range_error("Overflow on numeric constant.");	 
+	}
+      prevn = n;
+    }
+  
+  /* If the number is too big to be an int, or it's got an l suffix
+     then it's a long.  Work out if this has to be a long by
+     shifting right and and seeing if anything remains, and the
+     target int size is different to the target long size.
+     
+     In the expression below, we could have tested
+     (n >> TARGET_INT_BIT)
+     to see if it was zero,
+     but too many compilers warn about that, when ints and longs
+     are the same size.  So we shift it twice, with fewer bits
+     each time, for the same result.  */
+  
+  if ((TARGET_INT_BIT != TARGET_LONG_BIT 
+       && ((n >> 2) >> (TARGET_INT_BIT-2)))   /* Avoid shift warning */
+      || long_p)
+    {
+      high_bit = ((unsigned LONGEST)1) << (TARGET_LONG_BIT-1);
+      unsigned_type = builtin_type_unsigned_long;
+      signed_type = builtin_type_long;
+    }
+  else 
+    {
+      high_bit = ((unsigned LONGEST)1) << (TARGET_INT_BIT-1);
+      unsigned_type = builtin_type_unsigned_int;
+      signed_type = builtin_type_int;
+    }    
+  
+  putithere->typed_val.val = n;
+  
+  /* If the high bit of the worked out type is set then this number
+     has to be unsigned. */
+  
+  if (unsigned_p || (n & high_bit)) 
+    putithere->typed_val.type = unsigned_type;
+  else 
+    putithere->typed_val.type = signed_type;
+  
+  return INT;
+}
+
+struct token
+{
+  char *operator;
+  int token;
+  enum exp_opcode opcode;
+};
+
+static const struct token dot_ops[] =
+{
+  { ".and.", BOOL_AND, BINOP_END },
+  { ".AND.", BOOL_AND, BINOP_END },
+  { ".or.", BOOL_OR, BINOP_END },
+  { ".OR.", BOOL_OR, BINOP_END },
+  { ".not.", BOOL_NOT, BINOP_END },
+  { ".NOT.", BOOL_NOT, BINOP_END },
+  { ".eq.", EQUAL, BINOP_END },
+  { ".EQ.", EQUAL, BINOP_END },
+  { ".eqv.", EQUAL, BINOP_END },
+  { ".NEQV.", NOTEQUAL, BINOP_END },
+  { ".neqv.", NOTEQUAL, BINOP_END },
+  { ".EQV.", EQUAL, BINOP_END },
+  { ".ne.", NOTEQUAL, BINOP_END },
+  { ".NE.", NOTEQUAL, BINOP_END },
+  { ".le.", LEQ, BINOP_END },
+  { ".LE.", LEQ, BINOP_END },
+  { ".ge.", GEQ, BINOP_END },
+  { ".GE.", GEQ, BINOP_END },
+  { ".gt.", GREATERTHAN, BINOP_END },
+  { ".GT.", GREATERTHAN, BINOP_END },
+  { ".lt.", LESSTHAN, BINOP_END },
+  { ".LT.", LESSTHAN, BINOP_END },
+  { NULL, 0, 0 }
+};
+
+struct f77_boolean_val 
+{
+  char *name;
+  int value;
+}; 
+
+static const struct f77_boolean_val boolean_values[]  = 
+{
+  { ".true.", 1 },
+  { ".TRUE.", 1 },
+  { ".false.", 0 },
+  { ".FALSE.", 0 },
+  { NULL, 0 }
+};
+
+static const struct token f77_keywords[] = 
+{
+  { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END },
+  { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END },
+  { "character", CHARACTER, BINOP_END },
+  { "integer_2", INT_S2_KEYWORD, BINOP_END },
+  { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END },
+  { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END },
+  { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END },
+  { "integer", INT_KEYWORD, BINOP_END },
+  { "logical", LOGICAL_KEYWORD, BINOP_END },
+  { "real_16", REAL_S16_KEYWORD, BINOP_END },
+  { "complex", COMPLEX_S8_KEYWORD, BINOP_END },
+  { "sizeof", SIZEOF, BINOP_END },
+  { "real_8", REAL_S8_KEYWORD, BINOP_END },
+  { "real", REAL_KEYWORD, BINOP_END },
+  { NULL, 0, 0 }
+}; 
+
+/* Implementation of a dynamically expandable buffer for processing input
+   characters acquired through lexptr and building a value to return in
+   yylval. Ripped off from ch-exp.y */ 
+
+static char *tempbuf;		/* Current buffer contents */
+static int tempbufsize;		/* Size of allocated buffer */
+static int tempbufindex;	/* Current index into buffer */
+
+#define GROWBY_MIN_SIZE 64	/* Minimum amount to grow buffer by */
+
+#define CHECKBUF(size) \
+  do { \
+    if (tempbufindex + (size) >= tempbufsize) \
+      { \
+	growbuf_by_size (size); \
+      } \
+  } while (0);
+
+
+/* Grow the static temp buffer if necessary, including allocating the first one
+   on demand. */
+
+static void
+growbuf_by_size (count)
+     int count;
+{
+  int growby;
+
+  growby = max (count, GROWBY_MIN_SIZE);
+  tempbufsize += growby;
+  if (tempbuf == NULL)
+    tempbuf = (char *) malloc (tempbufsize);
+  else
+    tempbuf = (char *) realloc (tempbuf, tempbufsize);
+}
+
+/* Blatantly ripped off from ch-exp.y. This routine recognizes F77 
+   string-literals. 
+   
+   Recognize a string literal.  A string literal is a nonzero sequence
+   of characters enclosed in matching single quotes, except that
+   a single character inside single quotes is a character literal, which
+   we reject as a string literal.  To embed the terminator character inside
+   a string, it is simply doubled (I.E. 'this''is''one''string') */
+
+static int
+match_string_literal ()
+{
+  char *tokptr = lexptr;
+
+  for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
+    {
+      CHECKBUF (1);
+      if (*tokptr == *lexptr)
+	{
+	  if (*(tokptr + 1) == *lexptr)
+	    tokptr++;
+	  else
+	    break;
+	}
+      tempbuf[tempbufindex++] = *tokptr;
+    }
+  if (*tokptr == '\0'					/* no terminator */
+      || tempbufindex == 0)				/* no string */
+    return 0;
+  else
+    {
+      tempbuf[tempbufindex] = '\0';
+      yylval.sval.ptr = tempbuf;
+      yylval.sval.length = tempbufindex;
+      lexptr = ++tokptr;
+      return STRING_LITERAL;
+    }
+}
+
+/* Read one token, getting characters through lexptr.  */
+
+static int
+yylex ()
+{
+  int c;
+  int namelen;
+  unsigned int i,token;
+  char *tokstart;
+  char *tokptr;
+  int tempbufindex;
+  static char *tempbuf;
+  static int tempbufsize;
+  
+ retry:
+  
+  tokstart = lexptr;
+  
+  /* First of all, let us make sure we are not dealing with the 
+     special tokens .true. and .false. which evaluate to 1 and 0.  */
+  
+  if (*lexptr == '.')
+    { 
+      for (i=0;boolean_values[i].name != NULL;i++)
+	{
+	  if STREQN(tokstart,boolean_values[i].name,
+		    strlen(boolean_values[i].name))
+	    {
+	      lexptr += strlen(boolean_values[i].name); 
+	      yylval.lval = boolean_values[i].value; 
+	      return (BOOLEAN_LITERAL);
+	    }
+	}
+    }
+  
+  /* See if it is a special .foo. operator */
+  
+  for (i = 0; dot_ops[i].operator != NULL; i++)
+    if (STREQN(tokstart, dot_ops[i].operator,
+               strlen(dot_ops[i].operator)))
+      {
+	lexptr += strlen(dot_ops[i].operator);
+	yylval.opcode = dot_ops[i].opcode;
+	return dot_ops[i].token;
+      }
+  
+  switch (c = *tokstart)
+    {
+    case 0:
+      return 0;
+      
+    case ' ':
+    case '\t':
+    case '\n':
+      lexptr++;
+      goto retry;
+      
+    case '\'':
+      token = match_string_literal ();
+      if (token != 0)
+	return (token);
+      break;
+      
+    case '(':
+      paren_depth++;
+      lexptr++;
+      return c;
+      
+    case ')':
+      if (paren_depth == 0)
+	return 0;
+      paren_depth--;
+      lexptr++;
+      return c;
+      
+    case ',':
+      if (comma_terminates && paren_depth == 0)
+	return 0;
+      lexptr++;
+      return c;
+      
+    case '.':
+      /* Might be a floating point number.  */
+      if (lexptr[1] < '0' || lexptr[1] > '9')
+	goto symbol;		/* Nope, must be a symbol. */
+      /* FALL THRU into number case.  */
+      
+    case '0':
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+      {
+        /* It's a number.  */
+	int got_dot = 0, got_e = 0, got_d = 0, toktype;
+	register char *p = tokstart;
+	int hex = input_radix > 10;
+	
+	if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
+	  {
+	    p += 2;
+	    hex = 1;
+	  }
+	else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D'))
+	  {
+	    p += 2;
+	    hex = 0;
+	  }
+	
+	for (;; ++p)
+	  {
+	    if (!hex && !got_e && (*p == 'e' || *p == 'E'))
+	      got_dot = got_e = 1;
+	    else if (!hex && !got_e && (*p == 'd' || *p == 'D'))
+	      got_dot = got_d = 1;
+	    else if (!hex && !got_dot && *p == '.')
+	      got_dot = 1;
+	    else if ((got_e && (p[-1] == 'e' || p[-1] == 'E')
+		      || got_d && (p[-1] == 'd' || p[-1] == 'D'))
+		     && (*p == '-' || *p == '+'))
+	      /* This is the sign of the exponent, not the end of the
+		 number.  */
+	      continue;
+	    /* We will take any letters or digits.  parse_number will
+	       complain if past the radix, or if L or U are not final.  */
+	    else if ((*p < '0' || *p > '9')
+		     && ((*p < 'a' || *p > 'z')
+			 && (*p < 'A' || *p > 'Z')))
+	      break;
+	  }
+	toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
+				&yylval);
+        if (toktype == ERROR)
+          {
+	    char *err_copy = (char *) alloca (p - tokstart + 1);
+	    
+	    memcpy (err_copy, tokstart, p - tokstart);
+	    err_copy[p - tokstart] = 0;
+	    error ("Invalid number \"%s\".", err_copy);
+	  }
+	lexptr = p;
+	return toktype;
+      }
+      
+    case '+':
+    case '-':
+    case '*':
+    case '/':
+    case '%':
+    case '|':
+    case '&':
+    case '^':
+    case '~':
+    case '!':
+    case '@':
+    case '<':
+    case '>':
+    case '[':
+    case ']':
+    case '?':
+    case ':':
+    case '=':
+    case '{':
+    case '}':
+    symbol:
+      lexptr++;
+      return c;
+    }
+  
+  if (!(c == '_' || c == '$'
+	|| (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
+    /* We must have come across a bad character (e.g. ';').  */
+    error ("Invalid character '%c' in expression.", c);
+  
+  namelen = 0;
+  for (c = tokstart[namelen];
+       (c == '_' || c == '$' || (c >= '0' && c <= '9') 
+	|| (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')); 
+       c = tokstart[++namelen]);
+  
+  /* The token "if" terminates the expression and is NOT 
+     removed from the input stream.  */
+  
+  if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
+    return 0;
+  
+  lexptr += namelen;
+  
+  /* Handle the tokens $digits; also $ (short for $0) and $$ (short for $$1)
+     and $$digits (equivalent to $<-digits> if you could type that).
+     Make token type LAST, and put the number (the digits) in yylval.  */
+  
+ tryname:
+  if (*tokstart == '$')
+    {
+      register int negate = 0;
+
+      c = 1;
+      /* Double dollar means negate the number and add -1 as well.
+	 Thus $$ alone means -1.  */
+      if (namelen >= 2 && tokstart[1] == '$')
+	{
+	  negate = 1;
+	  c = 2;
+	}
+      if (c == namelen)
+	{
+	  /* Just dollars (one or two) */
+	  yylval.lval = - negate;
+	  return LAST;
+	}
+      /* Is the rest of the token digits?  */
+      for (; c < namelen; c++)
+	if (!(tokstart[c] >= '0' && tokstart[c] <= '9'))
+	  break;
+      if (c == namelen)
+	{
+	  yylval.lval = atoi (tokstart + 1 + negate);
+	  if (negate)
+	    yylval.lval = - yylval.lval;
+	  return LAST;
+	}
+    }
+  
+  /* Handle tokens that refer to machine registers:
+     $ followed by a register name.  */
+  
+  if (*tokstart == '$') {
+    for (c = 0; c < NUM_REGS; c++)
+      if (namelen - 1 == strlen (reg_names[c])
+	  && STREQN (tokstart + 1, reg_names[c], namelen - 1))
+	{
+	  yylval.lval = c;
+	  return REGNAME;
+	}
+    for (c = 0; c < num_std_regs; c++)
+      if (namelen - 1 == strlen (std_regs[c].name)
+	  && STREQN (tokstart + 1, std_regs[c].name, namelen - 1))
+	{
+	  yylval.lval = std_regs[c].regnum;
+	  return REGNAME;
+	}
+  }
+  /* Catch specific keywords.  */
+  
+  for (i = 0; f77_keywords[i].operator != NULL; i++)
+    if (STREQN(tokstart, f77_keywords[i].operator,
+               strlen(f77_keywords[i].operator)))
+      {
+	/* 	lexptr += strlen(f77_keywords[i].operator); */ 
+	yylval.opcode = f77_keywords[i].opcode;
+	return f77_keywords[i].token;
+      }
+  
+  yylval.sval.ptr = tokstart;
+  yylval.sval.length = namelen;
+  
+  /* Any other names starting in $ are debugger internal variables.  */
+  
+  if (*tokstart == '$')
+    {
+      yylval.ivar =  lookup_internalvar (copy_name (yylval.sval) + 1);
+      return VARIABLE;
+    }
+  
+  /* Use token-type TYPENAME for symbols that happen to be defined
+     currently as names of types; NAME for other symbols.
+     The caller is not constrained to care about the distinction.  */
+  {
+    char *tmp = copy_name (yylval.sval);
+    struct symbol *sym;
+    int is_a_field_of_this = 0;
+    int hextype;
+    
+    sym = lookup_symbol (tmp, expression_context_block,
+			 VAR_NAMESPACE,
+			 current_language->la_language == language_cplus
+			 ? &is_a_field_of_this : NULL,
+			 NULL);
+    if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
+      {
+	yylval.tsym.type = SYMBOL_TYPE (sym);
+	return TYPENAME;
+      }
+    if ((yylval.tsym.type = lookup_primitive_typename (tmp)) != 0)
+      return TYPENAME;
+    
+    /* Input names that aren't symbols but ARE valid hex numbers,
+       when the input radix permits them, can be names or numbers
+       depending on the parse.  Note we support radixes > 16 here.  */
+    if (!sym
+	&& ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
+	    || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
+      {
+ 	YYSTYPE newlval;	/* Its value is ignored.  */
+	hextype = parse_number (tokstart, namelen, 0, &newlval);
+	if (hextype == INT)
+	  {
+	    yylval.ssym.sym = sym;
+	    yylval.ssym.is_a_field_of_this = is_a_field_of_this;
+	    return NAME_OR_INT;
+	  }
+      }
+    
+    /* Any other kind of symbol */
+    yylval.ssym.sym = sym;
+    yylval.ssym.is_a_field_of_this = is_a_field_of_this;
+    return NAME;
+  }
+}
+
+void
+yyerror (msg)
+     char *msg;
+{
+  error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
+}
diff --git a/gdb/f-lang.c b/gdb/f-lang.c
new file mode 100644
index 0000000..f9d55b7
--- /dev/null
+++ b/gdb/f-lang.c
@@ -0,0 +1,945 @@
+/* Fortran language support routines for GDB, the GNU debugger.
+   Copyright 1993, 1994 Free Software Foundation, Inc.
+   Contributed by Motorola.  Adapted from the C parser by Farooq Butt
+   (fmbutt@engage.sps.mot.com).
+
+This file is part of GDB.
+
+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., 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+#include "defs.h"
+#include "symtab.h"
+#include "gdbtypes.h"
+#include "expression.h"
+#include "parser-defs.h"
+#include "language.h"
+#include "f-lang.h"
+
+/* Print the character C on STREAM as part of the contents of a literal
+   string whose delimiter is QUOTER.  Note that that format for printing
+   characters and strings is language specific.
+   FIXME:  This is a copy of the same function from c-exp.y.  It should
+   be replaced with a true F77 version.  */
+
+static void
+emit_char (c, stream, quoter)
+     register int c;
+     FILE *stream;
+     int quoter;
+{
+  c &= 0xFF;			/* Avoid sign bit follies */
+  
+  if (PRINT_LITERAL_FORM (c))
+    {
+      if (c == '\\' || c == quoter)
+	fputs_filtered ("\\", stream);
+      fprintf_filtered (stream, "%c", c);
+    }
+  else
+    {
+      switch (c)
+	{
+	case '\n':
+	  fputs_filtered ("\\n", stream);
+	  break;
+	case '\b':
+	  fputs_filtered ("\\b", stream);
+	  break;
+	case '\t':
+	  fputs_filtered ("\\t", stream);
+	  break;
+	case '\f':
+	  fputs_filtered ("\\f", stream);
+	  break;
+	case '\r':
+	  fputs_filtered ("\\r", stream);
+	  break;
+	case '\033':
+	  fputs_filtered ("\\e", stream);
+	  break;
+	case '\007':
+	  fputs_filtered ("\\a", stream);
+	  break;
+	default:
+	  fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
+	  break;
+	}
+    }
+}
+
+/* FIXME:  This is a copy of the same function from c-exp.y.  It should
+   be replaced with a true F77version. */
+
+static void
+f_printchar (c, stream)
+     int c;
+     FILE *stream;
+{
+  fputs_filtered ("'", stream);
+  emit_char (c, stream, '\'');
+  fputs_filtered ("'", stream);
+}
+
+/* Print the character string STRING, printing at most LENGTH characters.
+   Printing stops early if the number hits print_max; repeat counts
+   are printed as appropriate.  Print ellipses at the end if we
+   had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
+   FIXME:  This is a copy of the same function from c-exp.y.  It should
+   be replaced with a true F77 version. */
+
+static void
+f_printstr (stream, string, length, force_ellipses)
+     FILE *stream;
+     char *string;
+     unsigned int length;
+     int force_ellipses;
+{
+  register unsigned int i;
+  unsigned int things_printed = 0;
+  int in_quotes = 0;
+  int need_comma = 0;
+  extern int inspect_it;
+  extern int repeat_count_threshold;
+  extern int print_max;
+  
+  if (length == 0)
+    {
+      fputs_filtered ("''", stdout);
+      return;
+    }
+  
+  for (i = 0; i < length && things_printed < print_max; ++i)
+    {
+      /* Position of the character we are examining
+	 to see whether it is repeated.  */
+      unsigned int rep1;
+      /* Number of repetitions we have detected so far.  */
+      unsigned int reps;
+      
+      QUIT;
+      
+      if (need_comma)
+	{
+	  fputs_filtered (", ", stream);
+	  need_comma = 0;
+	}
+      
+      rep1 = i + 1;
+      reps = 1;
+      while (rep1 < length && string[rep1] == string[i])
+	{
+	  ++rep1;
+	  ++reps;
+	}
+      
+      if (reps > repeat_count_threshold)
+	{
+	  if (in_quotes)
+	    {
+	      if (inspect_it)
+		fputs_filtered ("\\', ", stream);
+	      else
+		fputs_filtered ("', ", stream);
+	      in_quotes = 0;
+	    }
+	  f_printchar (string[i], stream);
+	  fprintf_filtered (stream, " <repeats %u times>", reps);
+	  i = rep1 - 1;
+	  things_printed += repeat_count_threshold;
+	  need_comma = 1;
+	}
+      else
+	{
+	  if (!in_quotes)
+	    {
+	      if (inspect_it)
+		fputs_filtered ("\\'", stream);
+	      else
+		fputs_filtered ("'", stream);
+	      in_quotes = 1;
+	    }
+	  emit_char (string[i], stream, '"');
+	  ++things_printed;
+	}
+    }
+  
+  /* Terminate the quotes if necessary.  */
+  if (in_quotes)
+    {
+      if (inspect_it)
+	fputs_filtered ("\\'", stream);
+      else
+	fputs_filtered ("'", stream);
+    }
+  
+  if (force_ellipses || i < length)
+    fputs_filtered ("...", stream);
+}
+
+/* FIXME:  This is a copy of c_create_fundamental_type(), before
+   all the non-C types were stripped from it.  Needs to be fixed
+   by an experienced F77 programmer. */
+
+static struct type *
+f_create_fundamental_type (objfile, typeid)
+     struct objfile *objfile;
+     int typeid;
+{
+  register struct type *type = NULL;
+  
+  switch (typeid)
+    {
+    case FT_VOID:
+      type = init_type (TYPE_CODE_VOID,
+			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+			0, "VOID", objfile);
+      break;
+    case FT_BOOLEAN:
+      type = init_type (TYPE_CODE_BOOL,
+			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+			TYPE_FLAG_UNSIGNED, "boolean", objfile);
+      break;
+    case FT_STRING:
+      type = init_type (TYPE_CODE_STRING,
+			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+			0, "string", objfile);
+      break;
+    case FT_CHAR:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+			0, "character", objfile);
+      break;
+    case FT_SIGNED_CHAR:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+			0, "integer*1", objfile);
+      break;
+    case FT_UNSIGNED_CHAR:
+      type = init_type (TYPE_CODE_BOOL,
+			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+			TYPE_FLAG_UNSIGNED, "logical*1", objfile);
+      break;
+    case FT_SHORT:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+			0, "integer*2", objfile);
+      break;
+    case FT_SIGNED_SHORT:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+			0, "short", objfile);	/* FIXME-fnf */
+      break;
+    case FT_UNSIGNED_SHORT:
+      type = init_type (TYPE_CODE_BOOL,
+			TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+			TYPE_FLAG_UNSIGNED, "logical*2", objfile);
+      break;
+    case FT_INTEGER:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_INT_BIT / TARGET_CHAR_BIT,
+			0, "integer*4", objfile);
+      break;
+    case FT_SIGNED_INTEGER:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_INT_BIT / TARGET_CHAR_BIT,
+			0, "integer", objfile); /* FIXME -fnf */
+      break;
+    case FT_UNSIGNED_INTEGER:
+      type = init_type (TYPE_CODE_BOOL, 
+			TARGET_INT_BIT / TARGET_CHAR_BIT,
+			TYPE_FLAG_UNSIGNED, "logical*4", objfile);
+      break;
+    case FT_FIXED_DECIMAL:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_INT_BIT / TARGET_CHAR_BIT,
+			0, "fixed decimal", objfile);
+      break;
+    case FT_LONG:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_LONG_BIT / TARGET_CHAR_BIT,
+			0, "long", objfile);
+      break;
+    case FT_SIGNED_LONG:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_LONG_BIT / TARGET_CHAR_BIT,
+			0, "long", objfile); /* FIXME -fnf */
+      break;
+    case FT_UNSIGNED_LONG:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_LONG_BIT / TARGET_CHAR_BIT,
+			TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
+      break;
+    case FT_LONG_LONG:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
+			0, "long long", objfile);
+      break;
+    case FT_SIGNED_LONG_LONG:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
+			0, "signed long long", objfile);
+      break;
+    case FT_UNSIGNED_LONG_LONG:
+      type = init_type (TYPE_CODE_INT,
+			TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
+			TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
+      break;
+    case FT_FLOAT:
+      type = init_type (TYPE_CODE_FLT,
+			TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
+			0, "real", objfile);
+      break;
+    case FT_DBL_PREC_FLOAT:
+      type = init_type (TYPE_CODE_FLT,
+			TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
+			0, "real*8", objfile);
+      break;
+    case FT_FLOAT_DECIMAL:
+      type = init_type (TYPE_CODE_FLT,
+			TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
+			0, "floating decimal", objfile);
+      break;
+    case FT_EXT_PREC_FLOAT:
+      type = init_type (TYPE_CODE_FLT,
+			TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
+			0, "real*16", objfile);
+      break;
+    case FT_COMPLEX:
+      type = init_type (TYPE_CODE_FLT,
+			TARGET_COMPLEX_BIT / TARGET_CHAR_BIT,
+			0, "complex*8", objfile);
+      break;
+    case FT_DBL_PREC_COMPLEX:
+      type = init_type (TYPE_CODE_FLT,
+			TARGET_DOUBLE_COMPLEX_BIT / TARGET_CHAR_BIT,
+			0, "complex*16", objfile);
+      break;
+    case FT_EXT_PREC_COMPLEX:
+      type = init_type (TYPE_CODE_FLT,
+			TARGET_DOUBLE_COMPLEX_BIT / TARGET_CHAR_BIT,
+			0, "complex*32", objfile);
+      break;
+    default:
+      /* FIXME:  For now, if we are asked to produce a type not in this
+	 language, create the equivalent of a C integer type with the
+	 name "<?type?>".  When all the dust settles from the type
+	 reconstruction work, this should probably become an error. */
+      type = init_type (TYPE_CODE_INT,
+			TARGET_INT_BIT / TARGET_CHAR_BIT,
+			0, "<?type?>", objfile);
+      warning ("internal error: no F77 fundamental type %d", typeid);
+      break;
+    }
+  return (type);
+}
+
+
+/* Table of operators and their precedences for printing expressions.  */
+
+static const struct op_print f_op_print_tab[] = {
+  { "+",     BINOP_ADD, PREC_ADD, 0 },
+  { "+",     UNOP_PLUS, PREC_PREFIX, 0 },
+  { "-",     BINOP_SUB, PREC_ADD, 0 },
+  { "-",     UNOP_NEG, PREC_PREFIX, 0 },
+  { "*",     BINOP_MUL, PREC_MUL, 0 },
+  { "/",     BINOP_DIV, PREC_MUL, 0 },
+  { "DIV",   BINOP_INTDIV, PREC_MUL, 0 },
+  { "MOD",   BINOP_REM, PREC_MUL, 0 },
+  { "=",     BINOP_ASSIGN, PREC_ASSIGN, 1 },
+  { ".OR.",  BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0 },
+  { ".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0 },
+  { ".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0 },
+  { ".EQ.",  BINOP_EQUAL, PREC_EQUAL, 0 },
+  { ".NE.",  BINOP_NOTEQUAL, PREC_EQUAL, 0 },
+  { ".LE.",  BINOP_LEQ, PREC_ORDER, 0 },
+  { ".GE.",  BINOP_GEQ, PREC_ORDER, 0 },
+  { ".GT.",  BINOP_GTR, PREC_ORDER, 0 },
+  { ".LT.",  BINOP_LESS, PREC_ORDER, 0 },
+  { "**",    UNOP_IND, PREC_PREFIX, 0 },
+  { "@",     BINOP_REPEAT, PREC_REPEAT, 0 },
+  { NULL,    0, 0, 0 }
+};
+
+/* The built-in types of F77.  */
+
+struct type *builtin_type_f_character;
+struct type *builtin_type_f_integer;
+struct type *builtin_type_f_logical;
+struct type *builtin_type_f_logical_s1;
+struct type *builtin_type_f_logical_s2;
+struct type *builtin_type_f_integer; 
+struct type *builtin_type_f_integer_s2;
+struct type *builtin_type_f_real;
+struct type *builtin_type_f_real_s8;
+struct type *builtin_type_f_real_s16;
+struct type *builtin_type_f_complex_s8;
+struct type *builtin_type_f_complex_s16;
+struct type *builtin_type_f_complex_s32;
+struct type *builtin_type_f_void;
+
+struct type ** const (f_builtin_types[]) = 
+{
+  &builtin_type_f_character,
+  &builtin_type_f_integer,
+  &builtin_type_f_logical,
+  &builtin_type_f_logical_s1,
+  &builtin_type_f_logical_s2,
+  &builtin_type_f_integer,
+  &builtin_type_f_integer_s2,
+  &builtin_type_f_real,
+  &builtin_type_f_real_s8,
+  &builtin_type_f_real_s16,
+  &builtin_type_f_complex_s8,
+  &builtin_type_f_complex_s16,
+#if 0
+  &builtin_type_f_complex_s32,
+#endif
+  &builtin_type_f_void,
+  0
+};
+
+int c_value_print();
+
+const struct language_defn f_language_defn = {
+  "fortran",
+  language_fortran,
+  f_builtin_types,
+  range_check_on,
+  type_check_on,
+  f_parse,			/* parser */
+  f_error,			/* parser error function */
+  f_printchar,			/* Print character constant */
+  f_printstr,			/* function to print string constant */
+  f_create_fundamental_type,	/* Create fundamental type in this language */
+  f_print_type,		        /* Print a type using appropriate syntax */
+  f_val_print,			/* Print a value using appropriate syntax */
+  c_value_print,  /* FIXME */
+  {"",      "",   "",   ""},	/* Binary format info */
+  {"0%o",  "0",   "o", ""},	/* Octal format info */
+  {"%d",   "",    "d", ""},	/* Decimal format info */
+  {"0x%x", "0x",  "x", ""},	/* Hex format info */
+  f_op_print_tab,		/* expression operators for printing */
+  LANG_MAGIC
+  };
+
+void
+_initialize_f_language ()
+{
+  builtin_type_f_void =
+    init_type (TYPE_CODE_VOID, 1,
+	       0,
+	       "VOID", (struct objfile *) NULL);
+  
+  builtin_type_f_character =
+    init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "character", (struct objfile *) NULL);
+  
+  builtin_type_f_logical_s1 =
+    init_type (TYPE_CODE_BOOL, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+	       TYPE_FLAG_UNSIGNED,
+	       "logical*1", (struct objfile *) NULL);
+  
+  builtin_type_f_integer_s2 =
+    init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "integer*2", (struct objfile *) NULL);
+  
+  builtin_type_f_logical_s2 =
+    init_type (TYPE_CODE_BOOL, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+	       TYPE_FLAG_UNSIGNED,
+	       "logical*2", (struct objfile *) NULL);
+  
+  builtin_type_f_integer =
+    init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "integer", (struct objfile *) NULL);
+  
+  builtin_type_f_logical =
+    init_type (TYPE_CODE_BOOL, TARGET_INT_BIT / TARGET_CHAR_BIT,
+	       TYPE_FLAG_UNSIGNED,
+	       "logical*4", (struct objfile *) NULL);
+  
+  builtin_type_f_real =
+    init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "real", (struct objfile *) NULL);
+  
+  builtin_type_f_real_s8 =
+    init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "real*8", (struct objfile *) NULL);
+  
+  builtin_type_f_real_s16 =
+    init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "real*16", (struct objfile *) NULL);
+  
+  builtin_type_f_complex_s8 =
+    init_type (TYPE_CODE_COMPLEX, TARGET_COMPLEX_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "complex*8", (struct objfile *) NULL);
+  
+  builtin_type_f_complex_s16 =
+    init_type (TYPE_CODE_COMPLEX, TARGET_DOUBLE_COMPLEX_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "complex*16", (struct objfile *) NULL);
+  
+#if 0
+  /* We have a new size == 4 double floats for the
+     complex*32 data type */
+  
+  builtin_type_f_complex_s32 = 
+    init_type (TYPE_CODE_COMPLEX, TARGET_EXT_COMPLEX_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "complex*32", (struct objfile *) NULL);
+#endif
+  builtin_type_string =
+    init_type (TYPE_CODE_STRING, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+	       0,
+	       "character string", (struct objfile *) NULL); 
+  
+  add_language (&f_language_defn);
+}
+
+/* Following is dubious stuff that had been in the xcoff reader. */
+
+struct saved_fcn
+{
+  long                         line_offset;  /* Line offset for function */ 
+  struct saved_fcn             *next;      
+}; 
+
+
+struct saved_bf_symnum 
+{
+  long       symnum_fcn;  /* Symnum of function (i.e. .function directive) */
+  long       symnum_bf;   /* Symnum of .bf for this function */ 
+  struct saved_bf_symnum *next;  
+}; 
+
+typedef struct saved_fcn           SAVED_FUNCTION, *SAVED_FUNCTION_PTR; 
+typedef struct saved_bf_symnum     SAVED_BF, *SAVED_BF_PTR; 
+
+
+SAVED_BF_PTR allocate_saved_bf_node()
+{
+  SAVED_BF_PTR new;
+  
+  new = (SAVED_BF_PTR) malloc (sizeof (SAVED_BF));
+  
+  if (new == NULL)
+    fatal("could not allocate enough memory to save one more .bf on save list");
+  return(new);
+}
+
+SAVED_FUNCTION *allocate_saved_function_node()
+{
+  SAVED_FUNCTION *new;
+  
+  new = (SAVED_FUNCTION *) malloc (sizeof (SAVED_FUNCTION));
+  
+  if (new == NULL)
+    fatal("could not allocate enough memory to save one more function on save list");
+  
+  return(new);
+}
+
+SAVED_F77_COMMON_PTR allocate_saved_f77_common_node()
+{
+  SAVED_F77_COMMON_PTR new;
+  
+  new = (SAVED_F77_COMMON_PTR) malloc (sizeof (SAVED_F77_COMMON));
+  
+  if (new == NULL)
+    fatal("could not allocate enough memory to save one more F77 COMMON blk on save list");
+  
+  return(new);
+}
+
+COMMON_ENTRY_PTR allocate_common_entry_node()
+{
+  COMMON_ENTRY_PTR new;
+  
+  new = (COMMON_ENTRY_PTR) malloc (sizeof (COMMON_ENTRY));
+  
+  if (new == NULL)
+    fatal("could not allocate enough memory to save one more COMMON entry on save list");
+  
+  return(new);
+}
+
+
+SAVED_F77_COMMON_PTR head_common_list=NULL;     /* Ptr to 1st saved COMMON  */
+SAVED_F77_COMMON_PTR tail_common_list=NULL;     /* Ptr to last saved COMMON  */
+SAVED_F77_COMMON_PTR current_common=NULL;       /* Ptr to current COMMON */
+
+static SAVED_BF_PTR saved_bf_list=NULL;          /* Ptr to (.bf,function) 
+                                                    list*/
+static SAVED_BF_PTR saved_bf_list_end=NULL;      /* Ptr to above list's end */
+static SAVED_BF_PTR current_head_bf_list=NULL;   /* Current head of above list
+						  */
+
+static SAVED_BF_PTR tmp_bf_ptr;                  /* Generic temporary for use 
+                                                    in macros */ 
+
+
+/* The following function simply enters a given common block onto 
+   the global common block chain */
+
+void add_common_block(name,offset,secnum,func_stab)
+     char *name;
+     CORE_ADDR offset;
+     int secnum;
+     char *func_stab;
+     
+{
+  SAVED_F77_COMMON_PTR tmp;
+  char *c,*local_copy_func_stab; 
+  
+  /* If the COMMON block we are trying to add has a blank 
+     name (i.e. "#BLNK_COM") then we set it to __BLANK
+     because the darn "#" character makes GDB's input 
+     parser have fits. */ 
+  
+  
+  if (STREQ(name,BLANK_COMMON_NAME_ORIGINAL) ||
+      STREQ(name,BLANK_COMMON_NAME_MF77))
+    {
+      
+      free(name);
+      name = alloca(strlen(BLANK_COMMON_NAME_LOCAL) + 1); 
+      strcpy(name,BLANK_COMMON_NAME_LOCAL); 
+    }
+  
+  tmp = allocate_saved_f77_common_node();
+  
+  local_copy_func_stab = malloc (strlen(func_stab) + 1);
+  strcpy(local_copy_func_stab,func_stab); 
+  
+  tmp->name = malloc(strlen(name) + 1);
+  
+  /* local_copy_func_stab is a stabstring, let us first extract the 
+     function name from the stab by NULLing out the ':' character. */ 
+  
+  
+  c = NULL; 
+  c = strchr(local_copy_func_stab,':');
+  
+  if (c)
+    *c = '\0';
+  else
+    error("Malformed function STAB found in add_common_block()");
+  
+  
+  tmp->owning_function = malloc (strlen(local_copy_func_stab) + 1); 
+  
+  strcpy(tmp->owning_function,local_copy_func_stab); 
+  
+  strcpy(tmp->name,name);
+  tmp->offset = offset; 
+  tmp->next = NULL;
+  tmp->entries = NULL;
+  tmp->secnum = secnum; 
+  
+  current_common = tmp;
+  
+  if (head_common_list == NULL)
+    {
+      head_common_list = tail_common_list = tmp;
+    }
+  else
+    {
+      tail_common_list->next = tmp; 
+      tail_common_list = tmp;
+    }
+  
+}
+
+
+/* The following function simply enters a given common entry onto 
+   the "current_common" block that has been saved away. */ 
+
+void add_common_entry(entry_sym_ptr)
+     struct symbol *entry_sym_ptr; 
+{
+  COMMON_ENTRY_PTR tmp;
+  
+  
+  
+  /* The order of this list is important, since 
+     we expect the entries to appear in decl.
+     order when we later issue "info common" calls */ 
+  
+  tmp = allocate_common_entry_node();
+  
+  tmp->next = NULL;
+  tmp->symbol = entry_sym_ptr;
+  
+  if (current_common == NULL)
+    error("Attempt to add COMMON entry with no block open!");
+  else         
+    {
+      if (current_common->entries == NULL)
+	{
+	  current_common->entries = tmp;
+	  current_common->end_of_entries = tmp; 
+	}
+      else
+	{
+	  current_common->end_of_entries->next = tmp; 
+	  current_common->end_of_entries = tmp; 
+	}
+    }
+  
+  
+}
+
+/* This routine finds the first encountred COMMON block named "name" */ 
+
+SAVED_F77_COMMON_PTR find_first_common_named(name)
+     char *name; 
+{
+  
+  SAVED_F77_COMMON_PTR tmp;
+  
+  tmp = head_common_list;
+  
+  while (tmp != NULL)
+    {
+      if (STREQ(tmp->name,name))
+	return(tmp);
+      else
+	tmp = tmp->next;
+    }
+  return(NULL); 
+}
+
+/* This routine finds the first encountred COMMON block named "name" 
+   that belongs to function funcname */ 
+
+SAVED_F77_COMMON_PTR find_common_for_function(name, funcname)
+     char *name;
+     char *funcname; 
+{
+  
+  SAVED_F77_COMMON_PTR tmp;
+  
+  tmp = head_common_list;
+  
+  while (tmp != NULL)
+    {
+      if (STREQ(tmp->name,name) && STREQ(tmp->owning_function,funcname))
+	return(tmp);
+      else
+	tmp = tmp->next;
+    }
+  return(NULL); 
+}
+
+
+
+
+/* The following function is called to patch up the offsets 
+   for the statics contained in the COMMON block named
+   "name."  */ 
+
+
+void patch_common_entries (blk, offset, secnum)
+     SAVED_F77_COMMON_PTR blk;
+     CORE_ADDR offset;
+     int secnum;
+{
+  COMMON_ENTRY_PTR entry;
+  
+  blk->offset = offset;  /* Keep this around for future use. */ 
+  
+  entry = blk->entries;
+  
+  while (entry != NULL)
+    {
+      SYMBOL_VALUE (entry->symbol) += offset; 
+      SYMBOL_SECTION (entry->symbol) = secnum;
+      
+      entry = entry->next;
+    }
+  blk->secnum = secnum; 
+}
+
+
+/* Patch all commons named "name" that need patching.Since COMMON
+   blocks occur with relative infrequency, we simply do a linear scan on
+   the name.  Eventually, the best way to do this will be a
+   hashed-lookup.  Secnum is the section number for the .bss section
+   (which is where common data lives). */
+
+
+void patch_all_commons_by_name (name, offset, secnum)
+     char *name;
+     CORE_ADDR offset;
+     int secnum;
+{
+  
+  SAVED_F77_COMMON_PTR tmp;
+  
+  /* For blank common blocks, change the canonical reprsentation 
+     of a blank name */
+  
+  if ((STREQ(name,BLANK_COMMON_NAME_ORIGINAL)) ||
+      (STREQ(name,BLANK_COMMON_NAME_MF77)))
+    {
+      free(name);
+      name = alloca(strlen(BLANK_COMMON_NAME_LOCAL) + 1); 
+      strcpy(name,BLANK_COMMON_NAME_LOCAL); 
+    }
+  
+  tmp = head_common_list;
+  
+  while (tmp != NULL)
+    {
+      if (COMMON_NEEDS_PATCHING(tmp))
+	if (STREQ(tmp->name,name))
+	  patch_common_entries(tmp,offset,secnum); 
+      
+      tmp = tmp->next;
+    }   
+  
+}
+
+
+
+
+
+/* This macro adds the symbol-number for the start of the function 
+   (the symbol number of the .bf) referenced by symnum_fcn to a 
+   list.  This list, in reality should be a FIFO queue but since 
+   #line pragmas sometimes cause line ranges to get messed up 
+   we simply create a linear list.  This list can then be searched 
+   first by a queueing algorithm and upon failure fall back to 
+   a linear scan. */ 
+
+#define ADD_BF_SYMNUM(bf_sym,fcn_sym) \
+  \
+  if (saved_bf_list == NULL) \
+{ \
+    tmp_bf_ptr = allocate_saved_bf_node(); \
+      \
+	tmp_bf_ptr->symnum_bf = (bf_sym); \
+	  tmp_bf_ptr->symnum_fcn = (fcn_sym);  \
+	    tmp_bf_ptr->next = NULL; \
+	      \
+		current_head_bf_list = saved_bf_list = tmp_bf_ptr; \
+		  saved_bf_list_end = tmp_bf_ptr; \
+		  } \
+else \
+{  \
+     tmp_bf_ptr = allocate_saved_bf_node(); \
+       \
+         tmp_bf_ptr->symnum_bf = (bf_sym);  \
+	   tmp_bf_ptr->symnum_fcn = (fcn_sym);  \
+	     tmp_bf_ptr->next = NULL;  \
+	       \
+		 saved_bf_list_end->next = tmp_bf_ptr;  \
+		   saved_bf_list_end = tmp_bf_ptr; \
+		   } 
+
+
+/* This function frees the entire (.bf,function) list */ 
+
+void 
+  clear_bf_list()
+{
+  
+  SAVED_BF_PTR tmp = saved_bf_list;
+  SAVED_BF_PTR next = NULL; 
+  
+  while (tmp != NULL)
+    {
+      next = tmp->next;
+      free(tmp);
+      tmp=next;
+    }
+  saved_bf_list = NULL;
+}
+
+int global_remote_debug;
+
+long
+get_bf_for_fcn (the_function)
+     long the_function;
+{
+  SAVED_BF_PTR tmp;
+  int nprobes = 0;
+  long retval = 0; 
+  
+  /* First use a simple queuing algorithm (i.e. look and see if the 
+     item at the head of the queue is the one you want)  */
+  
+  if (saved_bf_list == NULL)
+    fatal ("cannot get .bf node off empty list"); 
+  
+  if (current_head_bf_list != NULL) 
+    if (current_head_bf_list->symnum_fcn == the_function)
+      {
+	if (global_remote_debug) 
+	  fprintf(stderr,"*"); 
+
+	tmp = current_head_bf_list; 
+	current_head_bf_list = current_head_bf_list->next;
+	return(tmp->symnum_bf); 
+      }
+  
+  /* If the above did not work (probably because #line directives were 
+     used in the sourcefile and they messed up our internal tables) we now do
+     the ugly linear scan */
+  
+  if (global_remote_debug) 
+    fprintf(stderr,"\ndefaulting to linear scan\n"); 
+  
+  nprobes = 0; 
+  tmp = saved_bf_list;
+  while (tmp != NULL)
+    {
+      nprobes++; 
+      if (tmp->symnum_fcn == the_function)
+	{ 
+	  if (global_remote_debug)
+	    fprintf(stderr,"Found in %d probes\n",nprobes);
+	  current_head_bf_list = tmp->next;
+	  return(tmp->symnum_bf);
+	} 
+      tmp= tmp->next; 
+    }
+  
+  return(-1); 
+}
+
+static SAVED_FUNCTION_PTR saved_function_list=NULL; 
+static SAVED_FUNCTION_PTR saved_function_list_end=NULL; 
+
+void clear_function_list()
+{
+  SAVED_FUNCTION_PTR tmp = saved_function_list;
+  SAVED_FUNCTION_PTR next = NULL; 
+  
+  while (tmp != NULL)
+    {
+      next = tmp->next;
+      free(tmp);
+      tmp = next;
+    }
+  
+  saved_function_list = NULL;
+}
diff --git a/gdb/f-lang.h b/gdb/f-lang.h
new file mode 100644
index 0000000..9611366
--- /dev/null
+++ b/gdb/f-lang.h
@@ -0,0 +1,90 @@
+/* Fortran language support definitions for GDB, the GNU debugger.
+   Copyright 1992, 1993, 1994 Free Software Foundation, Inc.
+   Contributed by Motorola.  Adapted from the C definitions by Farooq Butt
+   (fmbutt@engage.sps.mot.com).
+
+This file is part of GDB.
+
+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., 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+extern int f_parse PARAMS ((void));
+
+extern void f_error PARAMS ((char *));	/* Defined in f-exp.y */
+
+extern void f_print_type PARAMS ((struct type *, char *, FILE *, int, int));
+
+extern int f_val_print PARAMS ((struct type *, char *, CORE_ADDR, FILE *,
+				int, int, int, enum val_prettyprint));
+
+/* Language-specific data structures */ 
+
+struct common_entry
+{
+  struct symbol *symbol;                    /* The symbol node corresponding
+					       to this component */ 
+  struct common_entry *next;                /* The next component */ 
+};
+
+struct saved_f77_common
+{
+  char *name;                                /* Name of COMMON */
+  char *owning_function;                     /* Name of parent function */ 
+  int secnum;                                /* Section # of .bss */ 
+  CORE_ADDR offset;                          /* Offset from .bss for 
+						this block */
+  struct common_entry *entries;              /* List of block's components */
+  struct common_entry *end_of_entries;       /* ptr. to end of components */ 
+  struct saved_f77_common *next;              /* Next saved COMMON block */ 
+};
+
+typedef struct saved_f77_common    SAVED_F77_COMMON, *SAVED_F77_COMMON_PTR;
+
+typedef struct common_entry        COMMON_ENTRY, *COMMON_ENTRY_PTR;
+
+extern SAVED_F77_COMMON_PTR head_common_list;   /* Ptr to 1st saved COMMON  */
+extern SAVED_F77_COMMON_PTR tail_common_list;   /* Ptr to last saved COMMON  */
+extern SAVED_F77_COMMON_PTR current_common;     /* Ptr to current COMMON */
+
+#define UNINITIALIZED_SECNUM -1 
+#define COMMON_NEEDS_PATCHING(blk) ((blk)->secnum == UNINITIALIZED_SECNUM)
+
+#define BLANK_COMMON_NAME_ORIGINAL "#BLNK_COM"  /* XLF assigned  */
+#define BLANK_COMMON_NAME_MF77     "__BLNK__"   /* MF77 assigned  */
+#define BLANK_COMMON_NAME_LOCAL    "__BLANK"    /* Local GDB */
+
+#define BOUND_FETCH_OK 1
+#define BOUND_FETCH_ERROR -999
+
+/* When reasonable array bounds cannot be fetched, such as when 
+you ask to 'mt print symbols' and there is no stack frame and 
+therefore no way of knowing the bounds of stack-based arrays, 
+we have to assign default bounds, these are as good as any... */ 
+
+#define DEFAULT_UPPER_BOUND 999999
+#define DEFAULT_LOWER_BOUND -999999
+
+extern char *real_main_name;   /* Name of main function */ 
+extern int  real_main_c_value;   /* C_value field of main function */ 
+
+extern int f77_get_dynamic_upperbound PARAMS ((struct type *, int *));
+
+extern int f77_get_dynamic_lowerbound PARAMS ((struct type *, int *));
+
+extern void f77_get_dynamic_array_length PARAMS ((struct type *)); 
+
+#define DEFAULT_DOTMAIN_NAME_IN_MF77            ".MAIN_"
+#define DEFAULT_MAIN_NAME_IN_MF77               "MAIN_"
+#define DEFAULT_DOTMAIN_NAME_IN_XLF_BUGGY       ".main "
+#define DEFAULT_DOTMAIN_NAME_IN_XLF             ".main"
diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
new file mode 100644
index 0000000..3540f48
--- /dev/null
+++ b/gdb/f-typeprint.c
@@ -0,0 +1,457 @@
+/* Support for printing Fortran types for GDB, the GNU debugger.
+   Copyright 1986, 1988, 1989, 1991 Free Software Foundation, Inc.
+   Contributed by Motorola.  Adapted from the C version by Farooq Butt
+   (fmbutt@engage.sps.mot.com).
+
+This file is part of GDB.
+
+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., 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+#include "defs.h"
+#include "obstack.h"
+#include "bfd.h"
+#include "symtab.h"
+#include "gdbtypes.h"
+#include "expression.h"
+#include "value.h"
+#include "gdbcore.h"
+#include "target.h"
+#include "command.h"
+#include "gdbcmd.h"
+#include "language.h"
+#include "demangle.h"
+#include "f-lang.h"
+#include "typeprint.h"
+#include "frame.h"  /* ??? */
+
+#include <string.h>
+#include <errno.h>
+
+static void f_type_print_args PARAMS ((struct type *, FILE *));
+
+static void f_type_print_varspec_suffix PARAMS ((struct type *, FILE *,
+						 int, int, int));
+
+void f_type_print_varspec_prefix PARAMS ((struct type *, FILE *, int, int));
+
+void f_type_print_base PARAMS ((struct type *, FILE *, int, int));
+
+
+/* LEVEL is the depth to indent lines by.  */
+
+void
+f_print_type (type, varstring, stream, show, level)
+     struct type *type;
+     char *varstring;
+     FILE *stream;
+     int show;
+     int level;
+{
+  register enum type_code code;
+  int demangled_args;
+
+  f_type_print_base (type, stream, show, level);
+  code = TYPE_CODE (type);
+  if ((varstring != NULL && *varstring != '\0')
+      ||
+      /* Need a space if going to print stars or brackets;
+	 but not if we will print just a type name.  */
+      ((show > 0 || TYPE_NAME (type) == 0)
+       &&
+       (code == TYPE_CODE_PTR || code == TYPE_CODE_FUNC
+	|| code == TYPE_CODE_METHOD
+	|| code == TYPE_CODE_ARRAY
+	|| code == TYPE_CODE_MEMBER
+	|| code == TYPE_CODE_REF)))
+    fputs_filtered (" ", stream);
+  f_type_print_varspec_prefix (type, stream, show, 0);
+
+  fputs_filtered (varstring, stream);
+
+  /* For demangled function names, we have the arglist as part of the name,
+     so don't print an additional pair of ()'s */
+
+  demangled_args = varstring[strlen(varstring) - 1] == ')';
+  f_type_print_varspec_suffix (type, stream, show, 0, demangled_args);
+}
+
+/* Print any asterisks or open-parentheses needed before the
+   variable name (to describe its type).
+
+   On outermost call, pass 0 for PASSED_A_PTR.
+   On outermost call, SHOW > 0 means should ignore
+   any typename for TYPE and show its details.
+   SHOW is always zero on recursive calls.  */
+
+void
+f_type_print_varspec_prefix (type, stream, show, passed_a_ptr)
+     struct type *type;
+     FILE *stream;
+     int show;
+     int passed_a_ptr;
+{
+  char *name;
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_PTR:
+      f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      break;
+
+    case TYPE_CODE_FUNC:
+      f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      break;
+
+    case TYPE_CODE_ARRAY:
+      f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+      /* These types need no prefix.  They are listed here so that
+	 gcc -Wall will reveal any types that haven't been handled.  */
+      break;
+    }
+}
+
+static void
+f_type_print_args (type, stream)
+     struct type *type;
+     FILE *stream;
+{
+  int i;
+  struct type **args;
+
+  fprintf_filtered (stream, "(");
+  args = TYPE_ARG_TYPES (type);
+  if (args != NULL)
+    {
+      if (args[1] == NULL)
+	{
+	  fprintf_filtered (stream, "...");
+	}
+      else
+	{
+	  for (i = 1; args[i] != NULL && args[i]->code != TYPE_CODE_VOID; i++)
+	    {
+	      f_print_type (args[i], "", stream, -1, 0);
+	      if (args[i+1] == NULL)
+		fprintf_filtered (stream, "...");
+	      else if (args[i+1]->code != TYPE_CODE_VOID)
+		{
+		  fprintf_filtered (stream, ",");
+		  wrap_here ("    ");
+		}
+	    }
+	}
+    }
+  fprintf_filtered (stream, ")");
+}
+
+/* Print any array sizes, function arguments or close parentheses
+   needed after the variable name (to describe its type).
+   Args work like c_type_print_varspec_prefix.  */
+
+static void
+f_type_print_varspec_suffix (type, stream, show, passed_a_ptr, demangled_args)
+     struct type *type;
+     FILE *stream;
+     int show;
+     int passed_a_ptr;
+     int demangled_args;
+{
+  CORE_ADDR current_frame_addr = 0;
+  int upper_bound,lower_bound;
+  int lower_bound_was_default = 0;
+  static int arrayprint_recurse_level = 0;
+  int retcode;
+
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      arrayprint_recurse_level++;
+
+      if (arrayprint_recurse_level == 1)
+	fprintf_filtered(stream,"(");
+      else
+	fprintf_filtered(stream,",");
+
+      retcode = f77_get_dynamic_lowerbound (type,&lower_bound);
+
+      lower_bound_was_default = 0;
+
+      if (retcode == BOUND_FETCH_ERROR)
+	fprintf_filtered (stream,"???");
+      else
+	if (lower_bound == 1) /* The default */
+	  lower_bound_was_default = 1;
+	else
+	  fprintf_filtered (stream,"%d",lower_bound);
+
+      if (lower_bound_was_default)
+	lower_bound_was_default = 0;
+      else
+	fprintf_filtered(stream,":");
+
+      /* Make sure that, if we have an assumed size array, we
+	 print out a warning and print the upperbound as '*' */
+
+      if (TYPE_ARRAY_UPPER_BOUND_TYPE(type) == BOUND_CANNOT_BE_DETERMINED)
+	fprintf_filtered (stream, "*");
+       else
+	 {
+	   retcode = f77_get_dynamic_upperbound(type,&upper_bound);
+
+	   if (retcode == BOUND_FETCH_ERROR)
+	     fprintf_filtered(stream,"???");
+	   else
+	     fprintf_filtered(stream,"%d",upper_bound);
+	 }
+
+      f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      if (arrayprint_recurse_level == 1)
+	fprintf_filtered (stream, ")");
+      arrayprint_recurse_level--;
+      break;
+
+    case TYPE_CODE_PTR:
+    case TYPE_CODE_REF:
+      f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      fprintf_filtered(stream,")");
+      break;
+
+    case TYPE_CODE_FUNC:
+      f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+				 passed_a_ptr, 0);
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+
+      fprintf_filtered (stream, "()");
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_LITERAL_STRING:
+    case TYPE_CODE_STRING:
+      /* These types do not need a suffix.  They are listed so that
+	 gcc -Wall will report types that may not have been considered.  */
+      break;
+    }
+}
+
+
+void
+print_equivalent_f77_float_type (type, stream)
+     struct type *type;
+     FILE *stream;
+{
+  /* Override type name "float" and make it the
+     appropriate real. XLC stupidly outputs -12 as a type
+     for real when it really should be outputting -18 */
+
+  switch (TYPE_LENGTH (type))
+    {
+    case 4:
+      fprintf_filtered (stream, "real*4");
+      break;
+
+    case 8:
+      fprintf_filtered(stream,"real*8");
+      break;
+    }
+}
+
+/* Print the name of the type (or the ultimate pointer target,
+   function value or array element), or the description of a
+   structure or union.
+
+   SHOW nonzero means don't print this type as just its name;
+   show its real definition even if it has a name.
+   SHOW zero means print just typename or struct tag if there is one
+   SHOW negative means abbreviate structure elements.
+   SHOW is decremented for printing of structure elements.
+
+   LEVEL is the depth to indent by.
+   We increase it for some recursive calls.  */
+
+void
+f_type_print_base (type, stream, show, level)
+     struct type *type;
+     FILE *stream;
+     int show;
+     int level;
+{
+  char *name;
+  register int i;
+  register int len;
+  register int lastval;
+  char *mangled_name;
+  char *demangled_name;
+  enum {s_none, s_public, s_private, s_protected} section_type;
+  int retcode,upper_bound;
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered ("<type unknown>", stream);
+      return;
+    }
+
+  /* When SHOW is zero or less, and there is a valid type name, then always
+     just print the type name directly from the type. */
+
+  if ((show <= 0) && (TYPE_NAME (type) != NULL))
+    {
+      /* Damn builtin types on RS6000!  They call a float "float"
+         so we gotta translate to appropriate F77'isms */
+
+      if (TYPE_CODE (type) == TYPE_CODE_FLT)
+	print_equivalent_f77_float_type (type, stream);
+      else
+	fputs_filtered (TYPE_NAME (type), stream);
+      return;
+    }
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
+      break;
+
+    case TYPE_CODE_FUNC:
+      f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
+      break;
+
+   case TYPE_CODE_PTR:
+      fprintf_filtered (stream, "PTR TO -> ( ");
+      f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "VOID");
+      break;
+
+    case TYPE_CODE_UNDEF:
+      fprintf_filtered (stream, "struct <unknown>");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, "<unknown type>");
+      break;
+
+    case TYPE_CODE_RANGE:
+      /* This should not occur */
+      fprintf_filtered (stream, "<range type>");
+      break;
+
+    case TYPE_CODE_CHAR:
+      /* Override name "char" and make it "character" */
+      fprintf_filtered (stream, "character");
+      break;
+
+    case TYPE_CODE_INT:
+      /* There may be some character types that attempt to come
+         through as TYPE_CODE_INT since dbxstclass.h is so
+         C-oriented, we must change these to "character" from "char".  */
+
+      if (STREQ(TYPE_NAME(type),"char"))
+	fprintf_filtered (stream,"character");
+      else
+	goto default_case;
+      break;
+
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_LITERAL_COMPLEX:
+      fprintf_filtered (stream,"complex*");
+      fprintf_filtered (stream,"%d",TYPE_LENGTH(type));
+      break;
+
+    case TYPE_CODE_FLT:
+      print_equivalent_f77_float_type(type,stream);
+      break;
+
+    case TYPE_CODE_LITERAL_STRING:
+       fprintf_filtered (stream, "character*%d",
+			 TYPE_ARRAY_UPPER_BOUND_VALUE (type));
+       break;
+
+    case TYPE_CODE_STRING:
+      /* Strings may have dynamic upperbounds (lengths) like arrays */
+
+      if (TYPE_ARRAY_UPPER_BOUND_TYPE (type) == BOUND_CANNOT_BE_DETERMINED)
+	fprintf_filtered("character*(*)");
+      else
+	{
+	  retcode = f77_get_dynamic_upperbound(type,&upper_bound);
+
+	  if (retcode == BOUND_FETCH_ERROR)
+	    fprintf_filtered(stream,"character*???");
+	  else
+	    fprintf_filtered(stream,"character*%d",upper_bound);
+	}
+      break;
+
+    default_case:
+    default:
+      /* Handle types not explicitly handled by the other cases,
+	 such as fundamental types.  For these, just print whatever
+	 the type name is, as recorded in the type itself.  If there
+	 is no type name, then complain. */
+      if (TYPE_NAME (type) != NULL)
+	fputs_filtered (TYPE_NAME (type), stream);
+      else
+	error ("Invalid type code (%d) in symbol table.", TYPE_CODE (type));
+      break;
+    }
+}
diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c
new file mode 100644
index 0000000..0e0cdbc
--- /dev/null
+++ b/gdb/f-valprint.c
@@ -0,0 +1,889 @@
+/* Support for printing Fortran values for GDB, the GNU debugger.
+   Copyright 1993, 1994 Free Software Foundation, Inc.
+   Contributed by Motorola.  Adapted from the C definitions by Farooq Butt
+   (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
+
+This file is part of GDB.
+
+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., 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+#include "defs.h"
+#include "symtab.h"
+#include "gdbtypes.h"
+#include "expression.h"
+#include "value.h"
+#include "demangle.h"
+#include "valprint.h"
+#include "language.h"
+#include "f-lang.h" 
+#include "frame.h"
+
+extern struct obstack dont_print_obstack;
+
+extern unsigned int print_max; /* No of array elements to print */ 
+
+int f77_array_offset_tbl[MAX_FORTRAN_DIMS+1][2];
+
+/* Array which holds offsets to be applied to get a row's elements
+   for a given array. Array also holds the size of each subarray.  */
+
+/* The following macro gives us the size of the nth dimension, Where 
+   n is 1 based. */ 
+
+#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
+
+/* The following gives us the offset for row n where n is 1-based. */ 
+
+#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
+
+int 
+f77_get_dynamic_lowerbound (type, lower_bound)
+     struct type *type;
+     int *lower_bound; 
+{
+  CORE_ADDR current_frame_addr;   
+  CORE_ADDR ptr_to_lower_bound; 
+  
+  switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
+    {
+    case BOUND_BY_VALUE_ON_STACK:
+      current_frame_addr = selected_frame->frame;
+      if (current_frame_addr > 0) 
+	{
+	  *lower_bound = 
+	    read_memory_integer (current_frame_addr + 
+				 TYPE_ARRAY_LOWER_BOUND_VALUE (type),4);
+	}
+      else
+	{
+	  *lower_bound = DEFAULT_LOWER_BOUND; 
+	  return BOUND_FETCH_ERROR; 
+	}
+      break; 
+      
+    case BOUND_SIMPLE:
+      *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
+      break; 
+      
+    case BOUND_CANNOT_BE_DETERMINED: 
+      error("Lower bound may not be '*' in F77"); 
+      break; 
+      
+    case BOUND_BY_REF_ON_STACK:
+      current_frame_addr = selected_frame->frame;
+      if (current_frame_addr > 0) 
+	{
+	  ptr_to_lower_bound = 
+	    read_memory_integer (current_frame_addr + 
+				 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
+				 4);
+	  *lower_bound = read_memory_integer(ptr_to_lower_bound); 
+	}
+      else
+	{
+	  *lower_bound = DEFAULT_LOWER_BOUND; 
+	  return BOUND_FETCH_ERROR; 
+	}
+      break; 
+      
+    case BOUND_BY_REF_IN_REG: 
+    case BOUND_BY_VALUE_IN_REG: 
+    default: 
+      error ("??? unhandled dynamic array bound type ???");
+      break; 
+    }
+  return BOUND_FETCH_OK;
+}
+
+int 
+f77_get_dynamic_upperbound (type, upper_bound)
+     struct type *type;
+     int *upper_bound;
+{
+  CORE_ADDR current_frame_addr = 0;
+  CORE_ADDR ptr_to_upper_bound; 
+  
+  switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
+    {
+    case BOUND_BY_VALUE_ON_STACK:
+      current_frame_addr = selected_frame->frame;
+      if (current_frame_addr > 0) 
+	{
+	  *upper_bound = 
+	    read_memory_integer (current_frame_addr + 
+				 TYPE_ARRAY_UPPER_BOUND_VALUE (type),4);
+	}
+      else
+	{
+	  *upper_bound = DEFAULT_UPPER_BOUND; 
+	  return BOUND_FETCH_ERROR; 
+	}
+      break; 
+      
+    case BOUND_SIMPLE:
+      *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
+      break; 
+      
+    case BOUND_CANNOT_BE_DETERMINED: 
+      /* we have an assumed size array on our hands. Assume that 
+	 upper_bound == lower_bound so that we show at least 
+	 1 element.If the user wants to see more elements, let 
+	 him manually ask for 'em and we'll subscript the 
+	 array and show him */
+      f77_get_dynamic_lowerbound (type, &upper_bound);
+      break; 
+      
+    case BOUND_BY_REF_ON_STACK:
+      current_frame_addr = selected_frame->frame;
+      if (current_frame_addr > 0) 
+	{
+	  ptr_to_upper_bound = 
+	    read_memory_integer (current_frame_addr + 
+				 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
+				 4);
+	  *upper_bound = read_memory_integer(ptr_to_upper_bound); 
+	}
+      else
+	{
+	  *upper_bound = DEFAULT_UPPER_BOUND; 
+	  return BOUND_FETCH_ERROR;
+	}
+      break; 
+      
+    case BOUND_BY_REF_IN_REG: 
+    case BOUND_BY_VALUE_IN_REG: 
+    default: 
+      error ("??? unhandled dynamic array bound type ???");
+      break; 
+    }
+  return BOUND_FETCH_OK;
+}
+
+/* Obtain F77 adjustable array dimensions */ 
+
+void
+f77_get_dynamic_length_of_aggregate (type)
+     struct type *type;
+{
+  int upper_bound = -1;
+  int lower_bound = 1; 
+  unsigned int current_total = 1;
+  int retcode; 
+  
+  /* Recursively go all the way down into a possibly 
+     multi-dimensional F77 array 
+     and get the bounds.  For simple arrays, this is pretty easy 
+     but when the bounds are dynamic, we must be very careful 
+     to add up all the lengths correctly.  Not doing this right 
+     will lead to horrendous-looking arrays in parameter lists.
+     
+     This function also works for strings which behave very 
+     similarly to arrays.  */ 
+  
+  if (TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
+      || TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
+    f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
+  
+  /* Recursion ends here, start setting up lengths.  */ 
+  retcode = f77_get_dynamic_lowerbound (type, &lower_bound); 
+  if (retcode == BOUND_FETCH_ERROR)
+    error ("Cannot obtain valid array lower bound"); 
+  
+  retcode = f77_get_dynamic_upperbound (type, &upper_bound); 
+  if (retcode == BOUND_FETCH_ERROR)
+    error ("Cannot obtain valid array upper bound"); 
+  
+  /* Patch in a valid length value. */ 
+  
+  TYPE_LENGTH (type) =
+    (upper_bound - lower_bound + 1) * TYPE_LENGTH (TYPE_TARGET_TYPE (type));
+}       
+
+/* Print a FORTRAN COMPLEX value of type TYPE, pointed to in GDB by VALADDR,
+   on STREAM.  which_complex indicates precision, which may be regular,
+   *16, or *32 */
+
+void
+f77_print_cmplx (valaddr, type, stream, which_complex)
+     char *valaddr;
+     struct type *type;
+     FILE *stream;
+     int which_complex;
+{
+  float *f1,*f2;
+  double *d1, *d2;
+  int i; 
+  
+  switch (which_complex)
+    {
+    case TARGET_COMPLEX_BIT:
+      f1 = (float *) valaddr;
+      f2 = (float *) (valaddr + sizeof(float));
+      fprintf_filtered (stream, "(%.7e,%.7e)", *f1, *f2);
+      break;
+      
+    case TARGET_DOUBLE_COMPLEX_BIT:
+      d1 = (double *) valaddr;
+      d2 = (double *) (valaddr + sizeof(double));
+      fprintf_filtered (stream, "(%.16e,%.16e)", *d1, *d2);
+      break;
+#if 0
+    case TARGET_EXT_COMPLEX_BIT:
+      fprintf_filtered (stream, "<complex*32 format unavailable, "
+		       "printing raw data>\n");
+      
+      fprintf_filtered (stream, "( [ "); 
+      
+      for (i = 0;i<4;i++)
+	fprintf_filtered (stream, "0x%x ",
+			 * ( (unsigned int *) valaddr+i));
+      
+      fprintf_filtered (stream, "],\n  [ "); 
+      
+      for (i=4;i<8;i++)
+	fprintf_filtered (stream, "0x%x ",
+			 * ((unsigned int *) valaddr+i));
+      
+      fprintf_filtered (stream, "] )");
+      
+      break;
+#endif
+    default:
+      fprintf_filtered (stream, "<cannot handle complex of this type>");
+      break;
+    }
+}
+
+/* Function that sets up the array offset,size table for the array 
+   type "type". */ 
+
+void 
+f77_create_arrayprint_offset_tbl (type, stream)
+     struct type *type;
+     FILE *stream;
+{
+  struct type *tmp_type;
+  int eltlen; 
+  int ndimen = 1;
+  int upper, lower, retcode; 
+  
+  tmp_type = type; 
+  
+  while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)) 
+    {
+      if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
+	fprintf_filtered (stream, "<assumed size array> "); 
+      
+      retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
+      if (retcode == BOUND_FETCH_ERROR)
+	error ("Cannot obtain dynamic upper bound"); 
+      
+      retcode = f77_get_dynamic_lowerbound(tmp_type,&lower); 
+      if (retcode == BOUND_FETCH_ERROR)
+	error("Cannot obtain dynamic lower bound"); 
+      
+      F77_DIM_SIZE (ndimen) = upper - lower + 1;
+      
+      if (ndimen == 1)
+	F77_DIM_OFFSET (ndimen) = 1;
+      else
+	F77_DIM_OFFSET (ndimen) = 
+	  F77_DIM_OFFSET (ndimen - 1) * F77_DIM_SIZE(ndimen - 1);
+      
+      tmp_type = TYPE_TARGET_TYPE (tmp_type);
+      ndimen++; 
+    }
+  
+  eltlen = TYPE_LENGTH (tmp_type); 
+
+  /* Now we multiply eltlen by all the offsets, so that later we 
+     can print out array elements correctly.  Up till now we 
+     know an offset to apply to get the item but we also 
+     have to know how much to add to get to the next item */
+  
+  tmp_type = type; 
+  ndimen = 1; 
+  
+  while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)) 
+    {
+      F77_DIM_OFFSET (ndimen) *= eltlen; 
+      ndimen++;
+      tmp_type = TYPE_TARGET_TYPE (tmp_type);
+    }
+}
+
+/* Actual function which prints out F77 arrays, Valaddr == address in 
+   the superior.  Address == the address in the inferior.  */
+
+void 
+f77_print_array_1 (nss, ndimensions, type, valaddr, address, 
+		   stream, format, deref_ref, recurse, pretty)
+     int nss;
+     int ndimensions; 
+     char *valaddr;
+     struct type *type;
+     CORE_ADDR address;
+     FILE *stream;
+     int format;
+     int deref_ref;
+     int recurse;
+     enum val_prettyprint pretty;
+{
+  int i;
+  
+  if (nss != ndimensions)
+    {
+      for (i = 0; i< F77_DIM_SIZE(nss); i++)
+	{
+	  fprintf_filtered (stream, "( ");
+	  f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
+			    valaddr + i * F77_DIM_OFFSET (nss),
+			    address + i * F77_DIM_OFFSET (nss), 
+			    stream, format, deref_ref, recurse, pretty, i);
+	  fprintf_filtered (stream, ") ");
+	}
+    }
+  else
+    {
+      for (i = 0; (i < F77_DIM_SIZE (nss) && i < print_max); i++)
+	{
+	  val_print (TYPE_TARGET_TYPE (type),
+		     valaddr + i * F77_DIM_OFFSET (ndimensions),
+		     address + i * F77_DIM_OFFSET (ndimensions),
+		     stream, format, deref_ref, recurse, pretty); 
+
+	  if (i != (F77_DIM_SIZE (nss) - 1))
+	    fprintf_filtered (stream, ", "); 
+	  
+	  if (i == print_max - 1)
+	    fprintf_filtered (stream, "...");
+	}
+    }
+}
+
+/* This function gets called to print an F77 array, we set up some 
+   stuff and then immediately call f77_print_array_1() */
+
+void 
+f77_print_array (type, valaddr, address, stream, format, deref_ref, recurse, 
+		 pretty)
+     struct type *type;
+     char *valaddr;
+     CORE_ADDR address;
+     FILE *stream;
+     int format;
+     int deref_ref;
+     int recurse;
+     enum val_prettyprint pretty;
+{
+  int array_size_array[MAX_FORTRAN_DIMS+1]; 
+  int ndimensions; 
+  
+  ndimensions = calc_f77_array_dims (type); 
+  
+  if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
+    error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
+	   ndimensions, MAX_FORTRAN_DIMS);
+  
+  /* Since F77 arrays are stored column-major, we set up an 
+     offset table to get at the various row's elements. The 
+     offset table contains entries for both offset and subarray size. */ 
+  
+  f77_create_arrayprint_offset_tbl (type, stream); 
+  
+  f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format, 
+                     deref_ref, recurse, pretty);
+}
+
+
+/* Print data of type TYPE located at VALADDR (within GDB), which came from
+   the inferior at address ADDRESS, onto stdio stream STREAM according to
+   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
+   target byte order.
+   
+   If the data are a string pointer, returns the number of string characters
+   printed.
+   
+   If DEREF_REF is nonzero, then dereference references, otherwise just print
+   them like pointers.
+   
+   The PRETTY parameter controls prettyprinting.  */
+
+int
+f_val_print (type, valaddr, address, stream, format, deref_ref, recurse,
+	     pretty)
+     struct type *type;
+     char *valaddr;
+     CORE_ADDR address;
+     FILE *stream;
+     int format;
+     int deref_ref;
+     int recurse;
+     enum val_prettyprint pretty;
+{
+  register unsigned int i = 0;		/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  LONGEST val;
+  struct internalvar *ivar; 
+  char *localstr; 
+  unsigned char c;
+  CORE_ADDR addr;
+  
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_LITERAL_STRING: 
+      /* It is trivial to print out F77 strings allocated in the 
+	 superior process. The address field is actually a 
+	 pointer to the bytes of the literal. For an internalvar,
+	 valaddr points to a ptr. which points to 
+	 VALUE_LITERAL_DATA(value->internalvar->value)
+	 and for straight literals (i.e. of the form 'hello world'), 
+	 valaddr points a ptr to VALUE_LITERAL_DATA(value). */
+      
+      /* First deref. valaddr  */ 
+      
+      addr = * (CORE_ADDR *) valaddr; 
+      
+      if (addr)
+	{
+	  len = TYPE_LENGTH (type); 
+	  localstr = alloca (len + 1);
+	  strncpy (localstr, addr, len);
+	  localstr[len] = '\0'; 
+	  fprintf_filtered (stream, "'%s'", localstr);
+	}
+      else
+	fprintf_filtered (stream, "Unable to print literal F77 string");
+      break; 
+      
+      /* Strings are a little bit funny. They can be viewed as 
+	 monolithic arrays that are dealt with as atomic data 
+	 items. As such they are the only atomic data items whose 
+	 contents are not located in the superior process. Instead 
+	 instead of having the actual data, they contain pointers 
+	 to addresses in the inferior where data is located.  Thus 
+	 instead of using valaddr, we use address. */ 
+      
+    case TYPE_CODE_STRING: 
+      f77_get_dynamic_length_of_aggregate (type);
+      val_print_string (address, TYPE_LENGTH (type), stream);
+      break;
+      
+    case TYPE_CODE_ARRAY:
+      fprintf_filtered (stream, "("); 
+      f77_print_array (type, valaddr, address, stream, format, 
+		       deref_ref, recurse, pretty); 
+      fprintf_filtered (stream, ")");
+      break;
+#if 0
+      /* Array of unspecified length: treat like pointer to first elt.  */
+      valaddr = (char *) &address;
+      /* FALL THROUGH */
+#endif 
+    case TYPE_CODE_PTR:
+      if (format && format != 's')
+	{
+	  print_scalar_formatted (valaddr, type, format, 0, stream);
+	  break;
+	}
+      else
+	{
+	  addr = unpack_pointer (type, valaddr);
+	  elttype = TYPE_TARGET_TYPE (type);
+	  
+	  if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+	    {
+	      /* Try to print what function it points to.  */
+	      print_address_demangle (addr, stream, demangle);
+	      /* Return value is irrelevant except for string pointers.  */
+	      return 0;
+	    }
+	  
+	  if (addressprint && format != 's')
+	    fprintf_filtered (stream, "0x%x", addr);
+	  
+	  /* For a pointer to char or unsigned char, also print the string
+	     pointed to, unless pointer is null.  */
+	  if (TYPE_LENGTH (elttype) == 1
+	      && TYPE_CODE (elttype) == TYPE_CODE_INT
+	      && (format == 0 || format == 's')
+	      && addr != 0)
+	    i = val_print_string (addr, 0, stream);
+	  
+	  /* Return number of characters printed, plus one for the
+	     terminating null if we have "reached the end".  */
+	  return (i + (print_max && i != print_max));
+	}
+      break;
+      
+    case TYPE_CODE_FUNC:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr, type, format, 0, stream);
+	  break;
+	}
+      /* FIXME, we should consider, at least for ANSI C language, eliminating
+	 the distinction made between FUNCs and POINTERs to FUNCs.  */
+      fprintf_filtered (stream, "{");
+      type_print (type, "", stream, -1);
+      fprintf_filtered (stream, "} ");
+      /* Try to print what function it points to, and its address.  */
+      print_address_demangle (address, stream, demangle);
+      break;
+      
+    case TYPE_CODE_INT:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr, type, format, 0, stream);
+      else
+	{
+	  val_print_type_code_int (type, valaddr, stream);
+	  /* C and C++ has no single byte int type, char is used instead.
+	     Since we don't know whether the value is really intended to
+	     be used as an integer or a character, print the character
+	     equivalent as well. */
+	  if (TYPE_LENGTH (type) == 1)
+	    {
+	      fputs_filtered (" ", stream);
+	      LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
+			     stream);
+	    }
+	}
+      break;
+      
+    case TYPE_CODE_FLT:
+      if (format)
+	print_scalar_formatted (valaddr, type, format, 0, stream);
+      else
+	print_floating (valaddr, type, stream);
+      break;
+      
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "VOID");
+      break;
+      
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, "<error type>");
+      break;
+      
+    case TYPE_CODE_RANGE:
+      /* FIXME, we should not ever have to print one of these yet.  */
+      fprintf_filtered (stream, "<range type>");
+      break;
+      
+    case TYPE_CODE_BOOL:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr, type, format, 0, stream);
+      else
+	{
+          val = 0; 
+          switch (TYPE_LENGTH(type))
+	    {
+	    case 1:
+	      val = unpack_long (builtin_type_f_logical_s1, valaddr);
+	      break ; 
+	      
+	    case 2: 
+	      val = unpack_long (builtin_type_f_logical_s2, valaddr);
+	      break ; 
+	      
+	    case 4: 
+	      val = unpack_long (builtin_type_f_logical, valaddr);
+	      break ; 
+	      
+	    default:
+	      error ("Logicals of length %d bytes not supported",
+		     TYPE_LENGTH (type));
+	      
+	    }
+	  
+          if (val == 0) 
+	    fprintf_filtered (stream, ".FALSE.");
+          else 
+	    if (val == 1) 
+	      fprintf_filtered (stream, ".TRUE.");
+	    else
+	      /* Not a legitimate logical type, print as an integer.  */
+	      {
+		/* Bash the type code temporarily.  */
+		TYPE_CODE (type) = TYPE_CODE_INT;
+		f_val_print (type, valaddr, address, stream, format, 
+			     deref_ref, recurse, pretty); 
+		/* Restore the type code so later uses work as intended. */
+		TYPE_CODE (type) = TYPE_CODE_BOOL; 
+	      }
+	}
+      break;
+      
+    case TYPE_CODE_LITERAL_COMPLEX:
+      /* We know that the literal complex is stored in the superior 
+	 process not the inferior and that it is 16 bytes long. 
+	 Just like the case above with a literal array, the
+	 bytes for the the literal complex number are stored   
+	 at the address pointed to by valaddr */ 
+      
+      if (TYPE_LENGTH(type) == 32)
+	error("Cannot currently print out complex*32 literals");
+      
+      /* First deref. valaddr  */ 
+      
+      addr = * (CORE_ADDR *) valaddr; 
+      
+      if (addr)
+	{
+	  fprintf_filtered (stream, "("); 
+	  
+	  if (TYPE_LENGTH(type) == 16) 
+	    { 
+	      fprintf_filtered (stream, "%.16f", * (double *) addr); 
+	      fprintf_filtered (stream, ", %.16f", * (double *) 
+				(addr + sizeof(double)));
+	    }
+	  else
+	    {
+	      fprintf_filtered (stream, "%.8f", * (float *) addr); 
+	      fprintf_filtered (stream, ", %.8f", * (float *) 
+				(addr + sizeof(float)));
+	    }
+	  fprintf_filtered (stream, ") ");             
+	}
+      else
+	fprintf_filtered (stream, "Unable to print literal F77 array");
+      break; 
+      
+    case TYPE_CODE_COMPLEX:
+      switch (TYPE_LENGTH (type))
+	{
+	case 8:
+	  f77_print_cmplx (valaddr, type, stream, TARGET_COMPLEX_BIT);
+	  break;
+	  
+	case 16: 
+	  f77_print_cmplx(valaddr, type, stream, TARGET_DOUBLE_COMPLEX_BIT);
+	  break; 
+#if 0
+	case 32:
+	  f77_print_cmplx(valaddr, type, stream, TARGET_EXT_COMPLEX_BIT);
+	  break; 
+#endif
+	default:
+	  error ("Cannot print out complex*%d variables", TYPE_LENGTH(type)); 
+	}
+      break;
+      
+    case TYPE_CODE_UNDEF:
+      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
+	 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
+	 and no complete type for struct foo in that file.  */
+      fprintf_filtered (stream, "<incomplete type>");
+      break;
+      
+    default:
+      error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type));
+    }
+  fflush (stream);
+  return 0;
+}
+
+void
+list_all_visible_commons (funname)
+     char *funname;
+{
+  SAVED_F77_COMMON_PTR  tmp;
+  
+  tmp = head_common_list;
+  
+  printf_filtered ("All COMMON blocks visible at this level:\n\n");
+  
+  while (tmp != NULL)
+    {
+      if (STREQ(tmp->owning_function,funname))
+	printf_filtered ("%s\n", tmp->name); 
+      
+      tmp = tmp->next;
+    }
+}
+
+/* This function is used to print out the values in a given COMMON 
+   block. It will always use the most local common block of the 
+   given name */ 
+
+static void 
+info_common_command (comname, from_tty)
+     char *comname;
+     int from_tty;
+{
+  SAVED_F77_COMMON_PTR  the_common; 
+  COMMON_ENTRY_PTR entry; 
+  struct frame_info *fi;
+  register char *funname = 0;
+  struct symbol *func;
+  char *cmd; 
+  
+  /* We have been told to display the contents of F77 COMMON 
+     block supposedly visible in this function.  Let us 
+     first make sure that it is visible and if so, let 
+     us display its contents */ 
+  
+  fi = selected_frame; 
+  
+  if (fi == NULL)
+    error ("No frame selected"); 
+  
+  /* The following is generally ripped off from stack.c's routine 
+     print_frame_info() */ 
+  
+  func = find_pc_function (fi->pc);
+  if (func)
+    {
+      /* In certain pathological cases, the symtabs give the wrong
+	 function (when we are in the first function in a file which
+	 is compiled without debugging symbols, the previous function
+	 is compiled with debugging symbols, and the "foo.o" symbol
+	 that is supposed to tell us where the file with debugging symbols
+	 ends has been truncated by ar because it is longer than 15
+	 characters).
+	 
+	 So look in the minimal symbol tables as well, and if it comes
+	 up with a larger address for the function use that instead.
+	 I don't think this can ever cause any problems; there shouldn't
+	 be any minimal symbols in the middle of a function.
+	 FIXME:  (Not necessarily true.  What about text labels) */
+      
+      struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
+      
+      if (msymbol != NULL
+	  && (SYMBOL_VALUE_ADDRESS (msymbol) 
+	      > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
+	funname = SYMBOL_NAME (msymbol);
+      else
+	funname = SYMBOL_NAME (func);
+    }
+  else
+    {
+      register struct minimal_symbol *msymbol =
+	lookup_minimal_symbol_by_pc (fi->pc);
+      
+      if (msymbol != NULL)
+	funname = SYMBOL_NAME (msymbol);
+    }
+  
+  /* If comnname is NULL, we assume the user wishes to see the 
+     which COMMON blocks are visible here and then return */ 
+  
+  if (strlen (comname) == 0) 
+    {
+      list_all_visible_commons (funname);
+      return; 
+    }
+  
+  the_common = find_common_for_function (comname,funname); 
+  
+  if (the_common)
+    {
+      if (STREQ(comname,BLANK_COMMON_NAME_LOCAL))
+	printf_filtered ("Contents of blank COMMON block:\n");
+      else 
+	printf_filtered ("Contents of F77 COMMON block '%s':\n",comname); 
+      
+      printf_filtered ("\n"); 
+      entry = the_common->entries; 
+      
+      while (entry != NULL)
+	{
+	  printf_filtered ("%s = ",SYMBOL_NAME(entry->symbol)); 
+	  print_variable_value (entry->symbol,fi,stdout); 
+	  printf_filtered ("\n"); 
+	  entry = entry->next; 
+	}
+    }
+  else 
+    printf_filtered ("Cannot locate the common block %s in function '%s'\n",
+		    comname, funname);
+}
+
+/* This function is used to determine whether there is a
+   F77 common block visible at the current scope called 'comname'. */ 
+
+int
+there_is_a_visible_common_named (comname)
+     char *comname;
+{
+  SAVED_F77_COMMON_PTR  the_common; 
+  COMMON_ENTRY_PTR entry; 
+  struct frame_info *fi;
+  register char *funname = 0;
+  struct symbol *func;
+  
+  if (comname == NULL)
+    error ("Cannot deal with NULL common name!"); 
+  
+  fi = selected_frame; 
+  
+  if (fi == NULL)
+    error ("No frame selected"); 
+  
+  /* The following is generally ripped off from stack.c's routine 
+     print_frame_info() */ 
+  
+  func = find_pc_function (fi->pc);
+  if (func)
+    {
+      /* In certain pathological cases, the symtabs give the wrong
+	 function (when we are in the first function in a file which
+	 is compiled without debugging symbols, the previous function
+	 is compiled with debugging symbols, and the "foo.o" symbol
+	 that is supposed to tell us where the file with debugging symbols
+	 ends has been truncated by ar because it is longer than 15
+	 characters).
+	 
+	 So look in the minimal symbol tables as well, and if it comes
+	 up with a larger address for the function use that instead.
+	 I don't think this can ever cause any problems; there shouldn't
+	 be any minimal symbols in the middle of a function.
+	 FIXME:  (Not necessarily true.  What about text labels) */
+      
+      struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
+      
+      if (msymbol != NULL
+	  && (SYMBOL_VALUE_ADDRESS (msymbol) 
+	      > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
+	funname = SYMBOL_NAME (msymbol);
+      else
+	funname = SYMBOL_NAME (func);
+    }
+  else
+    {
+      register struct minimal_symbol *msymbol = 
+	lookup_minimal_symbol_by_pc (fi->pc);
+      
+      if (msymbol != NULL)
+	funname = SYMBOL_NAME (msymbol);
+    }
+  
+  the_common = find_common_for_function (comname, funname); 
+  
+  return (the_common ? 1 : 0);
+}
+
+void
+_initialize_f_valprint ()
+{
+  add_info ("common", info_common_command,
+	    "Print out the values contained in a Fortran COMMON block.");
+}
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index b891237..a87d9a1 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -487,6 +487,86 @@ create_set_type (result_type, domain_type)
   return (result_type);
 }
 
+/* Create an  F77 literal complex type composed of the two types we are 
+   given as arguments.  */
+
+struct type * 
+f77_create_literal_complex_type (type_arg1, type_arg2)
+     struct type *type_arg1;
+     struct type *type_arg2;
+{
+  struct type *result; 
+
+  /* First make sure that the 2 components of the complex 
+     number both have the same type */
+
+  if (TYPE_CODE (type_arg1) != TYPE_CODE (type_arg2))
+    error ("Both components of a F77 complex number must have the same type!");
+   
+  result = alloc_type (TYPE_OBJFILE (type_arg1));
+   
+  TYPE_CODE (result) = TYPE_CODE_LITERAL_COMPLEX;
+  TYPE_LENGTH (result) = TYPE_LENGTH(type_arg1) * 2;
+
+  return result;
+}
+
+/* Create a F77 LITERAL string type supplied by the user from the keyboard.
+
+   Elements will be of type ELEMENT_TYPE, the indices will be of type
+   RANGE_TYPE.
+
+   FIXME:  Maybe we should check the TYPE_CODE of RESULT_TYPE to make
+   sure it is TYPE_CODE_UNDEF before we bash it into an array type? 
+
+   This is a total clone of create_array_type() except that there are 
+   a few simplyfing assumptions (e.g all bound types are simple).  */ 
+
+struct type *
+f77_create_literal_string_type (result_type, range_type)
+     struct type *result_type;
+     struct type *range_type;
+{
+  int low_bound;
+  int high_bound;
+
+  if (TYPE_CODE (range_type) != TYPE_CODE_RANGE)
+    {
+      /* FIXME:  We only handle range types at the moment.  Complain and
+	 create a dummy range type to use. */
+      warning ("internal error:  array index type must be a range type");
+      range_type = lookup_fundamental_type (TYPE_OBJFILE (range_type),
+					    FT_INTEGER);
+      range_type = create_range_type ((struct type *) NULL, range_type, 0, 0);
+    }
+  if (result_type == NULL)
+    result_type = alloc_type (TYPE_OBJFILE (range_type));
+  TYPE_CODE (result_type) = TYPE_CODE_LITERAL_STRING;
+  TYPE_TARGET_TYPE (result_type) = builtin_type_f_character; 
+  low_bound = TYPE_FIELD_BITPOS (range_type, 0);
+  high_bound = TYPE_FIELD_BITPOS (range_type, 1);
+
+  /* Safely can assume that all bound types are simple */ 
+
+  TYPE_LENGTH (result_type) =
+    TYPE_LENGTH (builtin_type_f_character) * (high_bound - low_bound + 1);
+
+  TYPE_NFIELDS (result_type) = 1;
+  TYPE_FIELDS (result_type) =
+    (struct field *) TYPE_ALLOC (result_type, sizeof (struct field));
+  memset (TYPE_FIELDS (result_type), 0, sizeof (struct field));
+  TYPE_FIELD_TYPE (result_type, 0) = range_type;
+  TYPE_VPTR_FIELDNO (result_type) = -1;
+
+  /* Remember that all literal strings in F77 are of the 
+     character*N type. */
+
+  TYPE_ARRAY_LOWER_BOUND_TYPE (result_type) = BOUND_SIMPLE; 
+  TYPE_ARRAY_UPPER_BOUND_TYPE (result_type) = BOUND_SIMPLE; 
+
+  return result_type;
+}
+
 /* Smash TYPE to be a type of members of DOMAIN with type TO_TYPE. 
    A MEMBER is a wierd thing -- it amounts to a typed offset into
    a struct, e.g. "an int at offset 8".  A MEMBER TYPE doesn't
diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
index 62fe1ab..918e1a6 100644
--- a/gdb/gdbtypes.h
+++ b/gdb/gdbtypes.h
@@ -80,9 +80,7 @@ enum type_code
   TYPE_CODE_FUNC,		/* Function type */
   TYPE_CODE_INT,		/* Integer type */
 
-  /* Floating type.  This is *NOT* a complex type.  Complex types, when
-     we have them, will have their own type code (or TYPE_CODE_ERROR if
-     we can parse a complex type but not manipulate it).  There are parts
+  /* Floating type.  This is *NOT* a complex type.  Beware, there are parts
      of GDB which bogusly assume that TYPE_CODE_FLT can mean complex.  */
   TYPE_CODE_FLT,
 
@@ -119,7 +117,12 @@ enum type_code
 
   /* Boolean type.  0 is false, 1 is true, and other values are non-boolean
      (e.g. FORTRAN "logical" used as unsigned int).  */
-  TYPE_CODE_BOOL
+  TYPE_CODE_BOOL,
+
+  /* Fortran */
+  TYPE_CODE_COMPLEX,		/* Complex float */
+  TYPE_CODE_LITERAL_COMPLEX,	/* */
+  TYPE_CODE_LITERAL_STRING	/* */
 };
 
 /* For now allow source to use TYPE_CODE_CLASS for C++ classes, as an
@@ -182,6 +185,17 @@ struct type
 
   unsigned length;
 
+  /* FIXME, these should probably be restricted to a Fortran-specific
+     field in some fashion.  */
+#define BOUND_CANNOT_BE_DETERMINED   5
+#define BOUND_BY_REF_ON_STACK        4
+#define BOUND_BY_VALUE_ON_STACK      3
+#define BOUND_BY_REF_IN_REG          2
+#define BOUND_BY_VALUE_IN_REG        1
+#define BOUND_SIMPLE                 0
+  int upper_bound_type;
+  int lower_bound_type;
+
   /* Every type is now associated with a particular objfile, and the
      type is allocated on the type_obstack for that objfile.  One problem
      however, is that there are times when gdb allocates new types while
@@ -486,6 +500,17 @@ allocate_cplus_struct_type PARAMS ((struct type *));
    by force_to_range_type. */
 #define TYPE_DUMMY_RANGE(type) ((type)->vptr_fieldno)
 
+/* Moto-specific stuff for FORTRAN arrays */
+
+#define TYPE_ARRAY_UPPER_BOUND_TYPE(thistype) (thistype)->upper_bound_type
+#define TYPE_ARRAY_LOWER_BOUND_TYPE(thistype) (thistype)->lower_bound_type
+
+#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
+   (TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),1))
+
+#define TYPE_ARRAY_LOWER_BOUND_VALUE(arraytype) \
+   (TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),0))
+
 /* C++ */
 
 #define TYPE_VPTR_BASETYPE(thistype) (thistype)->vptr_basetype
@@ -605,6 +630,23 @@ extern struct type *builtin_type_chill_long;
 extern struct type *builtin_type_chill_ulong;
 extern struct type *builtin_type_chill_real;
 
+/* Fortran (F77) types */
+
+extern struct type *builtin_type_f_character;
+extern struct type *builtin_type_f_integer;
+extern struct type *builtin_type_f_logical;
+extern struct type *builtin_type_f_logical_s1;
+extern struct type *builtin_type_f_logical_s2;
+extern struct type *builtin_type_f_integer; 
+extern struct type *builtin_type_f_integer_s2;
+extern struct type *builtin_type_f_real;
+extern struct type *builtin_type_f_real_s8;
+extern struct type *builtin_type_f_real_s16;
+extern struct type *builtin_type_f_complex_s8;
+extern struct type *builtin_type_f_complex_s16;
+extern struct type *builtin_type_f_complex_s32;
+extern struct type *builtin_type_f_void;
+
 /* Maximum and minimum values of built-in types */
 
 #define	MAX_OF_TYPE(t)	\
diff --git a/gdb/language.c b/gdb/language.c
index c06decb..f27512c 100644
--- a/gdb/language.c
+++ b/gdb/language.c
@@ -166,6 +166,7 @@ set_language_command (ignore, from_tty)
     printf_unfiltered ("c                Use the C language\n");
     printf_unfiltered ("c++              Use the C++ language\n");
     printf_unfiltered ("chill            Use the Chill language\n");
+    printf_unfiltered ("fortran          Use the Fortran language\n");
     printf_unfiltered ("modula-2         Use the Modula-2 language\n");
     /* Restore the silly string. */
     set_language(current_language->la_language);
diff --git a/gdb/language.h b/gdb/language.h
index e9a2eff..7ab04db 100644
--- a/gdb/language.h
+++ b/gdb/language.h
@@ -34,6 +34,9 @@ struct objfile;
 #define	_LANG_c
 #define	_LANG_m2
 #define	_LANG_chill
+#define _LANG_fortran
+
+#define MAX_FORTRAN_DIMS  7   /* Maximum number of F77 array dims */ 
 
 /* range_mode ==
    range_mode_auto:   range_check set automatically to default of language.
diff --git a/gdb/parse.c b/gdb/parse.c
index 8c387c8..a16be75 100644
--- a/gdb/parse.c
+++ b/gdb/parse.c
@@ -466,7 +466,18 @@ length_of_subexp (expr, endpos)
       oplen = 3;
       break;
 
+    case OP_F77_LITERAL_COMPLEX:
+      oplen = 1; 
+      args = 2;
+      break; 
+
+    case OP_F77_SUBSTR:
+      oplen = 1; 
+      args = 2;
+      break; 
+
     case OP_FUNCALL:
+    case OP_F77_UNDETERMINED_ARGLIST:
       oplen = 3;
       args = 1 + longest_to_int (expr->elts[endpos - 2].longconst);
       break;
@@ -524,7 +535,9 @@ length_of_subexp (expr, endpos)
 
       /* Modula-2 */
    case MULTI_SUBSCRIPT:
-      oplen=3;
+      /* Fortran */
+   case MULTI_F77_SUBSCRIPT:
+      oplen = 3;
       args = 1 + longest_to_int (expr->elts[endpos- 2].longconst);
       break;
 
@@ -595,7 +608,18 @@ prefixify_subexp (inexpr, outexpr, inend, outbeg)
       oplen = 3;
       break;
 
+    case OP_F77_LITERAL_COMPLEX:
+      oplen = 1; 
+      args = 2; 
+      break; 
+
+   case OP_F77_SUBSTR:
+      oplen = 1; 
+      args = 2; 
+      break; 
+
     case OP_FUNCALL:
+    case OP_F77_UNDETERMINED_ARGLIST:
       oplen = 3;
       args = 1 + longest_to_int (inexpr->elts[inend - 2].longconst);
       break;
@@ -657,7 +681,9 @@ prefixify_subexp (inexpr, outexpr, inend, outbeg)
 
       /* Modula-2 */
    case MULTI_SUBSCRIPT:
-      oplen=3;
+      /* Fortran */
+   case MULTI_F77_SUBSCRIPT:
+      oplen = 3;
       args = 1 + longest_to_int (inexpr->elts[inend - 2].longconst);
       break;
 
diff --git a/gdb/valops.c b/gdb/valops.c
index 24f2c78..06f3527 100644
--- a/gdb/valops.c
+++ b/gdb/valops.c
@@ -33,31 +33,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
 
 /* Local functions.  */
 
-static int
-typecmp PARAMS ((int staticp, struct type *t1[], value t2[]));
-
-static CORE_ADDR
-find_function_addr PARAMS ((value, struct type **));
+static int typecmp PARAMS ((int staticp, struct type *t1[], value_ptr t2[]));
 
-static CORE_ADDR
-value_push PARAMS ((CORE_ADDR, value));
+static CORE_ADDR find_function_addr PARAMS ((value_ptr, struct type **));
 
-static CORE_ADDR
-value_arg_push PARAMS ((CORE_ADDR, value));
+static CORE_ADDR value_push PARAMS ((CORE_ADDR, value_ptr));
 
-static value
-search_struct_field PARAMS ((char *, value, int, struct type *, int));
+static CORE_ADDR value_arg_push PARAMS ((CORE_ADDR, value_ptr));
 
-static value
-search_struct_method PARAMS ((char *, value *, value *, int, int *,
-			      struct type *));
+static value_ptr search_struct_field PARAMS ((char *, value_ptr, int,
+					      struct type *, int));
 
-static int
-check_field_in PARAMS ((struct type *, const char *));
+static value_ptr search_struct_method PARAMS ((char *, value_ptr *,
+					       value_ptr *,
+					       int, int *, struct type *));
 
-static CORE_ADDR
-allocate_space_in_inferior PARAMS ((int));
+static int check_field_in PARAMS ((struct type *, const char *));
 
+static CORE_ADDR allocate_space_in_inferior PARAMS ((int));
 
 /* Allocate NBYTES of space in the inferior using the inferior's malloc
    and return a value that is a pointer to the allocated space. */
@@ -66,11 +59,11 @@ static CORE_ADDR
 allocate_space_in_inferior (len)
      int len;
 {
-  register value val;
+  register value_ptr val;
   register struct symbol *sym;
   struct minimal_symbol *msymbol;
   struct type *type;
-  value blocklen;
+  value_ptr blocklen;
   LONGEST maddr;
 
   /* Find the address of malloc in the inferior.  */
@@ -115,10 +108,10 @@ allocate_space_in_inferior (len)
    and if ARG2 is an lvalue it can be cast into anything at all.  */
 /* In C++, casts may change pointer or object representations.  */
 
-value
+value_ptr
 value_cast (type, arg2)
      struct type *type;
-     register value arg2;
+     register value_ptr arg2;
 {
   register enum type_code code1;
   register enum type_code code2;
@@ -141,8 +134,8 @@ value_cast (type, arg2)
       /* Look in the type of the source to see if it contains the
 	 type of the target as a superclass.  If so, we'll need to
 	 offset the object in addition to changing its type.  */
-      value v = search_struct_field (type_name_no_tag (type),
-				     arg2, 0, VALUE_TYPE (arg2), 1);
+      value_ptr v = search_struct_field (type_name_no_tag (type),
+					 arg2, 0, VALUE_TYPE (arg2), 1);
       if (v)
 	{
 	  VALUE_TYPE (v) = type;
@@ -167,8 +160,8 @@ value_cast (type, arg2)
 	      && TYPE_CODE (t2) == TYPE_CODE_STRUCT
 	      && TYPE_NAME (t1) != 0) /* if name unknown, can't have supercl */
 	    {
-	      value v = search_struct_field (type_name_no_tag (t1),
-					     value_ind (arg2), 0, t2, 1);
+	      value_ptr v = search_struct_field (type_name_no_tag (t1),
+						 value_ind (arg2), 0, t2, 1);
 	      if (v)
 		{
 		  v = value_addr (v);
@@ -198,12 +191,12 @@ value_cast (type, arg2)
 
 /* Create a value of type TYPE that is zero, and return it.  */
 
-value
+value_ptr
 value_zero (type, lv)
      struct type *type;
      enum lval_type lv;
 {
-  register value val = allocate_value (type);
+  register value_ptr val = allocate_value (type);
 
   memset (VALUE_CONTENTS (val), 0, TYPE_LENGTH (type));
   VALUE_LVAL (val) = lv;
@@ -220,12 +213,17 @@ value_zero (type, lv)
    is tested in the VALUE_CONTENTS macro, which is used if and when 
    the contents are actually required.  */
 
-value
+value_ptr
 value_at (type, addr)
      struct type *type;
      CORE_ADDR addr;
 {
-  register value val = allocate_value (type);
+  register value_ptr val;
+
+  if (TYPE_CODE (type) == TYPE_CODE_VOID)
+    error ("Attempt to dereference a generic pointer.");
+
+  val = allocate_value (type);
 
   read_memory (addr, VALUE_CONTENTS_RAW (val), TYPE_LENGTH (type));
 
@@ -237,12 +235,17 @@ value_at (type, addr)
 
 /* Return a lazy value with type TYPE located at ADDR (cf. value_at).  */
 
-value
+value_ptr
 value_at_lazy (type, addr)
      struct type *type;
      CORE_ADDR addr;
 {
-  register value val = allocate_value (type);
+  register value_ptr val;
+
+  if (TYPE_CODE (type) == TYPE_CODE_VOID)
+    error ("Attempt to dereference a generic pointer.");
+
+  val = allocate_value (type);
 
   VALUE_LVAL (val) = lval_memory;
   VALUE_ADDRESS (val) = addr;
@@ -265,7 +268,7 @@ value_at_lazy (type, addr)
 
 int
 value_fetch_lazy (val)
-     register value val;
+     register value_ptr val;
 {
   CORE_ADDR addr = VALUE_ADDRESS (val) + VALUE_OFFSET (val);
 
@@ -280,12 +283,12 @@ value_fetch_lazy (val)
 /* Store the contents of FROMVAL into the location of TOVAL.
    Return a new value with the location of TOVAL and contents of FROMVAL.  */
 
-value
+value_ptr
 value_assign (toval, fromval)
-     register value toval, fromval;
+     register value_ptr toval, fromval;
 {
   register struct type *type;
-  register value val;
+  register value_ptr val;
   char raw_buffer[MAX_REGISTER_RAW_SIZE];
   int use_buffer = 0;
 
@@ -514,12 +517,12 @@ Can't handle bitfield which doesn't fit in a single register.");
 
 /* Extend a value VAL to COUNT repetitions of its type.  */
 
-value
+value_ptr
 value_repeat (arg1, count)
-     value arg1;
+     value_ptr arg1;
      int count;
 {
-  register value val;
+  register value_ptr val;
 
   if (VALUE_LVAL (arg1) != lval_memory)
     error ("Only values in memory can be extended with '@'.");
@@ -537,12 +540,12 @@ value_repeat (arg1, count)
   return val;
 }
 
-value
+value_ptr
 value_of_variable (var, b)
      struct symbol *var;
      struct block *b;
 {
-  value val;
+  value_ptr val;
   FRAME fr;
 
   if (b == NULL)
@@ -590,9 +593,9 @@ value_of_variable (var, b)
    the coercion to pointer type.
    */
 
-value
+value_ptr
 value_coerce_array (arg1)
-     value arg1;
+     value_ptr arg1;
 {
   register struct type *type;
 
@@ -615,9 +618,9 @@ value_coerce_array (arg1)
 /* Given a value which is a function, return a value which is a pointer
    to it.  */
 
-value
+value_ptr
 value_coerce_function (arg1)
-     value arg1;
+     value_ptr arg1;
 {
 
   if (VALUE_LVAL (arg1) != lval_memory)
@@ -629,9 +632,9 @@ value_coerce_function (arg1)
 
 /* Return a pointer value for the object for which ARG1 is the contents.  */
 
-value
+value_ptr
 value_addr (arg1)
-     value arg1;
+     value_ptr arg1;
 {
   struct type *type = VALUE_TYPE (arg1);
   if (TYPE_CODE (type) == TYPE_CODE_REF)
@@ -639,7 +642,7 @@ value_addr (arg1)
       /* Copy the value, but change the type from (T&) to (T*).
 	 We keep the same location information, which is efficient,
 	 and allows &(&X) to get the location containing the reference. */
-      value arg2 = value_copy (arg1);
+      value_ptr arg2 = value_copy (arg1);
       VALUE_TYPE (arg2) = lookup_pointer_type (TYPE_TARGET_TYPE (type));
       return arg2;
     }
@@ -658,9 +661,9 @@ value_addr (arg1)
 
 /* Given a value of a pointer type, apply the C unary * operator to it.  */
 
-value
+value_ptr
 value_ind (arg1)
-     value arg1;
+     value_ptr arg1;
 {
   COERCE_ARRAY (arg1);
 
@@ -729,7 +732,7 @@ push_bytes (sp, buffer, len)
 static CORE_ADDR
 value_push (sp, arg)
      register CORE_ADDR sp;
-     value arg;
+     value_ptr arg;
 {
   register int len = TYPE_LENGTH (VALUE_TYPE (arg));
 
@@ -747,9 +750,9 @@ value_push (sp, arg)
 /* Perform the standard coercions that are specified
    for arguments to be passed to C functions.  */
 
-value
+value_ptr
 value_arg_coerce (arg)
-     value arg;
+     value_ptr arg;
 {
   register struct type *type;
 
@@ -789,7 +792,7 @@ value_arg_coerce (arg)
 static CORE_ADDR
 value_arg_push (sp, arg)
      register CORE_ADDR sp;
-     value arg;
+     value_ptr arg;
 {
   return value_push (sp, value_arg_coerce (arg));
 }
@@ -799,7 +802,7 @@ value_arg_push (sp, arg)
 
 static CORE_ADDR
 find_function_addr (function, retval_type)
-     value function;
+     value_ptr function;
      struct type **retval_type;
 {
   register struct type *ftype = VALUE_TYPE (function);
@@ -861,11 +864,11 @@ find_function_addr (function, retval_type)
    May fail to return, if a breakpoint or signal is hit
    during the execution of the function.  */
 
-value
+value_ptr
 call_function_by_hand (function, nargs, args)
-     value function;
+     value_ptr function;
      int nargs;
-     value *args;
+     value_ptr *args;
 {
   register CORE_ADDR sp;
   register int i;
@@ -1018,30 +1021,30 @@ call_function_by_hand (function, nargs, args)
 
 #if defined (REG_STRUCT_HAS_ADDR)
   {
-    /* This is a machine like the sparc, where we need to pass a pointer
+    /* This is a machine like the sparc, where we may need to pass a pointer
        to the structure, not the structure itself.  */
-    if (REG_STRUCT_HAS_ADDR (using_gcc))
-      for (i = nargs - 1; i >= 0; i--)
-	if (TYPE_CODE (VALUE_TYPE (args[i])) == TYPE_CODE_STRUCT)
-	  {
-	    CORE_ADDR addr;
+    for (i = nargs - 1; i >= 0; i--)
+      if (TYPE_CODE (VALUE_TYPE (args[i])) == TYPE_CODE_STRUCT
+	  && REG_STRUCT_HAS_ADDR (using_gcc, VALUE_TYPE (args[i])))
+	{
+	  CORE_ADDR addr;
 #if !(1 INNER_THAN 2)
-	    /* The stack grows up, so the address of the thing we push
-	       is the stack pointer before we push it.  */
-	    addr = sp;
+	  /* The stack grows up, so the address of the thing we push
+	     is the stack pointer before we push it.  */
+	  addr = sp;
 #endif
-	    /* Push the structure.  */
-	    sp = value_push (sp, args[i]);
+	  /* Push the structure.  */
+	  sp = value_push (sp, args[i]);
 #if 1 INNER_THAN 2
-	    /* The stack grows down, so the address of the thing we push
-	       is the stack pointer after we push it.  */
-	    addr = sp;
+	  /* The stack grows down, so the address of the thing we push
+	     is the stack pointer after we push it.  */
+	  addr = sp;
 #endif
-	    /* The value we're going to pass is the address of the thing
-	       we just pushed.  */
-	    args[i] = value_from_longest (lookup_pointer_type (value_type),
-				       (LONGEST) addr);
-	  }
+	  /* The value we're going to pass is the address of the thing
+	     we just pushed.  */
+	  args[i] = value_from_longest (lookup_pointer_type (value_type),
+					(LONGEST) addr);
+	}
   }
 #endif /* REG_STRUCT_HAS_ADDR.  */
 
@@ -1146,11 +1149,11 @@ the function call).", name);
   }
 }
 #else /* no CALL_DUMMY.  */
-value
+value_ptr
 call_function_by_hand (function, nargs, args)
-     value function;
+     value_ptr function;
      int nargs;
-     value *args;
+     value_ptr *args;
 {
   error ("Cannot invoke functions on this machine.");
 }
@@ -1167,16 +1170,16 @@ call_function_by_hand (function, nargs, args)
    first element, and all elements must have the same size (though we
    don't currently enforce any restriction on their types). */
 
-value
+value_ptr
 value_array (lowbound, highbound, elemvec)
      int lowbound;
      int highbound;
-     value *elemvec;
+     value_ptr *elemvec;
 {
   int nelem;
   int idx;
   int typelength;
-  value val;
+  value_ptr val;
   struct type *rangetype;
   struct type *arraytype;
   CORE_ADDR addr;
@@ -1228,12 +1231,12 @@ value_array (lowbound, highbound, elemvec)
    zero and an upper bound of LEN - 1.  Also note that the string may contain
    embedded null bytes. */
 
-value
+value_ptr
 value_string (ptr, len)
      char *ptr;
      int len;
 {
-  value val;
+  value_ptr val;
   struct type *rangetype;
   struct type *stringtype;
   CORE_ADDR addr;
@@ -1273,7 +1276,7 @@ static int
 typecmp (staticp, t1, t2)
      int staticp;
      struct type *t1[];
-     value t2[];
+     value_ptr t2[];
 {
   int i;
 
@@ -1327,10 +1330,10 @@ typecmp (staticp, t1, t2)
    If LOOKING_FOR_BASECLASS, then instead of looking for struct fields,
    look for a baseclass named NAME.  */
 
-static value
+static value_ptr
 search_struct_field (name, arg1, offset, type, looking_for_baseclass)
      char *name;
-     register value arg1;
+     register value_ptr arg1;
      int offset;
      register struct type *type;
      int looking_for_baseclass;
@@ -1346,7 +1349,7 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
 
 	if (t_field_name && STREQ (t_field_name, name))
 	  {
-	    value v;
+	    value_ptr v;
 	    if (TYPE_FIELD_STATIC (type, i))
 	      {
 		char *phys_name = TYPE_FIELD_STATIC_PHYSNAME (type, i);
@@ -1368,7 +1371,7 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
 
   for (i = TYPE_N_BASECLASSES (type) - 1; i >= 0; i--)
     {
-      value v;
+      value_ptr v;
       /* If we are looking for baseclasses, this is what we get when we
 	 hit them.  But it could happen that the base part's member name
 	 is not yet filled in.  */
@@ -1378,7 +1381,7 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
 
       if (BASETYPE_VIA_VIRTUAL (type, i))
 	{
-	  value v2;
+	  value_ptr v2;
 	  /* Fix to use baseclass_offset instead. FIXME */
 	  baseclass_addr (type, i, VALUE_CONTENTS (arg1) + offset,
 			  &v2, (int *)NULL);
@@ -1407,15 +1410,15 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
    If found, return value, else if name matched and args not return (value)-1,
    else return NULL. */
 
-static value
+static value_ptr
 search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
      char *name;
-     register value *arg1p, *args;
+     register value_ptr *arg1p, *args;
      int offset, *static_memfuncp;
      register struct type *type;
 {
   int i;
-  value v;
+  value_ptr v;
   int name_matched = 0;
   char dem_opname[64];
 
@@ -1448,11 +1451,11 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
 			    TYPE_FN_FIELD_ARGS (f, j), args))
 		{
 		  if (TYPE_FN_FIELD_VIRTUAL_P (f, j))
-		    return (value)value_virtual_fn_field (arg1p, f, j, type, offset);
+		    return value_virtual_fn_field (arg1p, f, j, type, offset);
 		  if (TYPE_FN_FIELD_STATIC_P (f, j) && static_memfuncp)
 		    *static_memfuncp = 1;
-		  v = (value)value_fn_field (arg1p, f, j, type, offset);
-		  if (v != (value)NULL) return v;
+		  v = value_fn_field (arg1p, f, j, type, offset);
+		  if (v != NULL) return v;
 		}
 	      j--;
 	    }
@@ -1475,7 +1478,7 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
         }
       v = search_struct_method (name, arg1p, args, base_offset + offset,
 				static_memfuncp, TYPE_BASECLASS (type, i));
-      if (v == (value) -1)
+      if (v == (value_ptr) -1)
 	{
 	  name_matched = 1;
 	}
@@ -1486,7 +1489,7 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
 	  return v;
         }
     }
-  if (name_matched) return (value) -1;
+  if (name_matched) return (value_ptr) -1;
   else return NULL;
 }
 
@@ -1504,15 +1507,15 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
 
    ERR is an error message to be printed in case the field is not found.  */
 
-value
+value_ptr
 value_struct_elt (argp, args, name, static_memfuncp, err)
-     register value *argp, *args;
+     register value_ptr *argp, *args;
      char *name;
      int *static_memfuncp;
      char *err;
 {
   register struct type *t;
-  value v;
+  value_ptr v;
 
   COERCE_ARRAY (*argp);
 
@@ -1558,7 +1561,7 @@ value_struct_elt (argp, args, name, static_memfuncp, err)
 
       v = search_struct_method (name, argp, args, 0, static_memfuncp, t);
 
-      if (v == (value) -1)
+      if (v == (value_ptr) -1)
 	error ("Cannot take address of a method");
       else if (v == 0)
 	{
@@ -1575,8 +1578,8 @@ value_struct_elt (argp, args, name, static_memfuncp, err)
       if (!args[1])
 	{
 	  /* destructors are a special case.  */
-	  v = (value)value_fn_field (NULL, TYPE_FN_FIELDLIST1 (t, 0),
-				TYPE_FN_FIELDLIST_LENGTH (t, 0), 0, 0);
+	  v = value_fn_field (NULL, TYPE_FN_FIELDLIST1 (t, 0),
+			      TYPE_FN_FIELDLIST_LENGTH (t, 0), 0, 0);
 	  if (!v) error("could not find destructor function named %s.", name);
 	  else return v;
 	}
@@ -1588,7 +1591,7 @@ value_struct_elt (argp, args, name, static_memfuncp, err)
   else
     v = search_struct_method (name, argp, args, 0, static_memfuncp, t);
 
-  if (v == (value) -1)
+  if (v == (value_ptr) -1)
     {
 	error("Argument list of %s mismatch with component in the structure.", name);
     }
@@ -1671,7 +1674,7 @@ check_field_in (type, name)
 
 int
 check_field (arg1, name)
-     register value arg1;
+     register value_ptr arg1;
      const char *name;
 {
   register struct type *t;
@@ -1702,7 +1705,7 @@ check_field (arg1, name)
    "pointers to member functions".  This function is used
    to resolve user expressions of the form "DOMAIN::NAME".  */
 
-value
+value_ptr
 value_struct_elt_for_reference (domain, offset, curtype, name, intype)
      struct type *domain, *curtype, *intype;
      int offset;
@@ -1710,7 +1713,7 @@ value_struct_elt_for_reference (domain, offset, curtype, name, intype)
 {
   register struct type *t = curtype;
   register int i;
-  value v;
+  value_ptr v;
 
   if (   TYPE_CODE (t) != TYPE_CODE_STRUCT
       && TYPE_CODE (t) != TYPE_CODE_UNION)
@@ -1822,7 +1825,7 @@ value_struct_elt_for_reference (domain, offset, curtype, name, intype)
     }
   for (i = TYPE_N_BASECLASSES (t) - 1; i >= 0; i--)
     {
-      value v;
+      value_ptr v;
       int base_offset;
 
       if (BASETYPE_VIA_VIRTUAL (t, i))
@@ -1843,7 +1846,7 @@ value_struct_elt_for_reference (domain, offset, curtype, name, intype)
 /* C++: return the value of the class instance variable, if one exists.
    Flag COMPLAIN signals an error if the request is made in an
    inappropriate context.  */
-value
+value_ptr
 value_of_this (complain)
      int complain;
 {
@@ -1852,7 +1855,7 @@ value_of_this (complain)
   struct block *b;
   int i;
   static const char funny_this[] = "this";
-  value this;
+  value_ptr this;
 
   if (selected_frame == 0)
     if (complain)
@@ -1890,3 +1893,243 @@ value_of_this (complain)
     error ("`this' argument at unknown address");
   return this;
 }
+
+/* Create a value for a literal string.  We copy data into a local 
+   (NOT inferior's memory) buffer, and then set up an array value.
+
+   The array bounds are set from LOWBOUND and HIGHBOUND, and the array is
+   populated from the values passed in ELEMVEC.
+
+   The element type of the array is inherited from the type of the
+   first element, and all elements must have the same size (though we
+   don't currently enforce any restriction on their types). */
+
+value_ptr
+f77_value_literal_string (lowbound, highbound, elemvec)
+     int lowbound;
+     int highbound;
+     value_ptr *elemvec;
+{
+  int nelem;
+  int idx;
+  int typelength;
+  register value_ptr val;
+  struct type *rangetype;
+  struct type *arraytype;
+  CORE_ADDR addr;
+
+  /* Validate that the bounds are reasonable and that each of the elements
+     have the same size. */
+
+  nelem = highbound - lowbound + 1;
+  if (nelem <= 0)
+    error ("bad array bounds (%d, %d)", lowbound, highbound);
+  typelength = TYPE_LENGTH (VALUE_TYPE (elemvec[0]));
+  for (idx = 0; idx < nelem; idx++)
+    {
+      if (TYPE_LENGTH (VALUE_TYPE (elemvec[idx])) != typelength)
+	error ("array elements must all be the same size");
+    }
+
+  /* Make sure we are dealing with characters */ 
+
+  if (typelength != 1)
+    error ("Found a non character type in a literal string "); 
+
+  /* Allocate space to store the array */ 
+
+  addr = malloc (nelem); 
+  for (idx = 0; idx < nelem; idx++)
+    {
+      memcpy (addr + (idx), VALUE_CONTENTS (elemvec[idx]), 1);
+    }
+
+  rangetype = create_range_type ((struct type *) NULL, builtin_type_int,
+				 lowbound, highbound);
+
+  arraytype = f77_create_literal_string_type ((struct type *) NULL, 
+                                              rangetype); 
+
+  val = allocate_value (arraytype); 
+
+  /* Make sure that this the rest of the world knows that this is 
+     a standard literal string, not one that is a substring of  
+     some base */ 
+
+  VALUE_SUBSTRING_START (val) = NULL; 
+
+  VALUE_LAZY (val) = 0; 
+  VALUE_LITERAL_DATA (val) = addr; 
+
+  /* Since this is a standard literal string with no real lval, 
+     make sure that value_lval indicates this fact */ 
+
+  VALUE_LVAL (val) = not_lval; 
+  return val;
+}
+
+/* Create a value for a substring.  We copy data into a local 
+   (NOT inferior's memory) buffer, and then set up an array value.
+
+   The array bounds for the string are (1:(to-from +1))
+   The elements of the string are all characters.  */
+
+value_ptr
+f77_value_substring (str, from, to)
+     value_ptr str; 
+     int from;
+     int to; 
+{
+  int nelem;
+  register value_ptr val;
+  struct type *rangetype;
+  struct type *arraytype;
+  struct internalvar *var; 
+  CORE_ADDR addr;
+
+  /* Validate that the bounds are reasonable. */ 
+
+  nelem = to - from + 1;
+  if (nelem <= 0)
+    error ("bad substring bounds (%d, %d)", from, to);
+
+  rangetype = create_range_type ((struct type *) NULL, builtin_type_int,
+				 1, nelem);
+
+  arraytype = f77_create_literal_string_type ((struct type *) NULL, 
+					      rangetype); 
+
+  val = allocate_value (arraytype); 
+
+  /* Allocate space to store the substring array */ 
+
+  addr = malloc (nelem); 
+
+  /* Copy over the data */
+
+  /* In case we ever try to use this substring on the LHS of an assignment 
+     remember where the SOURCE substring begins, for lval_memory 
+     types this ptr is to a location in legal inferior memory, 
+     for lval_internalvars it is a ptr. to superior memory. This 
+     helps us out later when we do assigments like:
+
+     set var ARR(2:3) = 'ab'
+ 
+     */ 
+
+
+  if (VALUE_LVAL (str) == lval_memory) 
+    {
+      if (VALUE_SUBSTRING_START (str) == NULL) 
+	{
+	  /* This is a regular lval_memory string located in the
+	     inferior */ 
+
+	  VALUE_SUBSTRING_START (val) = VALUE_ADDRESS (str) + (from - 1); 
+	  target_read_memory (VALUE_SUBSTRING_START (val), addr, nelem);
+	}
+      else
+	{
+
+#if 0 
+	  /* str is a substring allocated in the superior. Just 
+	     do a memcpy */ 
+
+	  VALUE_SUBSTRING_START(val) = VALUE_LITERAL_DATA(str)+(from - 1); 
+	  memcpy(addr,VALUE_SUBSTRING_START(val),nelem); 
+#else
+	  error ("Cannot get substrings of substrings"); 
+#endif
+	}
+    }
+  else
+    if (VALUE_LVAL(str) == lval_internalvar)
+      {
+        /* Internal variables of type TYPE_CODE_LITERAL_STRING 
+           have their data located in the superior 
+           process not the inferior */ 
+ 
+        var = VALUE_INTERNALVAR (str);
+        
+        if (VALUE_SUBSTRING_START (str) == NULL) 
+           VALUE_SUBSTRING_START (val) =
+	     VALUE_LITERAL_DATA (var->value) + (from - 1);
+        else 
+#if 0 
+	  VALUE_SUBSTRING_START(val)=VALUE_LITERAL_DATA(str)+(from -1);
+#else
+	error ("Cannot get substrings of substrings"); 
+#endif
+        memcpy (addr, VALUE_SUBSTRING_START (val), nelem);
+      }
+    else
+      error ("Substrings can not be applied to this data item"); 
+
+  VALUE_LAZY (val) = 0; 
+  VALUE_LITERAL_DATA (val) = addr; 
+
+  /* This literal string's *data* is located in the superior BUT 
+     we do need to know where it came from (i.e. was the source
+     string an internalvar or a regular lval_memory variable), so 
+     we set the lval field to indicate this.  This will be useful 
+     when we use this value on the LHS of an expr. */ 
+     
+  VALUE_LVAL (val) = VALUE_LVAL (str); 
+  return val;
+}
+
+/* Create a value for a FORTRAN complex number.  Currently most of 
+   the time values are coerced to COMPLEX*16 (i.e. a complex number 
+   composed of 2 doubles.  This really should be a smarter routine 
+   that figures out precision inteligently as opposed to assuming 
+   doubles. FIXME: fmb */ 
+
+value_ptr
+f77_value_literal_complex (arg1, arg2, size)
+     value_ptr arg1;
+     value_ptr arg2;
+     int size;
+{
+  struct type *complex_type; 
+  register value_ptr val;
+  char *addr; 
+
+  if (size != 8 && size != 16 && size != 32)
+    error ("Cannot create number of type 'complex*%d'", size);
+  
+  /* If either value comprising a complex number is a non-floating 
+     type, cast to double. */
+
+  if (TYPE_CODE (VALUE_TYPE (arg1)) != TYPE_CODE_FLT)
+    arg1 = value_cast (builtin_type_f_real_s8, arg1);
+
+  if (TYPE_CODE (VALUE_TYPE (arg1)) != TYPE_CODE_FLT)
+    arg2 = value_cast (builtin_type_f_real_s8, arg2);
+     
+  complex_type = f77_create_literal_complex_type (VALUE_TYPE (arg1),
+						  VALUE_TYPE (arg2),
+						  size);
+
+  val = allocate_value (complex_type); 
+
+  /* Now create a pointer to enough memory to hold the the two args */
+  
+  addr = malloc (TYPE_LENGTH (complex_type)); 
+
+  /* Copy over the two components */
+
+  memcpy (addr, VALUE_CONTENTS_RAW (arg1), TYPE_LENGTH (VALUE_TYPE (arg1)));
+  
+  memcpy (addr + TYPE_LENGTH (VALUE_TYPE (arg1)), VALUE_CONTENTS_RAW (arg2),
+	  TYPE_LENGTH (VALUE_TYPE (arg2)));
+
+  VALUE_ADDRESS (val) = 0; /* Not located in the inferior */ 
+  VALUE_LAZY (val) = 0; 
+  VALUE_LITERAL_DATA (val) = addr; 
+
+  /* Since this is a literal value, make sure that value_lval indicates 
+     this fact */ 
+
+  VALUE_LVAL (val) = not_lval; 
+  return val;
+}
diff --git a/gdb/value.h b/gdb/value.h
index 6982258..3c4a047 100644
--- a/gdb/value.h
+++ b/gdb/value.h
@@ -139,6 +139,28 @@ extern int value_fetch_lazy PARAMS ((value_ptr val));
 #define VALUE_REGNO(val) (val)->regno
 #define VALUE_OPTIMIZED_OUT(val) ((val)->optimized_out)
 
+/* This is probably not the right thing to do for in-gdb arrays.  FIXME */
+/* Overload the contents field to store literal data for 
+   arrays.  */
+
+#define VALUE_LITERAL_DATA(val)  ((val)->aligner.contents[0])
+
+/* Overload the frame address field to contain a pointer to 
+   the base substring, for F77 string substring operators.
+   We use this ONLY when doing operations of the form 
+   
+   FOO= 'hello' 
+   FOO(2:4) = 'foo'
+
+   In the above case VALUE_SUBSTRING_START would point to 
+   FOO(2) in the original FOO string. 
+
+   Depending on whether the base object is allocated in the 
+   inferior or the superior process, VALUE_SUBSTRING_START 
+   contains a ptr. to memory in the relevant area.  */ 
+
+#define VALUE_SUBSTRING_START(val) VALUE_FRAME(val)
+
 /* Convert a REF to the object referenced. */
 
 #define COERCE_REF(arg)    \
@@ -433,6 +455,10 @@ print_floating PARAMS ((char *valaddr, struct type *type, GDB_FILE *stream));
 extern int value_print PARAMS ((value_ptr val, GDB_FILE *stream, int format,
 				enum val_prettyprint pretty));
 
+extern void
+value_print_array_elements PARAMS ((value_ptr val, GDB_FILE* stream,
+				    int format, enum val_prettyprint pretty));
+
 extern value_ptr
 value_release_to_mark PARAMS ((value_ptr mark));
 
@@ -475,4 +501,10 @@ extern int baseclass_offset PARAMS ((struct type *, int, value_ptr, int));
 
 extern value_ptr call_function_by_hand PARAMS ((value_ptr, int, value_ptr *));
 
+extern value_ptr f77_value_literal_complex PARAMS ((value_ptr, value_ptr, int));
+
+extern value_ptr f77_value_literal_string PARAMS ((int, int, value_ptr *));
+
+extern value_ptr f77_value_substring PARAMS ((value_ptr, int, int));
+
 #endif	/* !defined (VALUE_H) */