This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

namelist


Thank you to all of you that have helped out with comments or corrections - it is well appreciated; in particular Steve Kargl, Tobi Schlueter, Paul Brook and Steven Bosscher.

Bootstrapped and regtested on 4.0 and Mainline. OK to commit?

Paul T

Changelog entries

2005-04-07 Paul Thomas <pault@gcc.gnu.org>

PR libgfortran/12884
PR libgfortran/17285
PR libgfortran/18122
PR libgfortran/18210
PR libgfortran/18392
PR libgfortran/18591
PR libgfortran/18879
* io/io.h (nml_ls): Declare.
* io/io.h (namelist_info): Modify for arrays.
* io/list_read.c (namelist_read): Modified to call new functions.
* io/list_read.c (match_namelist_name): Simplified.
* io/list_read.c (nml_query): Handles stdin queries ? and =?. New function.
* io/list_read.c (nml_get_obj_data): Parses object name. New function.
* io/list_read.c (touch_nml_nodes): Marks objects for read. New function.
* io/list_read.c (untouch_nml_nodes): Resets objects. New function.
* io/list_read.c (parse_qualifier): Parses and checks qualifiers. New function
* io/list_read.c (nml_read_object): Reads and stores object data. New function.
* io/list_read.c (eat_separator): No new_record on '/' in namelist.
* io/list_read.c (finish_separator): No new_record on '/' in namelist.
* io/list_read.c (read_logical): Error return for namelist.
* io/list_read.c (read_integer): Error return for namelist.
* io/list_read.c (read_complex): Error return for namelist.
* io/list_read.c (read_real): Error return for namelist.
* io/lock.c (library_end): Free extended namelist_info types.
* io/transfer.c (st_set_nml_var): Modified for arrays.
* io/transfer.c (st_set_nml_var_dim): Dimension descriptors. New function.
* io/write.c (namelist_write): Modified to call new functions.
* io/write.c (nml_write_obj): Writes output for object. New function.
* io/write.c (write_integer): Suppress leading blanks for repeat counts.
* io/write.c (write_int): Suppress leading blanks for repeat counts.
* io/write.c (write_float): Suppress leading blanks for repeat counts.
* io/write.c (output_float): Suppress leading blanks for repeat counts.


2005-04-07 Paul Thomas <pault@gcc.gnu.org>

PR fortran/17472
PR fortran/18209
PR fortran/18396
PR fortran/19467
PR fortran/19657
* fortran/trans-io.c : Build library function for st_set_nml_var.
* fortran/trans-io.c : Build library function for st_set_nml_var_dim.
* fortran/trans-io.c (build_dt): Simplified call to transfer_namelist_element.
* fortran/trans-io.c (nml_get_addr_expr): New function.
* fortran/trans-io.c (nml_full_name): Qualified name for derived type components. New function.



2005-04-07 Paul Thomas <pault@gcc.gnu.org>


PR libfortran/12884 gfortran.dg/pr12884.f: New test
PR libfortran/17285 gfortran.dg/pr17285.f90: New test
PR libfortran/17472, 18396, 18209 gfortran.dg/pr17472.f: New test
PR libfortran/18122, 18591 gfortran.dg/pr18122.f90: New test
PR libfortran/18210 gfortran.dg/pr18210.f90: New test
PR libfortran/18392 gfortran.dg/pr18392.f90: New test
PR libfortran/19467 gfortran.dg/pr19467.f90: New test
PR libfortran/19657 gfortran.dg/pr19657.f90: New test
* gfortran.dg/namelist_1.f: Tests reals and qualifiers in namelist. New test
* gfortran.dg/namelist_2.f: Tests integers and qualifiers in namelist. New test
* gfortran.dg/namelist_3.f90: Tests derived types in namelist. New test
* gfortran.dg/namelist_4.f90: Tests trans-io.c namelist support. New test
* gfortran.dg/namelist_5.f90: Tests arrays of derived types in namelist. New test
* gfortran.dg/namelist_6.f90: Tests complex in namelist. New test
* gfortran.dg/namelist_7.f90: Tests logical in namelist. New test
* gfortran.dg/namelist_8.f90: Tests charcter delimiters in namelist. New test
* gfortran.dg/namelist_9.f90: Tests namelist errors. New test




? fortran.diff
? fortran.patch
Index: trans-io.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.34
diff -p -c -3 -r1.34 trans-io.c
*** trans-io.c	15 Mar 2005 02:52:37 -0000	1.34
--- trans-io.c	7 Apr 2005 14:14:15 -0000
*************** static GTY(()) tree iocall_iolength_done
*** 125,135 ****
  static GTY(()) tree iocall_rewind;
  static GTY(()) tree iocall_backspace;
  static GTY(()) tree iocall_endfile;
! static GTY(()) tree iocall_set_nml_val_int;
! static GTY(()) tree iocall_set_nml_val_float;
! static GTY(()) tree iocall_set_nml_val_char;
! static GTY(()) tree iocall_set_nml_val_complex;
! static GTY(()) tree iocall_set_nml_val_log;
  
  /* Variable for keeping track of what the last data transfer statement
     was.  Used for deciding which subroutine to call when the data
--- 125,132 ----
  static GTY(()) tree iocall_rewind;
  static GTY(()) tree iocall_backspace;
  static GTY(()) tree iocall_endfile;
! static GTY(()) tree iocall_set_nml_val;
! static GTY(()) tree iocall_set_nml_val_dim;
  
  /* Variable for keeping track of what the last data transfer statement
     was.  Used for deciding which subroutine to call when the data
*************** gfc_build_io_library_fndecls (void)
*** 314,347 ****
      gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
  				     gfc_int4_type_node, 0);
  
-   iocall_set_nml_val_int =
-     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
-                                      void_type_node, 4,
-                                      pvoid_type_node, pvoid_type_node,
-                                      gfc_int4_type_node,gfc_int4_type_node);
  
!   iocall_set_nml_val_float =
!     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
!                                      void_type_node, 4,
!                                      pvoid_type_node, pvoid_type_node,
!                                      gfc_int4_type_node,gfc_int4_type_node);
!   iocall_set_nml_val_char =
!     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
                                       void_type_node, 5,
                                       pvoid_type_node, pvoid_type_node,
                                       gfc_int4_type_node, gfc_int4_type_node, 
!                                      gfc_charlen_type_node);
!   iocall_set_nml_val_complex =
!     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
!                                      void_type_node, 4,
!                                      pvoid_type_node, pvoid_type_node,
!                                      gfc_int4_type_node,gfc_int4_type_node);
!   iocall_set_nml_val_log =
!     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
!                                      void_type_node, 4,
!                                      pvoid_type_node, pvoid_type_node,
!                                      gfc_int4_type_node,gfc_int4_type_node);
  
  }
  
  
--- 311,329 ----
      gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
  				     gfc_int4_type_node, 0);
  
  
!   iocall_set_nml_val =
!     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
                                       void_type_node, 5,
                                       pvoid_type_node, pvoid_type_node,
                                       gfc_int4_type_node, gfc_int4_type_node, 
! 				     gfc_int4_type_node);
  
+   iocall_set_nml_val_dim =
+     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
+ 				     void_type_node, 4,
+ 				     gfc_int4_type_node, gfc_int4_type_node,
+ 				     gfc_int4_type_node, gfc_int4_type_node);
  }
  
  
*************** gfc_trans_inquire (gfc_code * code)
*** 815,821 ****
    return gfc_finish_block (&block);
  }
  
- 
  static gfc_expr *
  gfc_new_nml_name_expr (const char * name)
  {
--- 797,802 ----
*************** gfc_new_nml_name_expr (const char * name
*** 832,945 ****
     return nml_name;
  }
  
! static gfc_expr *
! get_new_var_expr(gfc_symbol * sym)
  {
!   gfc_expr * nml_var;
  
!   nml_var = gfc_get_expr();
!   nml_var->expr_type = EXPR_VARIABLE;
!   nml_var->ts = sym->ts;
!   if (sym->as)
!     nml_var->rank = sym->as->rank;
!   nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
!   nml_var->symtree->n.sym = sym;
!   nml_var->where = sym->declared_at;
    sym->attr.referenced = 1;
  
!   return nml_var;
  }
  
! /* For a scalar variable STRING whose address is ADDR_EXPR, generate a
     call to iocall_set_nml_val.  For derived type variable, recursively
!    generate calls to iocall_set_nml_val for each leaf field. The leafs
!    have no names -- their STRING field is null, and are interpreted by
!    the run-time library as having only the value, as in the example:
! 
!    &foo bzz=1,2,3,4,5/
! 
!    Note that the first output field appears after the name of the
!    variable, not of the field name.  This causes a little complication
!    documented below.  */
  
  static void
! transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr, 
!                            tree string, tree string_length)
  {
!   tree tmp, args, arg2;
!   tree expr;
  
!   gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
  
!   if (ts->type == BT_DERIVED)
!     {
!       gfc_component *c;
!       expr = gfc_build_indirect_ref (addr_expr);
  
!       for (c = ts->derived->components; c; c = c->next)
!         {
!           tree field = c->backend_decl;
!           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
!           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), 
! 			expr, field, NULL_TREE);
  
!           if (c->dimension)
!             gfc_todo_error ("NAMELIST IO of array in derived type");
!           if (!c->pointer)
!             tmp = gfc_build_addr_expr (NULL, tmp);
!           transfer_namelist_element (block, &c->ts, tmp, string, string_length);
! 
!           /* The first output field bears the name of the topmost
!              derived type variable.  All other fields are anonymous
!              and appear with nulls in their string and string_length
!              fields.  After the first use, we set string and
!              string_length to null.  */
!           string = null_pointer_node;
!           string_length = integer_zero_node;
!         }
  
!       return;
!     }
  
!   args = gfc_chainon_list (NULL_TREE, addr_expr);
!   args = gfc_chainon_list (args, string);
!   args = gfc_chainon_list (args, string_length);
!   arg2 = build_int_cst (gfc_array_index_type, ts->kind);
!   args = gfc_chainon_list (args,arg2);
  
    switch (ts->type)
      {
      case BT_INTEGER:
!       tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
        break;
! 
!     case BT_CHARACTER:
!       expr = gfc_build_indirect_ref (addr_expr);
!       gcc_assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
!       args = gfc_chainon_list (args,
!                                TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
!       tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
        break;
- 
      case BT_REAL:
!       tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
        break;
! 
!     case BT_LOGICAL:
!       tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
        break;
  
      case BT_COMPLEX:
!       tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
        break;
! 
!     default :
!       internal_error ("Bad namelist IO basetype (%d)", ts->type);
      }
  
    gfc_add_expr_to_block (block, tmp);
  }
  
  /* Create a data transfer statement.  Not all of the fields are valid
     for both reading and writing, but improper use has been filtered
     out by now.  */
--- 813,1038 ----
     return nml_name;
  }
  
! /* nml_full_name builds up the fully qualified name of a
!    derived type component. */
! 
! static char*
! nml_full_name (const char* var_name, const char* cmp_name)
  {
!   int full_name_length;
!   char * full_name;
!   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
!   if (full_name_length > GFC_MAX_SYMBOL_LEN)
!     gfc_error ("NAMELIST IO: concatenation of %s and %s "
! 	       "exceeds %d characters", var_name,
! 	       cmp_name, GFC_MAX_SYMBOL_LEN);
!   full_name = (char*)gfc_getmem (full_name_length + 1);
!   strcpy (full_name, var_name);
!   full_name = strcat (full_name, "%");
!   full_name = strcat (full_name, cmp_name);
!   return full_name;
! }
! 
! /* nml_get_addr_expr builds an address expression from the
!    gfc_symbol or gfc_component backend_decl's. An offset is
!    provided so that the address of an element of an array of
!    derived types is returned. This is used in the runtime to
!    determine that span of the derived type. */
  
! static tree
! nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
! 		   tree base_addr)
! {
!   tree decl = NULL_TREE;
!   tree tmp, itmp;
!   int fl_array, fl_dummy;
!   if (sym)
!     {
    sym->attr.referenced = 1;
+       decl = gfc_get_symbol_decl (sym);
+     }
+   else
+     decl = c->backend_decl;
+   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
+ 		     || TREE_CODE (decl) == VAR_DECL
+ 		     || TREE_CODE (decl) == PARM_DECL)
+ 		     || TREE_CODE (decl) == COMPONENT_REF));
+ 
+   tmp =decl;
+ 
+ /* Build indirect reference, if dummy argument. */
+ 
+   fl_dummy = POINTER_TYPE_P (TREE_TYPE(tmp));
+   itmp = (fl_dummy) ? gfc_build_indirect_ref (tmp) : tmp;
+ 
+ /* If an array, set flag and use indirect ref. if built. After
+    building the component reference, if we have a derived type
+    component, a reference to the first element of the array is
+    built.  This is done so that base_addr, used in the build of
+    the component reference, always points to a RECORD_TYPE. */
+ 
+   fl_array = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE &&
+ 	      !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
  
!   if (fl_array)
!     tmp = itmp;
! 
!   if (TREE_CODE (decl) == FIELD_DECL)
!     tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
! 		  base_addr, tmp, NULL_TREE);
! 
!   if (fl_array)
!     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
! 
! /* Now build the address expression, no matter what we have. */
! 
!   tmp = gfc_build_addr_expr (NULL, tmp);
! 
! /* If scalar dummy, resolve indirect reference now. */
! 
!   if (fl_dummy && !fl_array)
!     tmp = gfc_build_indirect_ref (tmp);
! 
!   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
! 
!   return tmp;
  }
  
! /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
     call to iocall_set_nml_val.  For derived type variable, recursively
!    generate calls to iocall_set_nml_val for each component. */
  
  static void
! transfer_namelist_element (stmtblock_t * block, const char * var_name,
! 			   gfc_symbol * sym, gfc_component * c,
! 			   tree base_addr)
  {
!   gfc_typespec * ts = NULL;
!   gfc_array_spec * as = NULL;
!   tree addr_expr = NULL;
!   tree dt = NULL;
  
!   tree string, tmp, args, dtype;
!   int n_dim, itype, rank = 0;
  
!   gcc_assert (sym || c);
  
! /* Build the namelist object name. */
  
!   string = gfc_build_cstring_const (var_name);
!   string = gfc_build_addr_expr (pchar_type_node, string);
  
! /* Build ts, as and data address using symbol or component. */
  
!   ts = (sym)? &sym->ts : &c->ts;
!   as = (sym)? sym->as : c->as;
! 
!   addr_expr = nml_get_addr_expr (sym, c, base_addr);
! 
!   if ( as ) rank = as->rank;
  
+   if (rank)
+     {
+       dt =  TREE_TYPE ((sym)? sym->backend_decl: c->backend_decl);
+       dtype = gfc_get_dtype (dt);
+     }
+   else
+     {
+       itype = GFC_DTYPE_UNKNOWN;
    switch (ts->type)
      {
      case BT_INTEGER:
! 	  itype = GFC_DTYPE_INTEGER;
        break;
! 	case BT_LOGICAL:
! 	  itype = GFC_DTYPE_LOGICAL;
        break;
      case BT_REAL:
! 	  itype = GFC_DTYPE_REAL;
        break;
! 	case BT_COMPLEX:
! 	  itype = GFC_DTYPE_COMPLEX;
        break;
+ 	case BT_DERIVED:
+ 	  itype = GFC_DTYPE_DERIVED;
+ 	  break;
+ 	case BT_CHARACTER:
+ 	  itype = GFC_DTYPE_CHARACTER;
+ 	  break;
+ 	default:
+ 	  gfc_error("Bad type in namelist transfer");
+ 	}
+       dtype = build_int_cst (gfc_array_index_type,
+ 			     itype << GFC_DTYPE_TYPE_SHIFT);
+     }
  
+ #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
+ #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
+ #define IARG(i) build_int_cst (gfc_array_index_type, i)
+ 
+ /* Build up the arguments for the transfer call.
+    The call for the scalar part transfers:
+    (address, name, type, kind or string_length, dtype) */
+ 
+   NML_FIRST_ARG (addr_expr);
+   NML_ADD_ARG (string);
+   NML_ADD_ARG (IARG (ts->kind));
+   switch(ts->type)
+     {
+     case BT_CHARACTER:
+       NML_ADD_ARG (convert (gfc_array_index_type,
+ 			    ts->cl->backend_decl));
+       break;
+     case BT_INTEGER:
+     case BT_REAL:
      case BT_COMPLEX:
!     case BT_LOGICAL:
!     case BT_DERIVED:
!       NML_ADD_ARG (integer_zero_node);
        break;
!     default:
!       gfc_error("Bad type in namelist transfer");
      }
+   NML_ADD_ARG (dtype);
+   tmp = gfc_build_function_call (iocall_set_nml_val, args);
+   gfc_add_expr_to_block (block, tmp);
+ 
+ /* If the object is an array, transfer rank times:
+    (null pointer, name, stride, lbound, ubound)  */
  
+   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
+     {
+       NML_FIRST_ARG (IARG (n_dim));
+       NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
+       NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
+       NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
+       tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
    gfc_add_expr_to_block (block, tmp);
+     }
+ 
+   if (ts->type == BT_DERIVED)
+     {
+       gfc_component *cmp;
+ 
+ /* Provide the RECORD_TYPE itself to build component references. */
+ 
+       tree expr = gfc_build_indirect_ref (addr_expr);
+ 
+       for (cmp = ts->derived->components; cmp; cmp = cmp->next)
+ 	{
+ 	  char *full_name = nml_full_name (var_name, cmp->name);
+ 	  transfer_namelist_element (block,
+ 				     full_name,
+ 				     NULL, cmp, expr);
+ 	  gfc_free (full_name);
+ 	}
+     }
  }
  
+ #undef IARG
+ #undef NML_ADD_ARG
+ #undef NML_FIRST_ARG
+ 
  /* Create a data transfer statement.  Not all of the fields are valid
     for both reading and writing, but improper use has been filtered
     out by now.  */
*************** build_dt (tree * function, gfc_code * co
*** 950,958 ****
    stmtblock_t block, post_block;
    gfc_dt *dt;
    tree tmp;
!   gfc_expr *nmlname, *nmlvar;
    gfc_namelist *nml;
-   gfc_se se,se2;
  
    gfc_init_block (&block);
    gfc_init_block (&post_block);
--- 1043,1050 ----
    stmtblock_t block, post_block;
    gfc_dt *dt;
    tree tmp;
!   gfc_expr *nmlname;
    gfc_namelist *nml;
  
    gfc_init_block (&block);
    gfc_init_block (&post_block);
*************** build_dt (tree * function, gfc_code * co
*** 1022,1039 ****
            set_flag (&block, ioparm_namelist_read_mode);
  
  	for (nml = dt->namelist->namelist; nml; nml = nml->next)
! 	  {
! 	    gfc_init_se (&se, NULL);
! 	    gfc_init_se (&se2, NULL);
! 	    nmlvar = get_new_var_expr (nml->sym);
! 	    nmlname = gfc_new_nml_name_expr (nml->sym->name);
! 	    gfc_conv_expr_reference (&se2, nmlname);
! 	    gfc_conv_expr_reference (&se, nmlvar);
! 	    gfc_evaluate_now (se.expr, &se.pre); 
! 
! 	    transfer_namelist_element (&block, &nml->sym->ts, se.expr,
! 				       se2.expr, se2.string_length);
! 	  }
      }
  
    tmp = gfc_build_function_call (*function, NULL_TREE);
--- 1114,1121 ----
            set_flag (&block, ioparm_namelist_read_mode);
  
  	for (nml = dt->namelist->namelist; nml; nml = nml->next)
! 	transfer_namelist_element (&block, nml->sym->name, nml->sym,
! 				   NULL, NULL);
      }
  
    tmp = gfc_build_function_call (*function, NULL_TREE);
? io.patch
? libgfortran.diff
Index: io.h
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/io.h,v
retrieving revision 1.17
diff -p -c -3 -r1.17 io.h
*** io.h	16 Mar 2005 19:33:07 -0000	1.17
--- io.h	7 Apr 2005 14:10:30 -0000
*************** stream;
*** 74,105 ****
  #define sseek(s, pos) ((s)->seek)(s, pos)
  #define struncate(s) ((s)->truncate)(s)
  
! /* Namelist represent object */
! /*
!    Namelist Records
!        &groupname  object=value [,object=value].../
!      or
!        &groupname  object=value [,object=value]...&groupname
! 
!   Even more complex, during the execution of a program containing a
!   namelist READ statement, you can specify a question mark character(?)
!   or a question mark character preceded by an equal sign(=?) to get
!   the information of the namelist group. By '?', the name of variables
!   in the namelist will be displayed, by '=?', the name and value of
!   variables will be displayed.
! 
!   All these requirements need a new data structure to record all info
!   about the namelist.
! */
  
  typedef struct namelist_type
  {
    char * var_name;
    void * mem_pos;
!   int  value_acquired;
    int len;
    int string_length;
!   bt type;
    struct namelist_type * next;
  }
  namelist_info;
--- 74,102 ----
  #define sseek(s, pos) ((s)->seek)(s, pos)
  #define struncate(s) ((s)->truncate)(s)
  
! /* Namelist object representation*/
! 
! typedef struct nml_loop_spec
! {
!   int idx;
!   int start;
!   int end;
!   int step;
! }
! nml_loop_spec;
  
  typedef struct namelist_type
  {
+   bt type;
    char * var_name;
    void * mem_pos;
!   int touched;
    int len;
+   int size;
    int string_length;
!   int var_rank;
!   descriptor_dimension * dim;
!   nml_loop_spec * ls;
    struct namelist_type * next;
  }
  namelist_info;
Index: list_read.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/list_read.c,v
retrieving revision 1.15
diff -p -c -3 -r1.15 list_read.c
*** list_read.c	25 Mar 2005 13:35:29 -0000	1.15
--- list_read.c	7 Apr 2005 14:10:31 -0000
***************
*** 1,5 ****
! /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
     Contributed by Andy Vaught
  
  This file is part of the GNU Fortran 95 runtime library (libgfortran).
  
--- 1,6 ----
! /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
     Contributed by Andy Vaught
+    Namelist input contributed by Paul Thomas
  
  This file is part of the GNU Fortran 95 runtime library (libgfortran).
  
*************** Boston, MA 02111-1307, USA.  */
*** 50,61 ****
     ourselves.  Data is buffered in scratch[] until it becomes too
     large, after which we start allocating memory on the heap.  */
  
! static int repeat_count, saved_length, saved_used, input_complete, at_eol;
! static int comma_flag, namelist_mode;
! 
  static char last_char, *saved_string;
  static bt saved_type;
  
  
  
  /* Storage area for values except for strings.  Must be large enough
--- 51,69 ----
     ourselves.  Data is buffered in scratch[] until it becomes too
     large, after which we start allocating memory on the heap.  */
  
! static int repeat_count, saved_length, saved_used;
! static int input_complete, at_eol, comma_flag;
  static char last_char, *saved_string;
  static bt saved_type;
  
+ /* These two namelist specific flags are used in the list directed library
+    to (i) flag that calls are being made from namelist read (eg. to ignore
+    comments or to treat '/' as a terminator) and (ii) both to flag read
+    errors and return, so that an attempt can be made to read a new object
+    name. */
+ 
+ static int namelist_mode, nml_read_error;
+ 
  
  
  /* Storage area for values except for strings.  Must be large enough
*************** eat_separator (void)
*** 226,237 ****
--- 234,249 ----
  
      case '/':
        input_complete = 1;
+       if (!namelist_mode)
+ 	{
        next_record (0);
        at_eol = 1;
+ 	}
        break;
  
      case '\n':
      case '\r':
+       at_eol = 1;
        break;
  
      case '!':
*************** finish_separator (void)
*** 282,288 ****
  
      case '/':
        input_complete = 1;
!       next_record (0);
        break;
  
      case '\n':
--- 294,300 ----
  
      case '/':
        input_complete = 1;
!       if (!namelist_mode) next_record (0);
        break;
  
      case '\n':
*************** finish_separator (void)
*** 305,310 ****
--- 317,336 ----
      }
  }
  
+ /* This function is needed to catch bad conversions so that namelist can
+    attempt to see if saved_string contains a new object name rather than
+    a bad value.  */
+ 
+ static int
+ nml_bad_return (char c)
+ {
+   if (!namelist_mode)
+     return 0;
+   nml_read_error = 1;
+   unget_char(c);
+   return 1;
+ }
+ 
  
  /* Convert an unsigned string to an integer.  The length value is -1
     if we are working on a repeat count.  Returns nonzero if we have a
*************** read_logical (int length)
*** 525,530 ****
--- 551,560 ----
    return;
  
   bad_logical:
+ 
+   if (nml_bad_return (c))
+     return;
+ 
    st_sprintf (message, "Bad logical value while reading item %d",
  	      g.item_count);
  
*************** read_integer (int length)
*** 641,646 ****
--- 671,680 ----
      }
  
   bad_integer:
+ 
+   if (nml_bad_return (c))
+     return;
+ 
    free_saved ();
  
    st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
*************** read_complex (int length)
*** 976,981 ****
--- 1010,1019 ----
    return;
  
   bad_complex:
+ 
+   if (nml_bad_return (c))
+     return;
+ 
    st_sprintf (message, "Bad complex value in item %d of list input",
  	      g.item_count);
  
*************** read_real (int length)
*** 1186,1191 ****
--- 1224,1233 ----
    return;
  
   bad_real:
+ 
+   if (nml_bad_return (c))
+     return;
+ 
    st_sprintf (message, "Bad real number in item %d of list input",
  	      g.item_count);
  
*************** finish_list_read (void)
*** 1380,1385 ****
--- 1422,1622 ----
    while (c != '\n');
  }
  
+ /****************************namelist input******************************
+ 
+ void namelist_read (void)
+ calls:
+    static void nml_match_name (char *name, int len)
+    static int nml_query (void)
+    static int nml_get_obj_data (void)
+ calls:
+       static void nml_untouch_nodes (void)
+       static namelist_info * find_nml_node (char * var_name)
+       static int nml_parse_qualifier(descriptor_dimension * ad,
+ 				     nml_loop_spec * ls, int rank)
+       static void nml_touch_nodes (namelist_info * nl)
+       static int nml_read_obj (namelist_info * nl, index_type offset)
+ calls:
+       -itself-  */
+ 
+ /* Carries error messages from the qualifier parser.  */
+ 
+ static char parse_err_msg[30];
+ 
+ /* Carries error messages for error returns.  */
+ 
+ static char nml_err_msg[100];
+ 
+ /* Pointer to the previously read object, in case attempt is made to read
+    new object name.  Should this fail, error message can give previous
+    name.  */
+ 
+ static namelist_info * prev_nl;
+ 
+ /* Lower index for substring qualifier.  */
+ 
+ static int clow;
+ 
+ /* Upper index for substring qualifier.  */
+ 
+ static int chigh;
+ 
+ /* Inputs a rank-dimensional qualifier, which can contain
+    singlets, doublets, triplets or ':' with the standard meanings.  ad is
+    the descriptor dimension, as in the declaration, whereas id is the
+    input descriptor. The input descriptor is checked for consistency with
+    the bounds in the variable declaration.  */
+ 
+ static try
+ nml_parse_qualifier(descriptor_dimension * ad,
+ 		    nml_loop_spec * ls, int rank)
+ {
+   int dim;
+   int indx;
+   int neg;
+   int null_flag;
+   char c;
+ 
+   /* The next character in the stream should be the '('.  */
+ 
+   c = next_char ();
+ 
+   /* Process the qualifier, by dimension and triplet.  */
+ 
+   for ( dim=0; dim < rank; dim++ )
+     {
+       for ( indx=0; indx<3;  indx++)
+ 	{
+ 	  free_saved ();
+ 	  eat_spaces ();
+ 	  neg = 0;
+ 
+ 	  /*process a potential sign.  */
+ 
+ 	  c = next_char ();
+ 	  switch (c)
+ 	    {
+ 	    case '-':
+ 	      neg = 1;
+ 	    case '+':
+ 	      break;
+ 	    default:
+ 	      unget_char (c);
+ 	      break;
+ 	    }
+ 
+ 	  /*process characters up to the next ':' , ',' or ')'  */
+ 
+ 	  for (;;)
+ 	    {
+ 	      c = next_char ();
+ 	      switch (c)
+ 		{
+ 		case ',': case ':':case ')':
+ 		  if ( (c==',' && dim == rank -1)
+ 		    || (c==')' && dim  < rank -1))
+ 		    {
+ 		      st_sprintf (parse_err_msg,
+ 				  "Bad number of index fields");
+ 		      goto err_ret;
+ 		    }
+ 		  break;
+ 		CASE_DIGITS:
+ 		  push_char (c);
+ 		  continue;
+ 		case ' ': case '\t':
+ 		  eat_spaces ();
+ 		  c = next_char ();
+ 		  break;
+ 		default:
+ 		  st_sprintf (parse_err_msg, "Bad character in index");
+ 		  goto err_ret;
+ 		}
+ 	      if (( c==',' || c==')') && indx==0 && saved_string == 0 )
+ 		{
+ 		  st_sprintf (parse_err_msg, "Null index field");
+ 		  goto err_ret;
+ 		}
+ 	      if (( c==':' && indx==1 && saved_string == 0) ||
+ 		  (indx==2 && saved_string == 0))
+ 		{
+ 		  st_sprintf(parse_err_msg, "Bad index triplet");
+ 		  goto err_ret;
+ 		}
+ 
+ 	      /* If '( : ? )' or '( ? : )' break and flag read failure.  */
+ 
+ 	      null_flag = 0;
+ 	      if ((c==':'  && indx==0 && saved_string == 0) ||
+ 		  (indx==1 && saved_string == 0))
+ 		{
+ 		  null_flag = 1;
+ 		  break;
+ 		}
+ 
+ 	      /* Now read the index.  */
+ 
+ 	      if (convert_integer (sizeof(int),neg))
+ 		{
+ 		  st_sprintf (parse_err_msg, "Bad integer in index");
+ 		  goto err_ret;
+ 		}
+ 	      break;
+ 	    }
+ 
+ 	  /*feed the index values to the triplet arrays.  */
+ 
+ 	  if (!null_flag)
+ 	    {
+ 	      if (indx == 0)
+ 		ls[dim].start = *(int *)value;
+ 	      if (indx == 1)
+ 		ls[dim].end   = *(int *)value;
+ 	      if (indx == 2)
+ 		ls[dim].step  = *(int *)value;
+ 	    }
+ 
+ 	  /*singlet or doublet indices  */
+ 
+ 	  if (c==',' || c==')')
+ 	    {
+ 	      if (indx == 0)
+ 		{
+ 		  ls[dim].start = *(int *)value;
+ 		  ls[dim].end = *(int *)value;
+ 		}
+ 	      break;
+ 	    }
+ 	}
+ 
+       /*Check the values of the triplet indices.  */
+ 
+       if ((ls[dim].start > ad[dim].ubound) ||
+ 	  (ls[dim].start < ad[dim].lbound) ||
+ 	  (ls[dim].end   > ad[dim].ubound) ||
+ 	  (ls[dim].end   < ad[dim].lbound))
+ 	{
+ 	  st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
+ 	  goto err_ret;
+ 	}
+       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0) ||
+ 	  (ls[dim].step == 0))
+ 	{
+ 	  st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
+ 	  goto err_ret;
+ 	}
+ 
+       /* Initialise the loop index counter.  */
+ 
+       ls[dim].idx = ls[dim].start;
+ 
+     }
+   eat_spaces ();
+   return SUCCESS;
+ err_ret:
+   return FAILURE;
+ }
+ 
  static namelist_info *
  find_nml_node (char * var_name)
  {
*************** find_nml_node (char * var_name)
*** 1388,1394 ****
       {
         if (strcmp (var_name,t->var_name) == 0)
           {
!            t->value_acquired = 1;
             return t;
           }
         t = t->next;
--- 1625,1631 ----
       {
         if (strcmp (var_name,t->var_name) == 0)
           {
! 	  t->touched = 1;
             return t;
           }
         t = t->next;
*************** find_nml_node (char * var_name)
*** 1396,1563 ****
    return NULL;
  }
  
  static void
! match_namelist_name (char *name, int len)
  {
!   int name_len;
!   char c;
!   char * namelist_name = name;
  
!   name_len = 0;
!   /* Match the name of the namelist.  */
  
!   if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
      {
!     wrong_name:
!       generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
        return;
      }
  
!   while (name_len < len)
      {
        c = next_char ();
!       if (tolower (c) != tolower (namelist_name[name_len++]))
!         goto wrong_name;
      }
  }
  
  
! /********************************************************************
!       Namelist reads
! ********************************************************************/
! 
! /* Process a namelist read.  This subroutine initializes things,
!    positions to the first element and 
!    FIXME: was this comment ever complete?  */
! 
! void
! namelist_read (void)
  {
!   char c;
!   int name_matched, next_name ;
    namelist_info * nl;
!   int len, m;
!   void * p;
  
!   namelist_mode = 1;
  
!   if (setjmp (g.eof_jump))
      {
!       generate_error (ERROR_END, NULL);
!       return;
!     }
  
!  restart:
!   c = next_char ();
!   switch (c)
      {
-     case ' ':
-       goto restart;
-     case '!':
-       do
-         c = next_char ();
-       while (c != '\n');
  
!       goto restart;
  
!     case '&':
!       break;
  
!     default:
!       generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
!       return;
      }
  
!   /* Match the name of the namelist.  */
!   match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
  
!   /* Ready to read namelist elements.  */
!   while (!input_complete)
!     {
!       c = next_char ();
!       switch (c)
          {
!         case '/':
!           input_complete = 1;
!           next_record (0);
            break;
!         case '&':
!           match_namelist_name("end",3);
!           return;
!         case '\\':
!           return;
!         case ' ':
!         case '\n':
!        case '\r':
!         case '\t':
            break;
!         case ',':
!           next_name = 1;
            break;
  
!         case '=':
!           name_matched = 1;
!           nl = find_nml_node (saved_string);
!           if (nl == NULL)
!             internal_error ("Can not match a namelist variable");
!           free_saved();
  
!           len = nl->len;
!           p = nl->mem_pos;
  
!           /* skip any blanks or tabs after the = */
!           eat_spaces ();
   
            switch (nl->type)
              {
!             case BT_INTEGER:
                read_integer (len);
                break;
!             case BT_LOGICAL:
                read_logical (len);
                break;
!             case BT_CHARACTER:
                read_character (len);
                break;
!             case BT_REAL:
                read_real (len);
                break;
!             case BT_COMPLEX:
                read_complex (len);
                break;
              default:
!               internal_error ("Bad type for namelist read");
              }
  
             switch (saved_type)
              {
              case BT_COMPLEX:
-               len = 2 * len;
-               /* Fall through...  */
- 
-             case BT_INTEGER:
              case BT_REAL:
              case BT_LOGICAL:
!               memcpy (p, value, len);
                break;
- 
              case BT_CHARACTER:
!               m = (len < saved_used) ? len : saved_used;
!               memcpy (p, saved_string, m);
! 
!               if (m < len)
!                 memset (((char *) p) + m, ' ', len - m);
                break;
! 
!             case BT_NULL:
                break;
              }
  
            break;
  
          default :
            push_char(tolower(c));
            break;
          }
     }
  }
--- 1633,2275 ----
    return NULL;
  }
  
+ /* Visits all the components of a derived type that have
+    not explicitly been identified in the namelist input.
+    touched is set and the loop specification initialised 
+    to default values  */
+ 
  static void
! nml_touch_nodes (namelist_info * nl)
  {
!   int len = strlen (nl->var_name) + 1;
!   int dim;
!   char * ext_name = (char*)get_mem (len + 1);
!   strcpy (ext_name, nl->var_name);
!   strcat (ext_name, "%");
!   for (nl = nl->next; nl; nl = nl->next)
!     {
!       if (strncmp (nl->var_name, ext_name, len) == 0)
! 	{
! 	  nl->touched = 1;
! 	  for (dim=0; dim < nl->var_rank; dim++)
! 	    {
! 	      nl->ls[dim].step = 1;
! 	      nl->ls[dim].end = nl->dim[dim].ubound;
! 	      nl->ls[dim].start = nl->dim[dim].lbound;
! 	      nl->ls[dim].idx = nl->ls[dim].start;
! 	    }
! 	}
!       else
! 	break;
!     }
!   return;
! }
  
! /* Resets touched for the entire list of nml_nodes, ready for a
!    new object.  */
  
! static void
! nml_untouch_nodes (void)
      {
!   namelist_info * t;
!   for (t = ionml; t; t = t->next)
!     t->touched = 0;
        return;
      }
  
! /* Attempts to input name to namelist name.  Returns nml_read_error = 1
!    on no match.  */
! 
! static void
! nml_match_name (char *name, int len)
! {
!   int i;
!   char c;
!   nml_read_error = 0;
!   for (i = 0; i < len; i++)
      {
        c = next_char ();
!       if (tolower (c) != tolower (name[i]))
! 	{
! 	  nml_read_error = 1;
! 	  break;
! 	}
      }
  }
  
+ /* If the namelist read is from stdin, output the current state of the
+    namelist to stdout.  This is used to implement the non-standard query
+    features, ? and =?. If c == '=' the full namelist is printed. Otherwise
+    the names alone are printed.  */
  
! static void
! nml_query (char c)
  {
!   gfc_unit * temp_unit;
    namelist_info * nl;
!   int len;
!   char * p;
  
!   if (current_unit->unit_number != options.stdin_unit)
!     return;
  
!   /* Store the current unit and transfer to stdout.  */
! 
!   temp_unit = current_unit;
!   current_unit = find_unit (options.stdout_unit);
! 
!   if (current_unit)
      {
!       g.mode =WRITING;
!       next_record (0);
  
!       /* Write the namelist in its entirety.  */
! 
!       if (c == '=')
! 	namelist_write ();
! 
!       /* Or write the list of names.  */
! 
!       else
      {
  
! 	  /* "&namelist_name\n"  */
  
! 	  len = ioparm.namelist_name_len;
! 	  p = write_block (len + 2);
! 	  if (!p)
! 	    goto query_return;
! 	  memcpy (p, "&", 1);
! 	  memcpy ((char*)(p + 1), ioparm.namelist_name, len);
! 	  memcpy ((char*)(p + len + 1), "\n", 1);
! 	  for (nl =ionml; nl; nl = nl->next)
! 	    {
  
! 	      /* " var_name\n"  */
! 
! 	      len = strlen (nl->var_name);
! 	      p = write_block (len + 2);
! 	      memcpy (p, " ", 1);
! 	      memcpy ((char*)(p + 1), nl->var_name, len);
! 	      memcpy ((char*)(p + len + 1), "\n", 1);
      }
  
! 	  /* "&end\n"  */
  
! 	  p = write_block (5);
! 	  memcpy (p, "&end\n", 5);
! 	}
! 
!       /* Flush the stream to force immediate output.  */
! 
!       flush (current_unit->s);
!     }
! 
! query_return:
! 
!   /* Restore the current unit.  */
! 
!   current_unit = temp_unit;
!   g.mode = READING;
!   return;
! }
! 
! /* Reads and stores the input for the namelist object nl.  For an array,
!    the function loops over the ranges defined by the loop specification.
!    This default to all the data or to the specification from a qualifier.
!    nml_read_obj recursively calls itself to read derived types. It visits
!    all its own components but only reads data for those that were touched
!    when the name was parsed.  If a read error is encountered, an attempt is
!    made to return to read a new object name because the standard allows too
!    little data to be available.  On the other hand, too much data is an
!    error.  */
! 
! static try
! nml_read_obj (namelist_info * nl, index_type offset)
! {
! 
!   namelist_info * cmp;
!   char * obj_name;
!   int dlen, len, m, dim, obj_name_len;
!   int nml_carry;
!   void * pdata ;
! 
!   /* This object not touched in name parsing.  */
! 
!   if (!nl->touched)
!     return SUCCESS;
! 
!   repeat_count = 0;
!   eat_spaces();
! 
!   len = nl->len;
!   switch (nl->type)
          {
!     case GFC_DTYPE_INTEGER:
!     case GFC_DTYPE_LOGICAL:
!     case GFC_DTYPE_REAL:
!       dlen = len;
            break;
!     case GFC_DTYPE_COMPLEX:
!       dlen = 2* len;
            break;
!     case GFC_DTYPE_CHARACTER:
!       dlen = chigh? (chigh - clow + 1): nl->string_length;
            break;
+     default:
+       dlen = 0;
+     }
+ 
+   do
+     {
  
!       /* Update the pointer to the data, using the current index vector  */
  
!       pdata = (void*)(nl->mem_pos + offset);
!       for (dim = 0; dim < nl->var_rank; dim++)
! 	pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
! 		 nl->dim[dim].stride * nl->size);
! 
!       /* Reset the error flag and try to read next value, if 
! 	 repeat_count=0  */
! 
!       nml_read_error = 0;
!       nml_carry = 0;
!       if (--repeat_count <= 0)
! 	{
! 	  if (input_complete) return SUCCESS;
! 	  if ( at_eol )
! 	    finish_separator ();
! 	  if (input_complete) return SUCCESS;
  
! 	  saved_type = GFC_DTYPE_UNKNOWN;   /* falls thru' for nulls */
! 	  free_saved ();
   
            switch (nl->type)
              {
! 	  case GFC_DTYPE_INTEGER:
                read_integer (len);
                break;
! 	  case GFC_DTYPE_LOGICAL:
                read_logical (len);
                break;
! 	  case GFC_DTYPE_CHARACTER:
                read_character (len);
                break;
! 	  case GFC_DTYPE_REAL:
                read_real (len);
                break;
! 	  case GFC_DTYPE_COMPLEX:
                read_complex (len);
                break;
+ 	  case GFC_DTYPE_DERIVED:
+ 	    obj_name_len = strlen (nl->var_name) + 1;
+ 	    obj_name = get_mem (obj_name_len+1);
+ 	    strcpy (obj_name, nl->var_name);
+ 	    strcat (obj_name, "%");
+ 
+ 	    /* Now loop over the components. Update the component pointer
+ 	       with the return value from nml_write_obj.  This loop jumps
+ 	       past nested derived types by testing if the potential 
+ 	       component name contains '%'.  */
+ 
+ 	    for (cmp = nl->next;
+ 		 cmp &&
+ 		   !strncmp (cmp->var_name, obj_name, obj_name_len) &&
+ 		   !strchr (cmp->var_name + obj_name_len, '%');
+ 		 cmp = cmp->next)
+ 	      {
+ 		if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
+ 		  return FAILURE;
+ 		if (input_complete)
+ 		  return SUCCESS;
+ 	      }
+ 
+ 	    free_mem (obj_name);
+ 	    goto incr_idx;
              default:
! 	    st_sprintf (nml_err_msg, "Bad type for namelist object %s",
! 			nl->var_name );
! 	    internal_error (nml_err_msg);
! 	    goto nml_err_ret;
!           }
              }
  
+       /* The standard permits array data to stop short of the number of
+ 	 elements specified in the loop specification.  In this case, we
+ 	 should be here with nml_read_error != 0.  Control returns to 
+ 	 nml_get_obj_data and an attempt is made to read object name.  */
+ 
+       prev_nl = nl;
+       if (nml_read_error)
+ 	return SUCCESS;
+ 
+       if (saved_type == GFC_DTYPE_UNKNOWN)
+ 	goto incr_idx;
+ 
+ 
+       /* Note the switch from GFC_DTYPE_type to BT_type at this point.
+ 	 This comes about because the read functions return BT_types.  */
+ 
             switch (saved_type)
              {
              case BT_COMPLEX:
              case BT_REAL:
+ 	case BT_INTEGER:
              case BT_LOGICAL:
! 	  memcpy (pdata, value, dlen);
                break;
              case BT_CHARACTER:
! 	  m = (dlen < saved_used) ? dlen : saved_used;
! 	  pdata = (void*)( pdata + clow - 1 );
! 	  memcpy (pdata, saved_string, m);
! 	  if (m < dlen)
! 	    memset ((void*)( pdata + m ), ' ', dlen - m);
                break;
! 	default:
                break;
              }
  
+       /* Break out of loop if scalar.  */
+ 
+       if (!nl->var_rank)
            break;
  
+       /* Now increment the index vector.  */
+ 
+ incr_idx:
+       nml_carry = 1;
+       for (dim = 0; dim < nl->var_rank; dim++)
+         {
+ 	  nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
+ 	  nml_carry = 0;
+ 	  if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
+ 	      ||
+ 	      ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
+ 	    {
+ 	      nl->ls[dim].idx = nl->ls[dim].start;
+ 	      nml_carry = 1;
+ 	    }
+         }
+     } while (!nml_carry);
+ 
+   if (repeat_count > 1)
+     {
+        st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
+ 		   nl->var_name );
+        goto nml_err_ret;
+     }
+   return SUCCESS;
+ nml_err_ret:
+   return FAILURE;
+ }
+ 
+ /* Parses the object name, including array and substring qualifiers.  It
+    iterates over derived type components, touching those components and
+    setting their loop specifications, if there is a qualifier.  If the
+    object is itself a derived type, its components and subcomponents are
+    touched.  nml_read_obj is called at the end and this reads the data in
+    the manner specified by the object name.  */
+ 
+ static try
+ nml_get_obj_data (void)
+ {
+   char c;
+   char * ext_name;
+   namelist_info * nl;
+   namelist_info * first_nl;
+   namelist_info * root_nl;
+   int dim;
+   int len;
+   int component_flag;
+ 
+   /* Look for end of input or object name.  If '?' or '=?' are encountered
+      in stdin, print the node names or the namelist to stdout. */
+ 
+   eat_separator ();
+   if (input_complete) return SUCCESS;
+ 
+   if ( at_eol )
+     finish_separator ();
+   if (input_complete) return SUCCESS;
+ 
+   c = next_char ();
+   switch (c)
+     {
+     case '=':
+       c = next_char ();
+       if (c != '?')
+ 	{
+ 	  st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
+ 	  goto nml_err_ret;
+ 	}
+       nml_query ('=');
+       return SUCCESS;
+     case '?':
+       nml_query ('?');
+       return SUCCESS;
+     case '$':
+     case '&':
+       nml_match_name ("end", 3);
+       if (nml_read_error)
+ 	{
+ 	  st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
+ 	  goto nml_err_ret;
+ 	}
+     case '/':
+       input_complete = 1;
+       return SUCCESS;
          default :
+       break;
+     }
+ 
+   /* Untouch all nodes of the namelist and reset the flag that is set for
+      derived type components.  */
+ 
+   nml_untouch_nodes();
+   component_flag = 0;
+ 
+   /* Get the object name - should '!' and '\n' be permitted separators?  */
+ 
+ get_name:
+ 
+   free_saved ();
+ 
+   do
+     {
            push_char(tolower(c));
+       c = next_char ();
+     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
+   unget_char (c);
+ 
+   /* Check that the name is in the namelist and get pointer to object.
+      Three error conditions exist: (i) An attempt is being made to
+      identify a non-existent object, following a failed data read or
+      (ii) The object name does not exist or (iii) Too many data items
+      are present for an object.  (iii) gives the same error message
+      as (i)  */
+ 
+   push_char ('\0');
+ 
+   if (component_flag)
+     {
+       ext_name = (char*)get_mem (strlen (root_nl->var_name) +
+ 		  saved_string? strlen (saved_string): 0 + 1);
+       strcpy (ext_name, root_nl->var_name);
+       strcat (ext_name, saved_string);
+       nl = find_nml_node (ext_name);
+     }
+   else
+     nl = find_nml_node (saved_string);
+ 
+   if (nl == NULL)
+     {
+       if (nml_read_error && prev_nl)
+ 	st_sprintf (nml_err_msg, "Bad data for namelist object %s",
+ 		    prev_nl->var_name);
+       else
+ 	st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
+ 		    saved_string);
+       goto nml_err_ret;
+     }
+ 
+   /* Get the length, data length, base pointer and rank of the variable.
+      Set the default loop specification first.  */
+ 
+   for (dim=0; dim < nl->var_rank; dim++)
+     {
+       nl->ls[dim].step = 1;
+       nl->ls[dim].end = nl->dim[dim].ubound;
+       nl->ls[dim].start = nl->dim[dim].lbound;
+       nl->ls[dim].idx = nl->ls[dim].start;
+     }
+ 
+ /* Check to see if there is a qualifier: if so, parse it.*/
+ 
+   if ( c == '(' && nl->var_rank )
+     {
+       if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
+ 	{
+ 	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+ 		      parse_err_msg, nl->var_name);
+ 	  goto nml_err_ret;
+ 	}
+       c = next_char ();
+       unget_char (c);
+     }
+ 
+   /* Now parse a derived type component. The root namelist_info address
+      is backed up, as is the previous component level.  The  component flag
+      is set and the iteration is made by jumping back to get_name.  */
+ 
+   if (c == '%')
+     {
+ 
+       if (nl->type != GFC_DTYPE_DERIVED)
+ 	{
+ 	  st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
+ 		      nl->var_name);
+ 	  goto nml_err_ret;
+ 	}
+ 
+       if (!component_flag)
+ 	first_nl = nl;
+ 
+       root_nl = nl;
+       component_flag = 1;
+       c = next_char ();
+       goto get_name;
+ 
+     }
+ 
+   /* Parse a character qualifier, if present.  chigh = 0 is a default
+      that signals that the string length = string_length.  */
+ 
+   clow = 1;
+   chigh = 0;
+ 
+   if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
+     {
+       descriptor_dimension chd[1] = {1, clow, nl->string_length};
+       nml_loop_spec ind[1] = {1, clow, nl->string_length, 1};
+ 
+       if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
+ 	{
+ 	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+ 		      parse_err_msg, nl->var_name);
+ 	  goto nml_err_ret;
+ 	}
+ 
+       clow = ind[0].start;
+       chigh = ind[0].end;
+ 
+       if (ind[0].step != 1)
+ 	{
+ 	  st_sprintf (nml_err_msg,
+ 		      "Bad step in substring for namelist object %s",
+ 		      nl->var_name);
+ 	  goto nml_err_ret;
+ 	}
+ 
+       c = next_char ();
+       unget_char (c);
+     }
+ 
+   /* If a derived type touch its components and restore the root
+      namelist_info if we have parsed a qualified derived type
+      component.  */
+ 
+   if (nl->type == GFC_DTYPE_DERIVED)
+     nml_touch_nodes (nl);
+   if (component_flag)
+     nl = first_nl;
+ 
+   /*make sure no extraneous qualifiers are there.*/
+ 
+   if (c == '(')
+     {
+       st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
+ 		  " namelist object %s", nl->var_name);
+       goto nml_err_ret;
+     }
+ 
+ /* According to the standard, an equal sign MUST follow an object name. The
+    following is possibly lax - it allows comments, blank lines and so on to
+    intervene.  eat_spaces (); c = next_char (); would be compliant*/
+ 
+   free_saved ();
+ 
+   eat_separator ();
+   if (input_complete)
+     return SUCCESS;
+ 
+   if ( at_eol )
+     finish_separator ();
+   if (input_complete)
+     return SUCCESS;
+ 
+   c = next_char ();
+ 
+   if (c != '=')
+     {
+       st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
+ 		 nl->var_name);
+       goto nml_err_ret;
+     }
+ 
+   if (nml_read_obj (nl, 0) == FAILURE)
+     goto nml_err_ret;
+   return SUCCESS;
+ 
+ nml_err_ret:
+   return FAILURE;
+ }
+ 
+ /* Entry point for namelist input.  Goes through input until namelist name
+   is matched.  Then cycles through nml_get_obj_data until the input is
+   completed or there is an error.  */
+ 
+ void
+ namelist_read (void)
+ {
+   char c;
+ 
+   namelist_mode = 1;
+   input_complete = 0;
+ 
+   if (setjmp (g.eof_jump))
+     {
+       generate_error (ERROR_END, NULL);
+       return;
+     }
+ 
+   /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
+      Exit on success or EOF. If '?' or '=?' encountered in stdin, print
+      node names or namelist on stdout.  */
+ 
+ find_nml_name:
+   switch (c = next_char ())
+     {
+     case '$':
+     case '&':
            break;
+     case '=':
+       c = next_char ();
+       if (c == '?')
+ 	nml_query ('=');
+       else
+ 	unget_char (c);
+       goto find_nml_name;
+     case '?':
+       nml_query ('?');
+     default:
+       goto find_nml_name;
+     }
+ 
+   /* Match the name of the namelist.  */
+ 
+   nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
+   if (nml_read_error)
+     goto find_nml_name;
+ 
+   /* Ready to read namelist objects.  If there is an error in input
+      from stdin, output the error message and continue.  */
+ 
+   while (!input_complete)
+     {
+       if (nml_get_obj_data ()  == FAILURE)
+ 	{
+ 	  if (current_unit->unit_number != options.stdin_unit)
+ 	    goto nml_err_ret;
+ 	  st_printf ("%s\n", nml_err_msg);
+ 	  flush (find_unit (options.stderr_unit)->s);
          }
     }
+   return;
+ 
+   /* All namelist error calls return from here */
+ 
+ nml_err_ret:
+   generate_error (ERROR_READ_VALUE , nml_err_msg);
+   return;
  }
Index: lock.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/lock.c,v
retrieving revision 1.5
diff -p -c -3 -r1.5 lock.c
*** lock.c	12 Jan 2005 21:27:31 -0000	1.5
--- lock.c	7 Apr 2005 14:10:31 -0000
***************
*** 1,5 ****
  /* Thread/recursion locking
!    Copyright 2002 Free Software Foundation, Inc.
     Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
  
  This file is part of the GNU Fortran 95 runtime library (libgfortran).
--- 1,5 ----
  /* Thread/recursion locking
!    Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
     Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
  
  This file is part of the GNU Fortran 95 runtime library (libgfortran).
*************** library_end (void)
*** 74,89 ****
    filename = NULL;
    line = 0;
  
    t = ioparm.library_return;
    if (ionml != NULL)
      {
        t1 = ionml;
        while (t1 != NULL)
!        {
!          t2 = t1;
!          t1 = t1->next;
!          free_mem (t2);
!        }
      }
    
    ionml = NULL;
--- 74,96 ----
    filename = NULL;
    line = 0;
  
+ 
    t = ioparm.library_return;
    if (ionml != NULL)
      {
        t1 = ionml;
        while (t1 != NULL)
! 	{
! 	  t2 = t1;
! 	  t1 = t1->next;
! 	  free_mem (t2->var_name);
! 	  if (t2->var_rank)
! 	    {
! 	     free_mem (t2->dim);
! 	     free_mem (t2->ls);
! 	    }
! 	  free_mem (t2);
! 	}
      }
    
    ionml = NULL;
Index: transfer.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.34
diff -p -c -3 -r1.34 transfer.c
*** transfer.c	31 Mar 2005 15:30:06 -0000	1.34
--- transfer.c	7 Apr 2005 14:10:31 -0000
***************
*** 1,5 ****
--- 1,6 ----
  /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
     Contributed by Andy Vaught
+    Namelist transfer functions contributed by Paul Thomas
  
  This file is part of the GNU Fortran 95 runtime library (libgfortran).
  
*************** st_write_done (void)
*** 1587,1617 ****
    library_end ();
  }
  
! 
! static void
! st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
!                 int kind, bt type, int string_length)
  {
!   namelist_info *t1 = NULL, *t2 = NULL;
!   namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
    nml->mem_pos = var_addr;
!   if (var_name)
!     {
!       assert (var_name_len > 0);
!       nml->var_name = (char*) get_mem (var_name_len+1);
!       strncpy (nml->var_name, var_name, var_name_len);
!       nml->var_name[var_name_len] = 0;
      }
    else
      {
!       assert (var_name_len == 0);
!       nml->var_name = NULL;
      }
  
-   nml->len = kind;
-   nml->type = type;
-   nml->string_length = string_length;
- 
    nml->next = NULL;
  
    if (ionml == NULL)
--- 1588,1624 ----
    library_end ();
  }
  
! void
! st_set_nml_var (void * var_addr, char * var_name,
! 		index_type ia1, index_type ia2, index_type ia3)
  {
!   namelist_info *t1 = NULL, *t2 = NULL, * nml;
! 
!   nml = (namelist_info *) get_mem (sizeof (namelist_info));
    nml->mem_pos = var_addr;
! 
!   nml->var_name = (char*) get_mem (strlen (var_name) + 1);
!   strcpy (nml->var_name, var_name);
! 
!   nml->len = ia1;
!   nml->string_length = ia2;
!   nml->var_rank = ia3 & GFC_DTYPE_RANK_MASK;
!   nml->size = ia3 >> GFC_DTYPE_SIZE_SHIFT;
!   nml->type =(ia3 & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT;
! 
!   if (nml->var_rank > 0)
!     {
!       nml->dim = (descriptor_dimension*)get_mem (nml->var_rank *
! 		 sizeof(descriptor_dimension));
!       nml->ls = (nml_loop_spec*)get_mem (nml->var_rank *
! 		 sizeof(nml_loop_spec));
      }
    else
      {
!       nml->dim = NULL;
!       nml->ls = NULL;
      }
  
    nml->next = NULL;
  
    if (ionml == NULL)
*************** st_set_nml_var (void * var_addr, char * 
*** 1626,1680 ****
         }
         t2->next = nml;
      }
  }
  
- extern void st_set_nml_var_int (void *, char *, int, int);
- export_proto(st_set_nml_var_int);
- 
- extern void st_set_nml_var_float (void *, char *, int, int);
- export_proto(st_set_nml_var_float);
- 
- extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
- export_proto(st_set_nml_var_char);
- 
- extern void st_set_nml_var_complex (void *, char *, int, int);
- export_proto(st_set_nml_var_complex);
- 
- extern void st_set_nml_var_log (void *, char *, int, int);
- export_proto(st_set_nml_var_log);
- 
  void
! st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
! 		    int kind)
  {
!   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
! }
  
! void
! st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
! 		      int kind)
! {
!   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL, 0);
  }
  
! void
! st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
! 		     int kind, gfc_charlen_type string_length)
! {
!   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
! 		  string_length);
! }
  
- void
- st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
- 			int kind)
- {
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX, 0);
- }
  
- void
- st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
- 		    int kind)
- {
-    st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL, 0);
- }
--- 1633,1664 ----
         }
         t2->next = nml;
      }
+   return;
  }
  
  void
! st_set_nml_var_dim (index_type n_dim, index_type ia1,
! 		     index_type ia2, index_type ia3)
  {
!   namelist_info *t1 = NULL, * nml;
!   t1 = ionml;
!   while ( t1 != NULL )
!     {
!       nml = t1;
!       t1 = t1->next;
!     }
  
!   nml->dim[n_dim].stride = ia1;
!   nml->dim[n_dim].lbound = ia2;
!   nml->dim[n_dim].ubound = ia3;
  }
  
! extern void st_set_nml_var (void * ,char * ,
! 			    index_type ,index_type ,index_type);
! export_proto(st_set_nml_var);
! 
! extern void st_set_nml_var_dim (index_type, index_type,
! 				index_type ,index_type);
! export_proto(st_set_nml_var_dim);
  
  
Index: write.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/write.c,v
retrieving revision 1.31
diff -p -c -3 -r1.31 write.c
*** write.c	5 Apr 2005 14:20:10 -0000	1.31
--- write.c	7 Apr 2005 14:10:31 -0000
***************
*** 1,5 ****
--- 1,6 ----
  /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
     Contributed by Andy Vaught
+    Namelist output contibuted by Paul Thomas
  
  This file is part of the GNU Fortran 95 runtime library (libgfortran).
  
*************** Boston, MA 02111-1307, USA.  */
*** 29,34 ****
--- 30,36 ----
  
  #include "config.h"
  #include <string.h>
+ #include <ctype.h>
  #include <float.h>
  #include <stdio.h>
  #include <stdlib.h>
*************** typedef enum
*** 44,49 ****
--- 46,53 ----
  sign_t;
  
  
+ static int no_leading_blank = 0 ;
+ 
  void
  write_a (fnode * f, const char *source, int len)
  {
*************** output_float (fnode *f, double value, in
*** 576,582 ****
      leadzero = 0;
  
    /* Padd to full field width.  */
!   if (nblanks > 0)
      {
        memset (out, ' ', nblanks);
        out += nblanks;
--- 580,588 ----
      leadzero = 0;
  
    /* Padd to full field width.  */
! 
! 
!   if ( ( nblanks > 0 ) && !no_leading_blank )
      {
        memset (out, ' ', nblanks);
        out += nblanks;
*************** output_float (fnode *f, double value, in
*** 650,655 ****
--- 656,668 ----
  #endif
        memcpy (out, buffer, edigits);
      }
+ 
+   if ( no_leading_blank )
+     {
+       out += edigits;
+       memset( out , ' ' , nblanks );
+       no_leading_blank = 0;
+     }
  }
  
  
*************** write_int (fnode *f, const char *source,
*** 802,814 ****
        goto done;
      }
  
    memset (p, ' ', nblank);
    p += nblank;
- 
    memset (p, '0', nzero);
    p += nzero;
- 
    memcpy (p, q, digits);
  
   done:
    return;
--- 815,838 ----
        goto done;
      }
  
+ 
+   if (!no_leading_blank)
+     {
    memset (p, ' ', nblank);
    p += nblank;
    memset (p, '0', nzero);
    p += nzero;
    memcpy (p, q, digits);
+     }
+   else
+     {
+       memset (p, '0', nzero);
+       p += nzero;
+       memcpy (p, q, digits);
+       p += digits;
+       memset (p, ' ', nblank);
+       no_leading_blank = 0;
+     }
  
   done:
    return;
*************** write_integer (const char *source, int l
*** 1102,1110 ****
    if(width < digits )
      width = digits ;
    p = write_block (width) ;
! 
    memset(p ,' ', width - digits) ;
    memcpy (p + width - digits, q, digits);
  }
  
  
--- 1126,1141 ----
    if(width < digits )
      width = digits ;
    p = write_block (width) ;
!   if (no_leading_blank)
!     {
!       memcpy (p, q, digits);
!       memset(p + digits ,' ', width - digits) ;
!     }
!   else
!     {
    memset(p ,' ', width - digits) ;
    memcpy (p + width - digits, q, digits);
+     }
  }
  
  
*************** list_formatted_write (bt type, void *p, 
*** 1269,1328 ****
    char_flag = (type == BT_CHARACTER);
  }
  
! void
! namelist_write (void)
! {
!   namelist_info * t1, *t2;
!   int len,num;
!   void * p;
! 
!   num = 0;
!   write_character("&",1);
!   write_character (ioparm.namelist_name, ioparm.namelist_name_len);
!   write_character("\n",1);
! 
!   if (ionml != NULL)
!     {
!       t1 = ionml;
!       while (t1 != NULL)
  	{
!           num ++;
!           t2 = t1;
!           t1 = t1->next;
!           if (t2->var_name)
              {
!               write_character(t2->var_name, strlen(t2->var_name));
!               write_character("=",1);
              }
!           len = t2->len;
!           p = t2->mem_pos;
!           switch (t2->type)
              {
!             case BT_INTEGER:
                write_integer (p, len);
                break;
!             case BT_LOGICAL:
                write_logical (p, len);
                break;
!             case BT_CHARACTER:
!               write_character (p, t2->string_length);
                break;
!             case BT_REAL:
                write_real (p, len);
                break;
!             case BT_COMPLEX:
                write_complex (p, len);
                break;
              default:
                internal_error ("Bad type for namelist write");
              }
! 	  write_character(",",1);
  	  if (num > 5)
  	    {
  	      num = 0;
! 	      write_character("\n",1);
  	    }
  	}
      }
!   write_character("/",1);
  }
--- 1300,1592 ----
    char_flag = (type == BT_CHARACTER);
  }
  
! /* nml_write_obj writes a namelist object to the output stream.  It is called
!    recursively for derived type components:
! 	obj    = is the namelist_info for the current object.
! 	offset = the offset relative to the address held by the object for
! 		 derived type arrays.
! 	base   = is the namelist_info of the derived type, when obj is a
! 		 component.
! 	base_name = the full name for a derived type, including qualifiers
! 		    if any.
!    The returned value is a pointer to the object beyond the last one
!    accessed, including nested derived types.  Notice that the namelist is
!    a linear linked list of objects, including derived types and their
!    components.  A tree, of sorts, is implied by the compound names of
!    the derived type components and this is how this function recurses through
!    the list.  */
! 
! /* A generous estimate of the number of characters needed to print
!    repeat counts and indices, including commas, asterices and brackets.  */
! 
! #define NML_DIGITS 20
! 
! /* Stores the delimiter to be used for character objects.  */
! 
! static char * nml_delim;
! 
! static namelist_info *
! nml_write_obj (namelist_info * obj, index_type offset,
! 	       namelist_info * base, char * base_name)
! {
!   int len, obj_size, num, nelem, dim_i, clen;
!   int nml_carry, elem_ctr, obj_name_len;
!   void * p ;
!   char cup;
!   char * obj_name;
!   char * ext_name;
!   char rep_buff[NML_DIGITS];
!   int rep_ctr;
!   namelist_info * cmp;
!   namelist_info * retval = obj->next;
! 
!   /* Write namelist variable names in upper case. If a derived type,
!      nothing is output.  If a component, base and base_name are set.  */
! 
!   if (obj->type != GFC_DTYPE_DERIVED)
!     {
!       write_character ("\n ", 2);
!       len = 0;
!       if (base)
  	{
! 	  len =strlen (base->var_name);
! 	  for (dim_i = 0; dim_i < strlen (base_name); dim_i++)
              {
! 	      cup = toupper (base_name[dim_i]);
! 	      write_character (&cup, 1);
              }
! 	}
!       for (dim_i =len; dim_i < strlen (obj->var_name); dim_i++)
              {
! 	  cup = toupper (obj->var_name[dim_i]);
! 	  write_character (&cup, 1);
! 	}
!       write_character ("=", 1);
!     }
! 
!   /* Counts the number of data output, including names.  */
! 
!   num = 1;
!   len = obj->len;
!   obj_size = len;
!   if (obj->type == GFC_DTYPE_COMPLEX) obj_size = 2*len;
!   if (obj->type == GFC_DTYPE_CHARACTER) obj_size = obj->string_length;
!   if (obj->var_rank) obj_size = obj->size;
! 
!   nelem = 1;
! 
!   /* Set the index vector and count the number of elements.  */
! 
!   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
!     {
!       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
!       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
!     }
!   rep_ctr = 1;
! 
!   /* Main loop to output the data held in the object.  */
! 
!   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
!     {
! 
!       /* Build the pointer to the data value.  The offset is passed by
! 	 recursive calls to this function for arrays of derived types.
! 	 Is NULL otherwise.  */
! 
!       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
!       p += offset;
! 
!       /* Check for repeat counts of intrinsic types.  */
! 
!       if ((elem_ctr < (nelem - 1)) &&
! 	  (obj->type != GFC_DTYPE_DERIVED) &&
! 	  !memcmp (p, (void*)(p + obj_size ), obj_size ))
! 	{
! 	  rep_ctr++;
! 	}
! 
!       /* Execute a repeated output.  Note the flag no_leading_blank that
! 	 is used in the functions used to output the intrinsic types.  */
! 
!       else
! 	{
! 	  if (rep_ctr > 1)
! 	    {
! 	      st_sprintf(rep_buff, " %d*", rep_ctr);
! 	      write_character (rep_buff, strlen (rep_buff));
! 	      no_leading_blank = 1;
! 	    }
! 	  num++;
! 
! 	  /* Output the data, if an intrinsic type, or recurse into this 
! 	     routine to treat derived types.  */
! 
! 	  switch (obj->type)
! 	    {
! 	    case GFC_DTYPE_INTEGER:
                write_integer (p, len);
                break;
! 	    case GFC_DTYPE_LOGICAL:
                write_logical (p, len);
                break;
! 	    case GFC_DTYPE_CHARACTER:
! 	      if (nml_delim)
! 		write_character (nml_delim, 1);
! 	      write_character (p, obj->string_length);
! 	      if (nml_delim)
! 		write_character (nml_delim, 1);
                break;
! 	    case GFC_DTYPE_REAL:
                write_real (p, len);
                break;
! 	    case GFC_DTYPE_COMPLEX:
! 	      no_leading_blank = 0;
! 	      num++;
                write_complex (p, len);
                break;
+ 	    case GFC_DTYPE_DERIVED:
+ 
+ 	      /* To treat a derived type, we need to build two strings:
+ 		 ext_name = the name, including qualifiers that prepends
+ 			    component names in the output - passed to 
+ 			    nml_write_obj.
+ 		 obj_name = the derived type name with no qualifiers but %
+ 			    appended.  This is used to identify the 
+ 			    components.  */
+ 
+ 	      /* First ext_name => get length of all possible components  */
+ 
+ 	      ext_name = (char*)get_mem ((base_name? strlen (base_name): 0)
+ 					+ (base? strlen (base->var_name): 0)
+ 					+ strlen (obj->var_name)
+ 					+ obj->var_rank * NML_DIGITS);
+ 
+ 	      strcpy(ext_name, base_name? base_name: "");
+ 	      clen = base? strlen (base->var_name): 0;
+ 	      strcat (ext_name, obj->var_name + clen);
+ 
+ 	      /* Append the qualifier. */
+ 
+ 	      for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
+ 		{
+ 		  strcat (ext_name, dim_i? "": "(");
+ 		  clen = strlen (ext_name);
+ 		  st_sprintf (ext_name + clen, "%d", obj->ls[dim_i].idx);
+ 		  strcat (ext_name, (dim_i == obj->var_rank - 1)? ")": ",");
+ 		}
+ 
+ 	      /* Now obj_name */
+ 
+ 	      obj_name_len = strlen (obj->var_name) + 1;
+ 	      obj_name = get_mem (obj_name_len+1);
+ 	      strcpy (obj_name, obj->var_name);
+ 	      strcat (obj_name, "%");
+ 
+ 	      /* Now loop over the components. Update the component pointer
+ 		 with the return value from nml_write_obj => this loop jumps
+ 		 past nested derived types.  */
+ 
+ 	      for (cmp = obj->next;
+ 		   cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
+ 		   cmp = retval)
+ 		{
+ 		  retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
+ 					  obj, ext_name);
+ 		}
+ 
+ 	      free_mem (obj_name);
+ 	      free_mem (ext_name);
+ 	      goto obj_loop;
              default:
                internal_error ("Bad type for namelist write");
              }
! 
! 	  /* Reset the leading blank suppression, write a comma and, if 5
! 	     values have been output, write a newline and advance to column
! 	     2. Reset the repeat counter.  */
! 
! 	  no_leading_blank = 0;
! 	  write_character (",", 1);
  	  if (num > 5)
  	    {
  	      num = 0;
! 	      write_character ("\n ", 2);
  	    }
+ 	  rep_ctr = 1;
+ 	}
+ 
+     /* Cycle through and increment the index vector.  */
+ 
+ obj_loop:
+     nml_carry = 1;
+     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
+       {
+ 	obj->ls[dim_i].idx += nml_carry ;
+ 	nml_carry = 0;
+ 	if (obj->ls[dim_i].idx  > obj->dim[dim_i].ubound)
+ 	  {
+ 	    obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
+ 	    nml_carry = 1;
+ 	  }
+        }
+     }
+ 
+   /* Return a pointer beyond the furthest object accessed.  */
+ 
+   return retval;
+ }
+ 
+ /* This is the entry function for namelist writes.  It outputs the name
+    of the namelist and iterates through the namelist by calls to 
+    nml_write_obj.  The call below has dummys in the arguments used in 
+    the treatment of derived types.  */
+ 
+ void
+ namelist_write (void)
+ {
+   namelist_info * t1, *t2, *dummy = NULL;
+   int i;
+   index_type dummy_offset = 0;
+   char c;
+   char * dummy_name = NULL;
+   unit_delim tmp_delim;
+ 
+   /* Set the delimiter for namelist output.  */
+ 
+   tmp_delim = current_unit->flags.delim;
+   current_unit->flags.delim = DELIM_NONE;
+   switch (tmp_delim)
+     {
+     case (DELIM_QUOTE):
+       nml_delim = "\"";
+       break;
+     case (DELIM_APOSTROPHE):
+       nml_delim = "'";
+       break;
+     default:
+       nml_delim = NULL;
+     }
+ 
+   write_character ("&",1);
+ 
+   /* Write namelist name in upper case - f95 std.  */
+ 
+   for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
+     {
+       c = toupper (ioparm.namelist_name[i]);
+       write_character (&c ,1);
+ 	    }
+ 
+   if (ionml != NULL)
+     {
+       t1 = ionml;
+       while (t1 != NULL)
+ 	{
+ 	  t2 = t1;
+ 	  t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
  	}
      }
!   write_character ("  /\n", 4);
!   current_unit->flags.delim = tmp_delim;
  }
+ #undef NML_DIGITS
c { dg-do run }
c This program tests: namelist comment, a blank line before the nameilist name, the namelist name,
c a scalar qualifier, various combinations of space, comma and lf delimiters, f-formats, e-formats
c a blank line within the data read, nulls, a range qualifier, a new object name before end of data
c and an integer read.  It also tests that namelist output can be re-read by namelist input.
c provided by Paul Thomas - pault@gcc.gnu.org

      program namelist_1

      REAL*4 x(10)
      REAL*8 xx
      integer ier
      namelist /mynml/ x, xx

      do i = 1 , 10
        x(i) = -1
      end do
      x(6) = 6.0
      x(10) = 10.0
      xx = 0d0

      open (10,status="scratch")
      write (10, *) "!mynml"
      write (10, *) ""
      write (10, *) "&gf /"
      write (10, *) "&mynml  x(7) =+99.0e0 x=1.0, 2.0 ,"
      write (10, *) " 2*3.0, ,, 7.0e0,+0.08e+02 !comment"
      write (10, *) ""
      write (10, *) " 9000e-3 x(4:5)=4 ,5 "
      write (10, *) " x=,,3.0, xx=10d0 /"
      rewind (10)

      read (10, nml=mynml, IOSTAT=ier)
      if (ier.ne.0) call abort
      rewind (10)

      do i = 1 , 10
        if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
      end do
      if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort

      write (10, nml=mynml, iostat=ier)
      if (ier.ne.0) call abort
      rewind (10)

      read (10, NML=mynml, IOSTAT=ier)
      if (ier.ne.0) call abort
      close (10)

      do i = 1 , 10
        if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
      end do
      if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort

      end program
c{ dg-do run }
c This program repeats many of the same tests as test_nml_1 but for integer instead of real.
c  It also tests repeat nulls, comma delimited character read, a triplet qualifier, a range with
c and assumed start, a quote delimited string, a qualifier with an assumed end and a fully
c explicit range.  It also tests that integers and characters are successfully read back by
c namelist.
c Provided by Paul Thomas - pault@gcc.gnu.org

      program namelist_2

      integer*4 x(10)
      integer*8 xx
      integer ier
      character*10 ch , check
      namelist /mynml/ x, xx, ch
 
c set debug = 0 or 1 in the namelist! (line 33)

      do i = 1 , 10
        x(i) = -1
      end do
      x(6) = 6
      x(10) = 10
      xx = 0
      ch ="zzzzzzzzzz"
      check="abcdefghij"

      open (10,status="scratch")
      write (10, *) "!mynml"
      write (10, *) " "
      write (10, *) "&mynml  x(7) =+99 x=1, 2 ,"
      write (10, *) " 2*3, ,, 2* !comment"
      write (10, *) " 9 ch=qqqdefghqq , x(8:7:-1) = 8 , 7"
      write (10, *) " ch(:3) =""abc"","
      write (10, *) " ch(9:)='ij' x(4:5)=4 ,5 xx = 42/"
      rewind (10)

      read (10, nml=mynml, IOSTAT=ier)
      if (ier.ne.0) call abort
      rewind (10)

      write (10, nml=mynml, iostat=ier)
      if (ier.ne.0) call abort
      rewind (10)

      read (10, NML=mynml, IOSTAT=ier)
      if (ier.ne.0) call abort
      close (10)

      do i = 1 , 10
        if ( abs( x(i) - i ) .ne. 0 ) call abort ()
        if ( ch(i:i).ne.check(I:I) ) call abort
      end do
      if (xx.ne.42) call abort ()

      end program
!{ dg-do run }
! Tests simple derived types.
! Provided by Paul Thomas - pault@gcc.gnu.org

program namelist_3

  type                        ::      yourtype
    integer, dimension(2)     ::      yi = (/8,9/)
    real, dimension(2)        ::      yx = (/80.,90./)
    character(len=2)          ::      ych = "xx"
  end type yourtype

  type                        ::      mytype
    integer, dimension(2)     ::      myi = (/800,900/)
    real, dimension(2)        ::      myx = (/8000.,9000./)
    character(len=2)          ::      mych = "zz"
    type(yourtype)            ::      my_yourtype
  end type mytype

  type(mytype)                ::      z
  integer                     ::      ier
  integer                     ::      zeros(10)
  namelist /mynml/ zeros, z

  zeros = 0
  zeros(5) = 1

  open(10,status="scratch")
  write (10, nml=mynml, iostat=ier)
  if (ier.ne.0) call abort

  rewind (10)
  read (10, NML=mynml, IOSTAT=ier)
  if (ier.ne.0) call abort
  close (10)

end program namelist_3

!{ dg-do run }
! Tests various combinations of intrinsic types, derived types, arrays,
! dummy arguments and common to check nml_get_addr_expr in trans-io.c.
! See comments below for selection.
! provided by Paul Thomas - pault@gcc.gnu.org

module global
  type             ::  mt
    integer        ::  ii(4)
  end type mt
end module global

program namelist_4
  use global
  common /myc/ cdt
  integer          ::  i(2) = (/101,201/)
  type(mt)         ::  dt(2)
  type(mt)         ::  cdt
  real*8           ::  pi = 3.14159_8
  character*10     ::  chs="singleton"
  character*10     ::  cha(2)=(/"first     ","second    "/)

  dt = mt ((/99,999,9999,99999/))
  cdt = mt ((/-99,-999,-9999,-99999/))
  call foo (i,dt,pi,chs,cha)

contains

  logical function dttest (dt1, dt2)
    use global
    type(mt)       :: dt1
    type(mt)       :: dt2
    dttest = any(dt1%ii == dt2%ii)
  end function dttest


  subroutine foo (i, dt, pi, chs, cha)
    use global
    common /myc/ cdt
    real *8        :: pi                   !local real scalar
    integer        :: i(2)                 !dummy arg. array
    integer        :: j(2) = (/21, 21/)    !equivalenced array
    integer        :: jj                   !    -||-     scalar
    integer        :: ier
    type(mt)       :: dt(2)                !dummy arg., derived array
    type(mt)       :: dtl(2)               !in-scope derived type array
    type(mt)       :: dts                  !in-scope derived type
    type(mt)       :: cdt                  !derived type in common block
    character*10   :: chs                  !dummy arg. character var.
    character*10   :: cha(:)               !dummy arg. character array
    character*10   :: chl="abcdefg"        !in-scope character var.
    equivalence (j,jj)
    namelist /z/     dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha

    dts = mt ((/1, 2, 3, 4/))
    dtl = mt ((/41, 42, 43, 44/))

    open (10, status = "scratch")
    write (10, nml = z, iostat = ier)
    if (ier /= 0 ) call abort()
    rewind (10)

    i = 0
    j = 0
    jj = 0
    pi = 0
    dt  = mt ((/0, 0, 0, 0/))
    dtl = mt ((/0, 0, 0, 0/))
    dts = mt ((/0, 0, 0, 0/))
    cdt = mt ((/0, 0, 0, 0/))
    chs = ""
    cha = ""
    chl = ""

    read (10, nml = z, iostat = ier)
    if (ier /= 0 ) call abort()
    close (10)

    if (.not.(dttest (dt(1),  mt ((/99,999,9999,99999/))) .and.  &
	      dttest (dt(2),  mt ((/99,999,9999,99999/))) .and.  &
	      dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and.     &
	      dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and.     &
	      dttest (dts, mt ((/1, 2, 3, 4/))) .and.            &
	      dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. &
	      all (j ==(/21, 21/)) .and.                         &
	      all (i ==(/101, 201/)) .and.                       &
	      (pi == 3.14159_8) .and.                            &
	      (chs == "singleton") .and.                         &
	      (chl == "abcdefg") .and.                           &
	      (cha(1)(1:10) == "first    ") .and.                &
	      (cha(2)(1:10) == "second    "))) call abort ()

    end subroutine foo
end program namelist_4 
!{ dg-do run }
! Tests arrays of derived types containing derived type arrays whose
! components are character arrays - exercises object name parser in
! list_read.c. Checks that namelist output can be reread. 
! provided by Paul Thomas - pault@gcc.gnu.org

module global
  type             ::  mt
    character(len=2) ::  ch(2) = (/"aa","bb"/)
  end type mt
  type             ::  bt
    integer        ::  i(2) = (/1,2/)
    type(mt)       ::  m(2)
  end type bt
end module global

program namelist_5
  use global
  type(bt)         ::  x(2)

  namelist /mynml/ x

  open (10, status = "scratch")
  write (10, '(A)') "&MYNML"
  write (10, '(A)') " x = 3, 4, 'dd', 'ee', 'ff', 'gg',"
  write (10, '(A)') "     4, 5, 'hh', 'ii', 'jj', 'kk',"
  write (10, '(A)') " x%i = , ,-3, -4"
  write (10, '(A)') " x(2)%m(1)%ch(2) =q,"
  write (10, '(A)') " x(2)%m(2)%ch(1)(1) =w,"
  write (10, '(A)') " x%m%ch(:)(2) =z z z z z z z z,"
  write (10, '(A)') "&end"
   
  rewind (10)
  read (10, nml = mynml, iostat = ier)
  if (ier .ne. 0) call abort () 
  close (10)

  open (10, status = "scratch")
  write (10, nml = mynml)
  rewind (10)
  read (10, nml = mynml, iostat = ier)
  if (ier .ne. 0) call abort () 
  close(10)
  
  if (.not. ((x(1)%i(1) == 3)          .and. &
             (x(1)%i(2) == 4)          .and. &
             (x(1)%m(1)%ch(1) == "dz") .and. &
	     (x(1)%m(1)%ch(2) == "ez") .and. &
             (x(1)%m(2)%ch(1) == "fz") .and. &
	     (x(1)%m(2)%ch(2) == "gz") .and. &
             (x(2)%i(1) == -3)         .and. &
             (x(2)%i(2) == -4)         .and. &
             (x(2)%m(1)%ch(1) == "hz") .and. &
	     (x(2)%m(1)%ch(2) == "qz") .and. &
             (x(2)%m(2)%ch(1) == "wz") .and. &
	     (x(2)%m(2)%ch(2) == "kz"))) call abort ()

end program namelist_5 
!{ dg-do run }
! Tests namelist on complex variables
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_6
  complex(KIND = 8), dimension(2)  ::   z
  namelist /mynml/ z
  z = (/(1.0,2.0), (3.0,4.0)/)
  
  open (10, status = "scratch")
  write (10, '(A)') "&mynml z(1)=(5.,6.) z(2)=(7.,8.) /"
  rewind (10)
  
  read (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  close (10)

  open (10, status = "scratch")
  write (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  rewind (10)

  z = (/(1.0,2.0), (3.0,4.0)/)
  read (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  close (10)
  
  if ((z(1) .ne. (5.0,6.0)) .or. (z(2) .ne. (7.0,8.0))) call abort ()
  
end program namelist_6 
!{ dg-do run }
! Tests namelist on logical variables
! provided by Paul Thomas - pault@gcc.gnu.org

program namelist_7
  logical, dimension(2)        ::   l
  namelist /mynml/ l
  l = (/.true., .false./)
  
  open (10, status = "scratch")
  write (10, '(A)') "&mynml l = F T /"
  rewind (10)
  
  read (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  close (10)

  open (10, status = "scratch")
  write (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  rewind (10)

  l = (/.true., .false./)
  read (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  close (10)
  
  if (l(1) .or. (.not.l(2))) call abort ()
  
end program namelist_7 
!{ dg-do run }
! Tests character delimiters for namelist write 
! provided by Paul Thomas - pault@gcc.gnu.org

program namelist_8
  character*3        ::   ch = "foo"
  character*80       ::   buffer
  namelist /mynml/ ch
  
  open (10, status = "scratch")
  write (10, mynml)
  rewind (10)
  read (10, '(a)', iostat = ier) buffer
  read (10, '(a)', iostat = ier) buffer
  if (ier .ne. 0) call abort ()
  close (10)
  If ((buffer(5:5) /= "f") .or. (buffer(9:9) /= " ")) call abort () 
  
  open (10, status = "scratch", delim ="quote")
  write (10, mynml)
  rewind (10)
  read (10, '(a)', iostat = ier) buffer
  read (10, '(a)', iostat = ier) buffer
  if (ier .ne. 0) call abort ()
  close (10)
  If ((buffer(5:5) /= """") .or. (buffer(9:9) /= """")) call abort ()
  
  open (10, status = "scratch", delim ="apostrophe")
  write (10, mynml)
  rewind (10)
  read (10, '(a)', iostat = ier) buffer
  read (10, '(a)', iostat = ier) buffer
  if (ier .ne. 0) call abort ()
  close (10)
  If ((buffer(5:5) /= "'") .or. (buffer(9:9) /= "'")) call abort ()
  
end program namelist_8
!{ dg-do run }
! Test namelist error trapping.
! provided by Paul Thomas - pault@gcc.gnu.org

program namelist_9
  character*80 wrong, right
  
! "=" before any object name
  wrong = "&z = i = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)
  
! &* instead of &end for termination 
  wrong = "&z i = 1,2 &xxx"
  right = "&z i = 1,2 &end"
  call test_err(wrong, right)
  
! bad data 
  wrong = "&z i = 1,q /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)
  
! object name not matched 
  wrong = "&z j = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! derived type component for intrinsic type
  wrong = "&z i%j = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! step other than 1 for substring qualifier
  wrong = "&z ch(1:2:2) = 'a'/"
  right = "&z ch(1:2) = 'ab' /"
  call test_err(wrong, right)

! qualifier for scalar 
  wrong = "&z k(2) = 1 /"
  right = "&z k    = 1 /"
  call test_err(wrong, right)

! no '=' after object name 
  wrong = "&z i   1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! repeat count too large 
  wrong = "&z i = 3*2 /"
  right = "&z i = 2*2 /"
  call test_err(wrong, right)

! too much data 
  wrong = "&z i = 1 2 3 /"
  right = "&z i = 1 2 /"
  call test_err(wrong, right)

! no '=' after object name 
  wrong = "&z i   1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! bad number of index fields
  wrong = "&z i(1,2) = 1 /"
  right = "&z i(1)   = 1 /"
  call test_err(wrong, right)

! bad character in index field 
  wrong = "&z i(x) = 1 /"
  right = "&z i(1) = 1 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i( ) = 1 /"
  right = "&z i(1) = 1 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i(1::)   = 1 2/"
  right = "&z i(1:2:1) = 1 2 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i(1:2:)  = 1 2/"
  right = "&z i(1:2:1) = 1 2 /"
  call test_err(wrong, right)

! index out of range 
  wrong = "&z i(10) = 1 /"
  right = "&z i(1)  = 1 /"
  call test_err(wrong, right)

! index out of range 
  wrong = "&z i(0:1) = 1 /"
  right = "&z i(1:1) = 1 /"
  call test_err(wrong, right)

! bad range
  wrong = "&z i(1:2:-1) = 1 2 /"
  right = "&z i(1:2: 1) = 1 2 /"
  call test_err(wrong, right)

! bad range
  wrong = "&z i(2:1: 1) = 1 2 /"
  right = "&z i(2:1:-1) = 1 2 /"
  call test_err(wrong, right)

contains
  subroutine test_err(wrong, right)
    character*80 wrong, right
    integer            :: i(2) = (/0, 0/)
    integer            :: k =0
    character*2        :: ch = "  "
    namelist /z/ i, k, ch

! Check that wrong namelist input gives an error

    open (10, status = "scratch")
    write (10, '(A)') wrong
    rewind (10)
    read (10, z, iostat = ier)
    close(10)
    if (ier == 0) call abort ()

! Check that right namelist input gives no error

    open (10, status = "scratch")
    write (10, '(A)') right
    rewind (10)
    read (10, z, iostat = ier)
    close(10)
    if (ier /= 0) call abort ()
  end subroutine test_err
  
end program namelist_9
c { dg-do run }
c pr 12884
c test namelist with input file containg / before namelist. Also checks
c non-standard use of $ instead of &
c Based on example provided by jean-pierre.flament@univ-lille1.fr

      program pr12884
      integer ispher,nosym,runflg,noprop
      namelist /cntrl/ ispher,nosym,runflg,noprop
      ispher = 0
      nosym = 0
      runflg = 0
      noprop = 0 
      open (10, status = "scratch")
      write (10, '(A)') " $FILE"
      write (10, '(A)') "   pseu  dir/file"
      write (10, '(A)') " $END"
      write (10, '(A)') " $cntrl ispher=1,nosym=2,"
      write (10, '(A)') " runflg=3,noprop=4,$END"
      write (10, '(A)')"/"
      rewind (10)
      read (10, cntrl)
      if ((ispher.ne.1).or.(nosym.ne.2).or.(runflg.ne.3).or.
     &  (noprop.ne.4)) call abort ()
      end
! { dg-do run }
! pr 17285
! Test that namelist can read its own output.
! At the same time, check arrays and different terminations
! Based on example provided by paulthomas2@wanadoo.fr

program pr17285
  implicit none
  integer, dimension(10) :: number = 42
  integer                :: ctr, ierr
  namelist /mynml/ number
  open (10, status = "scratch")
  write (10,'(A)') &
    "&mynml number(:)=42,42,42,42,42,42,42,42,42,42,/ "
  write (10,mynml)
  write (10,'(A)') "&mynml number(1:10)=10*42 &end"
  rewind (10)
  do ctr = 1,3
    number = 0
    read (10, nml = mynml, iostat = ierr)
    if ((ierr /= 0) .or. (any (number /= 42))) &
      call abort ()
  end do
  close(10)
end program pr17285
c { dg-do run }
c pr 17472
c test namelist handles arrays
c  Based on example provided by thomas.koenig@online.de

       integer a(10), ctr
       data a / 1,2,3,4,5,6,7,8,9,10 /
       namelist /ints/ a
       do ctr = 1,10
         if (a(ctr).ne.ctr) call abort ()
       end do
       end
! { dg-do run }
! pr 18122
! test namelist read
! Based on example provided by thomas.koenig@online.de

program sechs_w
  implicit none

  integer, parameter :: dr=selected_real_kind(15)

  integer, parameter :: nkmax=6
  real (kind=dr) :: rb(nkmax)
  integer :: z

  real (kind=dr) :: dg
  real (kind=dr) :: a
  real (kind=dr) :: da
  real (kind=dr) :: delta
  real (kind=dr) :: s,t
  integer :: nk
  real (kind=dr) alpha0

  real (kind=dr) :: phi, phi0, rad, rex, zk, z0, drdphi, dzdphi

  namelist /schnecke/ z, dg, a, t, delta, s, nk, rb, alpha0

  open (10,status="scratch")
  write (10, *)  "&SCHNECKE"
  write (10, *)    " z=1,"
  write (10, *)    " dg=58.4,"
  write (10, *)    " a=48.,"
  write (10, *)    " delta=0.4,"
  write (10, *)    " s=0.4,"
  write (10, *)    " nk=6,"
  write (10, *)    " rb=60, 0, 40,"
  write (10, *)    " alpha0=20.,"
  write (10, *)    "/"

  rewind (10)
  read (10,schnecke)
  close (10)
  if ((z /= 1)       .or. (dg /= 58.4_dr)  .or. (a /= 48.0_dr)   .or. &
    (delta /= 0.4_dr).or. (s /= 0.4_dr)    .or. (nk /= 6)        .or. &
    (rb(1) /= 60._dr).or. (rb(2) /= 0.0_dr).or. (rb(3) /=40.0_dr).or. &
    (alpha0 /= 20.0_dr)) call abort ()
end program sechs_w
! { dg-do run }
! Names in upper case and object names starting column 2
! Based on example provided by thomas.koenig@online.de

program pr18210

  real :: a
  character*80 :: buffer
  namelist /foo/ a

  a = 1.4
  open (10, status = "scratch")
  write (10,foo)
  rewind (10)
  read (10, '(a)') buffer
  if (buffer(2:4) /= "FOO") call abort ()
  read (10, '(a)') buffer
  if (buffer(1:2) /= " A") call abort ()
  close (10)

end program pr18210
! { dg-do run }
! pr 18392
! test namelist with derived types
! Based on example provided by thomas.koenig@online.de

program pr18392
  implicit none
  type foo
     integer a
     real b
  end type foo
  type(foo) :: a
  namelist /nl/ a
  open (10, status="scratch")
  write (10,*) " &NL"
  write (10,*) " A%A = 10,"
  write (10,*) "/"
  rewind (10)
  read (10,nl)
  close (10)
  IF (a%a /= 10.0) call abort ()
end program pr18392
! { dg-do run }
! pr 19467
! test namelist with character arrays
! Based on example provided by paulthomas2@wanadoo.fr

program pr19467
  implicit none
  integer             :: ier
  character(len=2)    :: ch(2)
  character(len=2)    :: dh(2)=(/"aa","bb"/)
  namelist /a/ ch
  open (10, status = "scratch")
  write (10, *) "&A ch = 'aa' , 'bb' /"
  rewind (10)
  READ (10,nml=a, iostat = ier)
  close (10)
  if ((ier /= 0) .or. (any (ch /= dh))) call abort ()
end program pr19467
c { dg-do run }
c pr 19657
c test namelist not skipped if ending with logical.
c  Based on example provided by fuyuki@ccsr.u-tokyo.ac.jp

      program pr19657
      implicit none
      logical   l
      integer   i, ctr
      namelist /nm/ i, l
      open (10, status = "scratch")
      write (10,*) "&nm i=1,l=t &end"
      write (10,*) "&nm i=2 &end"
      write (10,*) "&nm i=3 &end"
      rewind (10)
      do ctr = 1,3
        read (10,nm,end=190)
        if (i.ne.ctr) call abort ()
      enddo
 190  continue 
      end

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]