+2005-06-05 Jakub Jelinek <jakub@redhat.com>
+
+ Backport from the mainline:
+ 2005-04-17 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 (gfc_build_io_library_fndecls): Create
+ declaration for st_set_nml_var and st_set_nml_var_dim. Remove
+ declarations of old namelist functions.
+ (build_dt): Simplified call to transfer_namelist_element.
+ (nml_get_addr_expr): Generates address expression for start of
+ object data. New function.
+ (nml_full_name): Qualified name for derived type components. New
+ function.
+ (transfer_namelist_element): Modified for calls to new functions
+ and improved derived type handling.
+
2005-06-05 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/21912
@itemize @minus
@item Formatted sequential ('T' edit descriptor, and others)
-@item Namelist (can read a namelist that it writes, but not free-form)
@end itemize
Not recommended:
@item
Variables for setting fp rounding mode.
-@item
-Support old style namelists ending in $end or &end.
-
@item
Variable to fill uninitialized variables with a user-defined bit
pattern.
@menu
* Old-style kind specifications::
* Old-style variable initialization::
+* Extensions to namelist::
@end menu
@node Old-style kind specifications
DATA i,j,x /1,2,3*0.,1./
@end smallexample
+@node Extensions to namelist
+@section Extensions to namelist
+@cindex Namelist
+
+@command{gfortran} fully supports the fortran95 standard for namelist io
+including array qualifiers, substrings and fully qualified derived types.
+The output from a namelist write is compatible with namelist read. The
+output has all names in upper case and indentation to column 1 after the
+namelist name. Two extensions are permitted:
+
+Old-style use of $ instead of &
+@smallexample
+$MYNML
+ X(:)%Y(2) = 1.0 2.0 3.0
+ CH(1:4) = "abcd"
+$END
+@end smallexample
+
+It should be noticed that the default terminator is / rather than &END.
+
+Querying of the namelist when inputting from stdin. After at least
+one space, entering ? sends to stdout the namelist name and the names of
+the variables in the namelist:
+@smallexample
+?
+
+&mynml
+ x
+ x%y
+ ch
+&end
+@end smallexample
+
+Entering =? outputs the namelist to stdout, as if WRITE (*,NML = mynml)
+had been called:
+@smallexample
+=?
+
+&MYNML
+ X(1)%Y= 0.000000 , 1.000000 , 0.000000 ,
+ X(2)%Y= 0.000000 , 2.000000 , 0.000000 ,
+ X(3)%Y= 0.000000 , 3.000000 , 0.000000 ,
+ CH=abcd, /
+@end smallexample
+
+To aid this dialog, when input is from stdin, errors produce send their
+messages to stderr and execution continues, even if IOSTAT is set.
+
@include intrinsic.texi
@c ---------------------------------------------------------------------
@c Contributing
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;
+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_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")),
+ 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_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);
+ gfc_int4_type_node, gfc_charlen_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);
}
return gfc_finish_block (&block);
}
-
static gfc_expr *
gfc_new_nml_name_expr (const char * name)
{
gfc_expr * nml_name;
+
nml_name = gfc_get_expr();
nml_name->ref = NULL;
nml_name->expr_type = EXPR_CONSTANT;
return nml_name;
}
-static gfc_expr *
-get_new_var_expr(gfc_symbol * sym)
+/* 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)
{
- 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;
+ int full_name_length;
+ char * full_name;
+
+ full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
+ 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;
}
-/* 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:
+/* 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;
+ tree itmp;
+ int array_flagged;
+ int dummy_arg_flagged;
+
+ 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. */
+
+ dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
- &foo bzz=1,2,3,4,5/
+ itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp;
- 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. */
+ /* If an array, set flag and use indirect ref. if built. */
+
+ array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
+ && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
+
+ if (array_flagged)
+ tmp = itmp;
+
+ /* Treat the component of a derived type, using base_addr for
+ the derived type. */
+
+ if (TREE_CODE (decl) == FIELD_DECL)
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ base_addr, tmp, NULL_TREE);
+
+ /* 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. */
+
+ if (array_flagged)
+ tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
+
+ /* Now build the address expression. */
+
+ tmp = gfc_build_addr_expr (NULL, tmp);
+
+ /* If scalar dummy, resolve indirect reference now. */
+
+ if (dummy_arg_flagged && !array_flagged)
+ 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. */
+
+#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)
static void
-transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
- tree string, tree string_length)
+transfer_namelist_element (stmtblock_t * block, const char * var_name,
+ gfc_symbol * sym, gfc_component * c,
+ tree base_addr)
{
- tree tmp, args, arg2;
- tree expr;
+ gfc_typespec * ts = NULL;
+ gfc_array_spec * as = NULL;
+ tree addr_expr = NULL;
+ tree dt = NULL;
+ tree string;
+ tree tmp;
+ tree args;
+ tree dtype;
+ int n_dim;
+ int itype;
+ int rank = 0;
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
+ gcc_assert (sym || c);
- if (ts->type == BT_DERIVED)
- {
- gfc_component *c;
- expr = gfc_build_indirect_ref (addr_expr);
+ /* Build the namelist object name. */
- 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);
+ string = gfc_build_cstring_const (var_name);
+ string = gfc_build_addr_expr (pchar_type_node, string);
- 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;
- }
+ /* Build ts, as and data address using symbol or component. */
- return;
- }
+ ts = (sym) ? &sym->ts : &c->ts;
+ as = (sym) ? sym->as : c->as;
- 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);
+ addr_expr = nml_get_addr_expr (sym, c, base_addr);
- switch (ts->type)
+ if (as)
+ rank = as->rank;
+
+ if (rank)
{
- case BT_INTEGER:
- tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
- break;
+ dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
+ dtype = gfc_get_dtype (dt);
+ }
+ else
+ {
+ itype = GFC_DTYPE_UNKNOWN;
- 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;
+ switch (ts->type)
- case BT_REAL:
- tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
- break;
+ {
+ 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:
+ gcc_unreachable ();
+ }
- case BT_LOGICAL:
- tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
- break;
+ dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
+ }
- case BT_COMPLEX:
- tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
- break;
+ /* Build up the arguments for the transfer call.
+ The call for the scalar part transfers:
+ (address, name, type, kind or string_length, dtype) */
- default :
- internal_error ("Bad namelist IO basetype (%d)", ts->type);
- }
+ NML_FIRST_ARG (addr_expr);
+ NML_ADD_ARG (string);
+ NML_ADD_ARG (IARG (ts->kind));
+
+ if (ts->type == BT_CHARACTER)
+ NML_ADD_ARG (ts->cl->backend_decl);
+ else
+ NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
+ 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 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. */
stmtblock_t block, post_block;
gfc_dt *dt;
tree tmp;
- gfc_expr *nmlname, *nmlvar;
+ gfc_expr *nmlname;
gfc_namelist *nml;
- gfc_se se,se2;
gfc_init_block (&block);
gfc_init_block (&post_block);
if (dt->namelist)
{
- if (dt->format_expr || dt->format_label)
- fatal_error("A format cannot be specified with a namelist");
-
- nmlname = gfc_new_nml_name_expr(dt->namelist->name);
-
- set_string (&block, &post_block, ioparm_namelist_name,
- ioparm_namelist_name_len, nmlname);
-
- if (last_dt == READ)
- 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);
- }
+ if (dt->format_expr || dt->format_label)
+ gfc_internal_error ("build_dt: format with namelist");
+
+ nmlname = gfc_new_nml_name_expr(dt->namelist->name);
+
+ set_string (&block, &post_block, ioparm_namelist_name,
+ ioparm_namelist_name_len, nmlname);
+
+ if (last_dt == READ)
+ 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);
+2005-06-05 Jakub Jelinek <jakub@redhat.com>
+
+ Backport from the mainline:
+ 2005-04-17 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 (gfc_build_io_library_fndecls): Create
+ declaration for st_set_nml_var and st_set_nml_var_dim. Remove
+ declarations of old namelist functions.
+ (build_dt): Simplified call to transfer_namelist_element.
+ (nml_get_addr_expr): Generates address expression for start of
+ object data. New function.
+ (nml_full_name): Qualified name for derived type components. New
+ function.
+ (transfer_namelist_element): Modified for calls to new functions
+ and improved derived type handling.
+
+ 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.f90: Correct comment (PUBLIC and PRIVATE wrong way round).
+ * gfortran.dg/namelist_2.f90: Variables with INTENT(IN) cannot be in namelists. New test
+ * gfortran.dg/namelist_3.f90: Pointers cannot be in namelists. New test
+ * gfortran.dg/namelist_11.f: Tests reals and qualifiers in namelist. New test
+ * gfortran.dg/namelist_12.f: Tests integers and qualifiers in namelist. New test
+ * gfortran.dg/namelist_13.f90: Tests derived types in namelist. New test
+ * gfortran.dg/namelist_14.f90: Tests trans-io.c namelist support. New test
+ * gfortran.dg/namelist_15.f90: Tests arrays of derived types in namelist. New test
+ * gfortran.dg/namelist_16.f90: Tests complex in namelist. New test
+ * gfortran.dg/namelist_17.f90: Tests logical in namelist. New test
+ * gfortran.dg/namelist_18.f90: Tests charcter delimiters in namelist. New test
+ * gfortran.dg/namelist_19.f90: Tests namelist errors. New test
+ * gfortran.dg/namelist_20.f90: Tests negative bounds for explicit arrays. New test
+
2005-06-05 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/21912
! { dg-do compile }
-! Check that public entities in private namelists are rejected
+! Check that private entities in public namelists are rejected
module namelist_1
public
integer,private :: x
namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" }
end module
-
+2005-06-05 Jakub Jelinek <jakub@redhat.com>
+
+ Backport from the mainline:
+ 2005-04-18 Paul Thomas <pault@gcc.gnu.org>
+ Jerry DeLisle <jvdelisle@verizon.net>
+
+ * io/write.c (nml_write_obj): Provide 1 more byte for ext_name.
+ * io/list_read.c (nml_get_obj_data): Put extra brackets in get_mem
+ call for ext_name. These fix the bug reported by Jerry DeLisle to
+ the fortran list and are based on his suggested fix.
+
+ 2005-04-18 Paul Thomas <pault@gcc.gnu.org>
+
+ * io/list_read.c (nml_touch_nodes, nml_read_obj,
+ nml_get_obj_data): Fix memory leaks in code for derived types.
+
+ 2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+ * io/list_read.c (eat_separator): at_eol = 1 replaced
+ (zapped at some time?).
+
+ 2005-04-17 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.
+ (namelist_info): Modify for arrays.
+ * io/list_read.c (namelist_read): Reduced to call to new functions.
+ (match_namelist_name): Simplified.
+ (nml_query): Handles stdin queries ? and =?. New function.
+ (nml_get_obj_data): Parses object name. New function.
+ (touch_nml_nodes): Marks objects for read. New function.
+ (untouch_nml_nodes): Resets objects. New function.
+ (parse_qualifier): Parses and checks qualifiers. New function
+ (nml_read_object): Reads and stores object data. New function.
+ (eat_separator): No new_record on '/' in namelist.
+ (finish_separator): No new_record on '/' in namelist.
+ (read_logical): Error return for namelist.
+ (read_integer): Error return for namelist.
+ (read_complex): Error return for namelist.
+ (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.
+ (st_set_nml_var_dim): Dimension descriptors. New function.
+ * io/write.c (namelist_write): Reduced to call to new functions.
+ (nml_write_obj): Writes output for object. New function.
+ (write_integer): Suppress leading blanks for repeat counts.
+ (write_int): Suppress leading blanks for repeat counts.
+ (write_float): Suppress leading blanks for repeat counts.
+ (output_float): Suppress leading blanks for repeat counts.
+
2005-06-01 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
* Makefile.am (gfor_specific_src): Add 'intrinsics/f2c_intrinsics.F90'
#define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->truncate)(s)
-/* Namelist represent object */
-/*
+/* Representation of a namelist object in libgfortran
+
Namelist Records
- &groupname object=value [,object=value].../
+ &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
or
- &groupname object=value [,object=value]...&groupname
+ &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
+
+ The object can be a fully qualified, compound name for an instrinsic
+ type, derived types or derived type components. So, a substring
+ a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
+ read. Hence full information about the structure of the object has
+ to be available to list_read.c and write.
+
+ These requirements are met by the following data structures.
+
+ nml_loop_spec contains the variables for the loops over index ranges
+ that are encountered. Since the variables can be negative, ssize_t
+ is used. */
+
+typedef struct nml_loop_spec
+{
- 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.
+ /* Index counter for this dimension. */
+ ssize_t idx;
- All these requirements need a new data structure to record all info
- about the namelist.
-*/
+ /* Start for the index counter. */
+ ssize_t start;
+
+ /* End for the index counter. */
+ ssize_t end;
+
+ /* Step for the index counter. */
+ ssize_t step;
+}
+nml_loop_spec;
+
+/* namelist_info type contains all the scalar information about the
+ object and arrays of descriptor_dimension and nml_loop_spec types for
+ arrays. */
typedef struct namelist_type
{
+
+ /* Object type, stored as GFC_DTYPE_xxxx. */
+ bt type;
+
+ /* Object name. */
char * var_name;
+
+ /* Address for the start of the object's data. */
void * mem_pos;
- int value_acquired;
+
+ /* Flag to show that a read is to be attempted for this node. */
+ int touched;
+
+ /* Length of intrinsic type in bytes. */
int len;
- int string_length;
- bt type;
+
+ /* Rank of the object. */
+ int var_rank;
+
+ /* Overall size of the object in bytes. */
+ index_type size;
+
+ /* Length of character string. */
+ index_type string_length;
+
+ descriptor_dimension * dim;
+ nml_loop_spec * ls;
struct namelist_type * next;
}
namelist_info;
-/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+/* 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).
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 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;
+/* A namelist specific flag used in the list directed library
+ to flag that calls are being made from namelist read (eg. to ignore
+ comments or to treat '/' as a terminator) */
+
+static int namelist_mode;
+
+/* A namelist specific flag used in the list directed library to flag
+ read errors and return, so that an attempt can be made to read a
+ new object name. */
+static int nml_read_error;
/* Storage area for values except for strings. Must be large enough
to hold a complex value (two reals) of the largest kind. */
case '/':
input_complete = 1;
- next_record (0);
- at_eol = 1;
+ if (!namelist_mode)
+ {
+ next_record (0);
+ at_eol = 1;
+ }
break;
case '\n':
case '\r':
+ at_eol = 1;
break;
case '!':
case '/':
input_complete = 1;
- next_record (0);
+ if (!namelist_mode) next_record (0);
break;
case '\n':
}
}
+/* 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)
+ {
+ nml_read_error = 1;
+ unget_char(c);
+ return 1;
+ }
+ return 0;
+}
/* 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
return;
bad_logical:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad logical value while reading item %d",
g.item_count);
}
bad_integer:
+
+ if (nml_bad_return (c))
+ return;
+
free_saved ();
st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
return;
bad_complex:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad complex value in item %d of list input",
g.item_count);
return;
bad_real:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad real number in item %d of list input",
g.item_count);
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 index_type clow;
+
+/* Upper index for substring qualifier. */
+
+static index_type chigh;
+
+/* Inputs a rank-dimensional qualifier, which can contain
+ singlets, doublets, triplets or ':' with the standard meanings. */
+
+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;
+ break;
+
+ case '+':
+ break;
+
+ default:
+ unget_char (c);
+ break;
+ }
+
+ /*process characters up to the next ':' , ',' or ')' */
+
+ for (;;)
+ {
+ c = next_char ();
+
+ switch (c)
+ {
+ case ':':
+ break;
+
+ 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 > (ssize_t)ad[dim].ubound)
+ || (ls[dim].start < (ssize_t)ad[dim].lbound)
+ || (ls[dim].end > (ssize_t)ad[dim].ubound)
+ || (ls[dim].end < (ssize_t)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)
{
- namelist_info * t = ionml;
- while (t != NULL)
- {
- if (strcmp (var_name,t->var_name) == 0)
- {
- t->value_acquired = 1;
- return t;
- }
- t = t->next;
- }
+ namelist_info * t = ionml;
+ while (t != NULL)
+ {
+ if (strcmp (var_name,t->var_name) == 0)
+ {
+ t->touched = 1;
+ return t;
+ }
+ t = t->next;
+ }
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
-match_namelist_name (char *name, int len)
+nml_touch_nodes (namelist_info * nl)
{
- 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++]))
+ index_type 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)
{
- wrong_name:
- generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
- return;
+ 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;
}
+ free_mem (ext_name);
+ 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. */
- while (name_len < len)
+static void
+nml_match_name (char *name, index_type len)
+{
+ index_type i;
+ char c;
+ nml_read_error = 0;
+ for (i = 0; i < len; i++)
{
c = next_char ();
- if (tolower (c) != tolower (namelist_name[name_len++]))
- goto wrong_name;
+ 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. */
-/********************************************************************
- 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)
+static void
+nml_query (char c)
{
- char c;
- int name_matched, next_name ;
+ gfc_unit * temp_unit;
namelist_info * nl;
- int len, m;
- void * p;
+ index_type len;
+ char * p;
- namelist_mode = 1;
+ if (current_unit->unit_number != options.stdin_unit)
+ return;
- if (setjmp (g.eof_jump))
+ /* Store the current unit and transfer to stdout. */
+
+ temp_unit = current_unit;
+ current_unit = find_unit (options.stdout_unit);
+
+ if (current_unit)
{
- generate_error (ERROR_END, NULL);
- return;
+ 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);
+ if (!p)
+ goto query_return;
+ memcpy (p, " ", 1);
+ memcpy ((char*)(p + 1), nl->var_name, len);
+ memcpy ((char*)(p + len + 1), "\n", 1);
+ }
+
+ /* "&end\n" */
+
+ p = write_block (5);
+ if (!p)
+ goto query_return;
+ memcpy (p, "&end\n", 5);
+ }
+
+ /* Flush the stream to force immediate output. */
+
+ flush (current_unit->s);
}
- restart:
- c = next_char ();
- switch (c)
- {
- case ' ':
- goto restart;
- case '!':
- do
- c = next_char ();
- while (c != '\n');
+query_return:
- goto restart;
+ /* Restore the current unit. */
- case '&':
+ 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 nml_carry;
+ int len;
+ int dim;
+ index_type dlen;
+ index_type m;
+ index_type obj_name_len;
+ 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:
- generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
- return;
+ dlen = 0;
}
- /* Match the name of the namelist. */
- match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
-
- /* Ready to read namelist elements. */
- while (!input_complete)
+ do
{
- 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();
+ /* Update the pointer to the data, using the current index vector */
- len = nl->len;
- p = nl->mem_pos;
+ 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);
- /* skip any blanks or tabs after the = */
- eat_spaces ();
+ /* 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;
+
+ /* GFC_TYPE_UNKNOWN through for nulls and is detected
+ after the switch block. */
+
+ saved_type = GFC_DTYPE_UNKNOWN;
+ free_saved ();
switch (nl->type)
- {
- case BT_INTEGER:
+ {
+ case GFC_DTYPE_INTEGER:
read_integer (len);
break;
- case BT_LOGICAL:
+
+ case GFC_DTYPE_LOGICAL:
read_logical (len);
break;
- case BT_CHARACTER:
+
+ case GFC_DTYPE_CHARACTER:
read_character (len);
break;
- case BT_REAL:
+
+ case GFC_DTYPE_REAL:
read_real (len);
break;
- case BT_COMPLEX:
+
+ case GFC_DTYPE_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);
+ 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)
+ {
+ free_mem (obj_name);
+ return FAILURE;
+ }
+
+ if (input_complete)
+ {
+ free_mem (obj_name);
+ 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;
+ }
+ }
- if (m < len)
- memset (((char *) p) + m, ' ', len - m);
- break;
+ /* 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. */
- case BT_NULL:
- break;
- }
+ prev_nl = nl;
+ if (nml_read_error)
+ return SUCCESS;
- break;
+ 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 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);
+ free_mem (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;
+ }
- default :
- push_char(tolower(c));
+ 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;
}
/* Thread/recursion locking
- Copyright 2002 Free Software Foundation, Inc.
+ 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).
g.in_library = 0;
filename = NULL;
line = 0;
-
t = ioparm.library_return;
+
+ /* Delete the namelist, if it exists. */
+
if (ionml != NULL)
{
t1 = ionml;
while (t1 != NULL)
- {
- t2 = t1;
- t1 = t1->next;
- free_mem (t2);
- }
+ {
+ 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;
+
memset (&ioparm, '\0', sizeof (ioparm));
ioparm.library_return = t;
}
/* 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).
library_end ();
}
+/* Receives the scalar information for namelist objects and stores it
+ in a linked list of namelist_info types. */
-static void
-st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
- int kind, bt type, int string_length)
+void
+st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
+ gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
{
- namelist_info *t1 = NULL, *t2 = NULL;
- namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
+ namelist_info *t1 = NULL;
+ namelist_info *nml;
+
+ nml = (namelist_info*) get_mem (sizeof (namelist_info));
+
nml->mem_pos = var_addr;
- if (var_name)
+
+ nml->var_name = (char*) get_mem (strlen (var_name) + 1);
+ strcpy (nml->var_name, var_name);
+
+ nml->len = (int) len;
+ nml->string_length = (index_type) string_length;
+
+ nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
+ nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
+ nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
+
+ if (nml->var_rank > 0)
{
- 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;
+ 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
{
- assert (var_name_len == 0);
- nml->var_name = NULL;
+ nml->dim = NULL;
+ nml->ls = NULL;
}
- nml->len = kind;
- nml->type = type;
- nml->string_length = string_length;
-
nml->next = NULL;
if (ionml == NULL)
- ionml = nml;
+ ionml = nml;
else
{
- t1 = ionml;
- while (t1 != NULL)
- {
- t2 = t1;
- t1 = t1->next;
- }
- t2->next = nml;
+ for (t1 = ionml; t1->next; t1 = t1->next);
+ t1->next = nml;
}
+ return;
}
-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);
+/* Store the dimensional information for the namelist object. */
void
-st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
- int kind)
+st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
+ GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
{
- st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
-}
+ namelist_info * nml;
+ int n;
-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);
-}
+ n = (int)n_dim;
-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);
-}
+ for (nml = ionml; nml->next; nml = nml->next);
-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);
+ nml->dim[n].stride = (ssize_t)stride;
+ nml->dim[n].lbound = (ssize_t)lbound;
+ nml->dim[n].ubound = (ssize_t)ubound;
}
-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);
-}
+extern void st_set_nml_var (void * ,char * ,
+ GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
+export_proto(st_set_nml_var);
+
+extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
+ GFC_INTEGER_4 ,GFC_INTEGER_4);
+export_proto(st_set_nml_var_dim);
+
/* 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).
#include "config.h"
#include <string.h>
+#include <ctype.h>
#include <float.h>
#include <stdio.h>
#include <stdlib.h>
sign_t;
+static int no_leading_blank = 0 ;
+
void
write_a (fnode * f, const char *source, int len)
{
leadzero = 0;
/* Padd to full field width. */
- if (nblanks > 0)
+
+
+ if ( ( nblanks > 0 ) && !no_leading_blank )
{
memset (out, ' ', nblanks);
out += nblanks;
#endif
memcpy (out, buffer, edigits);
}
+
+ if ( no_leading_blank )
+ {
+ out += edigits;
+ memset( out , ' ' , nblanks );
+ no_leading_blank = 0;
+ }
}
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;
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);
+ }
}
char_flag = (type == BT_CHARACTER);
}
-void
-namelist_write (void)
-{
- namelist_info * t1, *t2;
- int len,num;
- void * p;
+/* NAMELIST OUTPUT
- num = 0;
- write_character("&",1);
- write_character (ioparm.namelist_name, ioparm.namelist_name_len);
- write_character("\n",1);
+ 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. */
- if (ionml != NULL)
+/* 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 rep_ctr;
+ int num;
+ int nml_carry;
+ index_type len;
+ index_type obj_size;
+ index_type nelem;
+ index_type dim_i;
+ index_type clen;
+ index_type elem_ctr;
+ index_type obj_name_len;
+ void * p ;
+ char cup;
+ char * obj_name;
+ char * ext_name;
+ char rep_buff[NML_DIGITS];
+ 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)
{
- t1 = ionml;
- while (t1 != NULL)
+ write_character ("\n ", 2);
+ len = 0;
+ if (base)
{
- num ++;
- t2 = t1;
- t1 = t1->next;
- if (t2->var_name)
+ len =strlen (base->var_name);
+ for (dim_i = 0; dim_i < strlen (base_name); dim_i++)
{
- write_character(t2->var_name, strlen(t2->var_name));
- write_character("=",1);
+ cup = toupper (base_name[dim_i]);
+ write_character (&cup, 1);
}
- len = t2->len;
- p = t2->mem_pos;
- switch (t2->type)
- {
- case BT_INTEGER:
+ }
+ 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 on a line, 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;
+
+ /* Set the index vector and count the number of elements. */
+
+ nelem = 1;
+ 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);
+ }
+
+ /* Main loop to output the data held in the object. */
+
+ rep_ctr = 1;
+ 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 BT_LOGICAL:
+
+ case GFC_DTYPE_LOGICAL:
write_logical (p, len);
break;
- case BT_CHARACTER:
- write_character (p, t2->string_length);
+
+ 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 BT_REAL:
+
+ case GFC_DTYPE_REAL:
write_real (p, len);
break;
- case BT_COMPLEX:
+
+ 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
+ + 1);
+
+ 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");
}
- write_character(",",1);
+
+ /* 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",1);
+ 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 > (ssize_t)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;
+ index_type 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("/",1);
+ write_character (" /\n", 4);
+
+ /* Recover the original delimiter. */
+
+ current_unit->flags.delim = tmp_delim;
}
+
+#undef NML_DIGITS
+
projects / thirdparty / gcc.git / commitdiff
