! bof
! **********************************************************************
! Fortran 95 program coco

! **********************************************************************
! Source Control Strings

! $Id: coco.f90,v 1.30 2007/06/25 19:08:22 dan Exp dan $

! **********************************************************************
!  Copyright 2003 Purple Sage Computing Solutions, Inc.
!  All Rights Reserved

!   This program is free software; you can redistribute it and/or
!   modify it under the terms of the GNU General Public
!   License as published by the Free Software Foundation; either
!   version 2 of the License, or (at your option) any later version.

!   This program is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!   General Public License for more details.

!   You should have received a copy of the GNU General Public
!   License along with this program; if not, write to the Free
!   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

! To report bugs, suggest enhancements, etc. to the Authors,
! Contact:
!    Purple Sage Computing Solutions, Inc.
!                               send email to dnagle@erols.com
!                                   or fax to 703 471 0684 (USA)
!                                  or mail to 12142 Purple Sage Ct.
!                                             Reston, VA 20194-5621 USA

! **********************************************************************
! coco implements Part 3: Conditional Compilation

! **********************************************************************

!  coco reads

!     input source file(s)- named via command line, or stdin
!     named set file- name taken from the output filename, or coco.set

!  coco writes

!     output source file- named via command line, or stdout
!     logfile- named via ??logfile directive, or stderr

!  coco temp files

!     scratch- hold the contents of text blocks while counting their size

!  coco uses

!     f2kcli (http://www.winteracter.com/f2kcli)

!  coco constants

!     coco_rcs_id- this file's rcs id string
!     *_unit- logical unit numbers
!     *_fmt- formats
!     *_len- lengths of character entities
!     alter_*- the alter states
!     if_*- the current state of if-directive processing

!  coco types

!     file_t- filename and unit
!     path_t- include directory
!     symbol_t- integer, logical, macro, text symbol
!     if_t- if block and state
!     state_t- set of options
!     report_t- statistics

!  coco data

!  coco library

!     add_directory() appends a directory to the path list
!     add_integer() build an integer entry and store it on the symbol list
!     add_logical() build a logical entry and store it on the symbol list
!     add_macro() build a macro entry and store it on the symbol list
!     add_symbol() append an entry to the symbol list
!     add_text() build a text entry and store it on the symbol list
!     blank_compress_lower_case() read lines return statement for processing
!     close_file() closes a named file and unlinks pointers
!     close_scratch() closes a scratch file
!     coco() main program
!     copy_set_file() appends the set file to the end of the output
!     edit_coco_strings() edit ?coco? in source
!     edit_date_time_strings() edit ?date? and ?time? strings in source lines
!     edit_file_line_strings() edit ?file? and ?line? strings in source lines
!     edit_integer_strings() edit integer substitutions
!     edit_logical_strings() edit logical substitutions
!     edit_macro_strings() edit macro substitutions
!     edit_source_line() edit a source line with substitutions
!     eval_int_expr() return an integer value from an expression
!     eval_int_primary() return a value from an integer primary
!     eval_log_expr() return a logical value from an expression
!     eval_log_primary() return a value from a logical primary
!     eval_rel_expr() return a logical value from a comparison
!     gather_coco_statement() signal when a complete statement has been read
!     get_integer_value() return the value of an integer symbol
!     get_logical_value() return the value of a logical value
!     get_macro_name() return a macro name from statement
!     get_next_integer() return a pointer to the next integer on the symbol list
!     get_next_logical() return a pointer to the next logical on the symbol list
!     get_next_macro() return a pointer to the next macro on the symbol list
!     get_symbol_name() return integer or logical name from statement
!     get_text_name() return a text block name from statement
!     get_text_ptr() return pointer to a text block name
!     getopt() get each command line word
!     initialize_coco() set derived types variables and pointers to initial state
!     integer_or_logical() determine whether an expression is integer or logical
!     is_coco_statement() decide whether line is a directive or a comment
!     msg_continue() log message and continue
!     msg_quit() log message and stop
!     open_file() opens a file and sets pointers
!     open_scratch() opens a scratch file
!     print_help() print command line options to stderr
!     process_actual_arglist() edit macro definition dummy args
!     process_alter_directive() set alter state from directive
!     process_alter_option() set alter state from -a
!     process_assert_directive() process a coco assert statement
!     process_assertif_directive() process a coco assertif statement
!     process_block_directive() process a coco statement within a text block
!     process_coco_statement() process a coco directive in a source file
!     process_command_line() process command line options including filenames
!     process_copy_directive() process a copy statement
!     process_copyif_directive() process a copyif statement
!     process_directory_directive() process a setfile directory directive
!     process_doc_directive() processes a doc directive
!     process_docfile_directive() processes a docfile directive
!     process_dummy_arglist() process a macro or text definition dummy arg list
!     process_dump_directive() process a dump directive
!     process_edit_directive() process a setfile edit directive
!     process_else_directive() process a coco else statement
!     process_elseif_directive() process a coco else if statement
!     process_endif_directive() process a coco end if statement
!     process_if_directive() process a coco if statement
!     process_ifdef_directive() true if symbol is defined
!     process_ifndef_directive() true if symbol is not defined
!     process_include_directive() process a source file include directive
!     process_include_option() set include directory from -Idir
!     process_input_file() read a source file and process it
!     process_integer_assignment() assign a value to an integer symbol
!     process_integer_constant() define an integer constant
!     process_integer_declaration() process an integer statement
!     process_logfile_directive() process a setfile logfile directive
!     process_logical_assignment() assign a value to a logical symbol
!     process_logical_constant() define a logical constant
!     process_logical_declaration() process a logical statement
!     process_macro_declaration() process a macro statement
!     process_message_directive() process a coco message statement
!     process_number_directive() set numbering from setfile directive
!     process_output_directive() opens a new output file
!     process_set_file() read and process the setfile
!     process_set_statement() process one setfile statement
!     process_stop_directive() process a coco stop statement
!     process_summary_directive() process a setfile summary directive
!     process_symbol_option() define symbol from -Dname
!     process_text_directive() process a begin text statement
!     process_undefine_directive() processes an undefine directive
!     process_verbose_directive() process a setfile verbose directive
!     process_warn_directive() process a setfile warn directive
!     process_wrap_value() process the length supplied on a -w or ??wrap
!     remove_symbol() remove a symbol entry from the symbol list
!     replace_substring() globally replace a substring in a string
!     seek_close_paren() return the location of the matching parenthesis
!     seek_directory() seek an directory to find an include file
!     seek_include_file() find an include file
!     seek_log_primary() find the next logical operator
!     seek_set_file() try to open setfile
!     seek_symbol_name() find an integer or logical name
!     set_option_defaults() check options after command line and setfile processing
!     unquote_string() return an unquoted string
!     verify_actual_args() check actual arguments for need of parenthesis
!     verify_dummy_args() verify macro or text dummy args
!     verify_macro_value() verify a macro's value
!     verfiy_text_directive() verify which directives are in a text block
!     wrap_source_line() ensure that a source line exceeds not length
!     write_coco_line() write a coco line
!     write_options() write the current options to the logfile
!     write_report() log summary statistics
!     write_source_line() write a source line

! **********************************************************************

!  coco

! **********************************************************************

program coco

!  coco implements ISO/IEC 1539-3 Conditional Compilation standard

!  coco steps

!  1. call process_command_line() to read command line, get filenames & options
!  2. call process_setfile() to read the setfile, if there is one
!  3. open the output file, if named, use stdout if not
!  4. open the input file(s), if named, use stdin if not
!  5. call process_input_file() to process the input file(s) & write the output file
!  6. copy the setfile contents to the output file
!  7. close all files
!  8. call write_report() print summary information

! **********************************************************************

!  coco uses modules

! **********************************************************************

!  Winteracter Fortran 2003 command line access module
!  http://www.winteracter.com/f2kcli

use f2kcli

! **********************************************************************

!  explicit declaration

implicit none

! **********************************************************************

!  coco RCS strings

! **********************************************************************

!  program source filename supplied by RCS

character( len= *), parameter :: coco_rcs_id = &
   '$Id: coco.f90,v 1.30 2007/06/25 19:08:22 dan Exp dan $'

! **********************************************************************

!  coco constants

! **********************************************************************

!  coco logical unit numbers

!  scheme for logical unit numbers:

!  The setfile is read first and processed.
!  The setfile is then closed.  The output is opened
!  (if need be), and then the input file is opened (again, if need be).
!  If an include file is encountered, the logical unit numbers used are
!  computed by adding to the current input unit number.  If the current
!  input file is stdin, read_unit is used first, then successive unit
!  numbers are used for nested include files.  When all input files have
!  been read, the set scratch file is copied to the output file.  All
!  Fortran files are then closed.  The summary is written to the output.
!  A text block is copied to the text_unit to count the number of lines.
!  Then it is copied back to a character array and the text_unit is closed.

! **********************************************************************

!  global constants

!  the unit names are provided in the Fortran 2003 intrinsic module iso_fortran_env

integer, parameter :: input_unit = 5
integer, parameter :: output_unit = 6
integer, parameter :: error_unit = 0

!  logfile unit else use error_unit, +4 tries to avoid plot_unit, punch_unit, etc.

integer, parameter :: log_unit = max( input_unit, output_unit, error_unit) + 4

!  documentation unit for doc ... end doc lines

integer, parameter :: doc_unit = log_unit + 1

!  scratch unit for text scratch files

integer, parameter :: text_unit = doc_unit + 1

!  setfile unit

integer, parameter :: set_unit = text_unit + 1

!  output unit if named output file (else use unit= *)

integer, parameter :: write_unit = set_unit + 1

!  input unit if named input file (else use unit= *)

integer, parameter :: read_unit = write_unit + 1

! **********************************************************************

!  coco formats

! **********************************************************************

!  used to read/write lines

character( len= *), parameter :: string_fmt = '( a)'

!  used to write reports

character( len= *), parameter :: integer_fmt = '( a, i10)'

!  used to write reports

character( len= *), parameter :: directory_fmt = '( a, i0, a)'

!  length of format strings

integer, parameter :: format_len = max( len( string_fmt), len( integer_fmt) )

!  length of input/output specifier strings

integer, parameter :: io_specifier_len = 16

! ----------------------------------------------------------------------

!  length of strings used to convert between integers and characters

integer, parameter :: conversion_len = 10

!  format used to convert between integers and characters

character( len= *), parameter :: conversion_fmt = '(i10)'

! **********************************************************************

!  coco character lengths

! **********************************************************************

!  these are the lengths of strings used throughout coco

! ----------------------------------------------------------------------

!  length of character storing a constant or variable name

integer, parameter :: symbol_name_len = 32

!  length of a Fortran source line

integer, parameter :: free_format_len = 132

integer, parameter :: fixed_format_len = 72

!  length used to write lines is free_format_len + len( '!?>') + len( blank)

integer, parameter :: source_line_len = free_format_len + len( '!?>') + len( ' ')

!  length of character storing filenames

integer, parameter :: filename_len = 256

!  length of character line buffers (allows for max_continuations number of continuations)

integer, parameter :: max_continuations = 39

!  buffer a whole coco statement and always have a blank at the end

integer, parameter :: buffer_len = ( max_continuations + 1) * source_line_len

! **********************************************************************

!  this string is used to initialize character variables

! ----------------------------------------------------------------------

!  null string

character( len= *), parameter :: null_string = ''

!  mark beginning of the setfile in the output

character( len= *), parameter :: mark_set_file = &
   '?? This was produced using the following SET file'

! ----------------------------------------------------------------------

!  names must be made of alphanumeric characters only

character( len= *), parameter :: alpha_chars = 'abcdefghijklmnopqrstuvwxyz'

character( len= *), parameter :: digit_chars = '0123456789'

character( len= *), parameter :: underscore = '_'

character( len= *), parameter :: alphanum_chars =  alpha_chars // digit_chars // underscore

! ----------------------------------------------------------------------

!  ascii characters change case

integer, parameter :: change_case = 32

! **********************************************************************

!  coco directives constants

! **********************************************************************

!  many character string constants' lengths are used to count past
!  the string as coco processes each statement

!  coco line and statement syntax uses the next set of character constants

! **********************************************************************

!  . separates filenames from extensions, delimits logical operators & literals

character( len= *), parameter :: dot = '.'

! ----------------------------------------------------------------------

!  constants defining coco directives, comments, separators, etc.

! ----------------------------------------------------------------------

!  coco line key ??coco_directive

character( len= *), parameter :: coco_key = '??'

!  substitution key

character( len= *), parameter :: arg_key = '?'

!  length of ?name?

integer, parameter :: target_len = len( arg_key) + symbol_name_len + len( arg_key)

!  continuation character

character( len= *), parameter :: continuation = '&'

!  blank character

character( len= *), parameter :: blank = ' '

!  tab character

character( len= *), parameter :: tab = achar( 9)

!  whitespace is blank or tab

character( len= *), parameter :: white_space = blank // tab

!  coco comment initializer

character( len= *), parameter :: comment = '!'

!  separates items within a list

character( len= *), parameter :: comma = ','

!  quotes

character( len= *), parameter :: single_quote = "'"

character( len= *), parameter :: double_quote = '"'

! **********************************************************************

!  process_logical_declaration() constants

! ----------------------------------------------------------------------

!  process name[=value][,name[=value]]...

character( len= *), parameter :: end_of_decl = comma // blank

! ----------------------------------------------------------------------

!  constants defining coco (integer or logical) operators, constants, etc.

! ----------------------------------------------------------------------

!  minus sign

character( len= *), parameter :: minus = '-'

!  plus sign

character( len= *), parameter :: plus = '+'

! ----------------------------------------------------------------------

!  logical binary operators

character( len= *), parameter :: or_str = '.or.'

character( len= *), parameter :: and_str = '.and.'

character( len= *), parameter :: eqv_str = '.eqv.'

character( len= *), parameter :: neqv_str = '.neqv.'

! ----------------------------------------------------------------------

!  logical uniary operator

character( len= *), parameter :: not_str = '.not.'

! ----------------------------------------------------------------------

!  logical literals

character( len= *), parameter :: true_str = '.true.'

character( len= *), parameter :: false_str = '.false.'

! ----------------------------------------------------------------------

!  the archaic versions of the relational operators

character( len= *), parameter :: dot_eq = '.eq.'

character( len= *), parameter :: dot_ne = '.ne.'

character( len= *), parameter :: dot_gt = '.gt.'

character( len= *), parameter :: dot_ge = '.ge.'

character( len= *), parameter :: dot_le = '.le.'

character( len= *), parameter :: dot_lt = '.lt.'

!  the modern versions of the relational operators

character( len= *), parameter :: ch_eq = '=='

character( len= *), parameter :: ch_ne = '/='

character( len= *), parameter :: ch_gt = '>'

character( len= *), parameter :: ch_ge = '>='

character( len= *), parameter :: ch_le = '<='

character( len= *), parameter :: ch_lt = '<'

! ----------------------------------------------------------------------

!  strings used to declare symbol names and values

! ----------------------------------------------------------------------

!  equal sign

character( len= *), parameter :: equals = '='

!  open parenthesis

character( len= *), parameter :: open_paren = '('

!  close parenthesis

character( len= *), parameter :: close_paren = ')'

! ----------------------------------------------------------------------

!  directives which must appear in the setfile

! ----------------------------------------------------------------------

!  alter directive

character( len= *), parameter :: alter_str = 'alter:'

!  directory declaration

character( len= *), parameter :: directory_str = 'directory'

!  edit directive allows changing the edit mode from the setfile

character( len= *), parameter :: edit_str = 'edit:'

!  docfile declaration

character( len= *), parameter :: docfile_str = 'docfile'

!  logfile declaration

character( len= *), parameter :: logfile_str = 'logfile'

!  number directive controls placing "! file: line" strings on source lines

character( len= *), parameter :: number_str = 'number:'

!  parens directive sets warning when actual arguments don't have enclosing parenthesis

character( len= *), parameter :: parens_str = 'parens:'

!  summary directive allows changing the summary mode from the setfile

character( len= *), parameter :: summary_str = 'summary:'

!  verbose directive allows changing the verbose mode from the setfile

character( len= *), parameter :: verbose_str = 'verbose:'

!  warn directive allows changing the warning mode from the setfile

character( len= *), parameter :: warn_str = 'warn:'

!  wrap directive allows changing the wrap length from the setfile

character( len= *), parameter :: wrap_str = 'wrap:'

! ----------------------------------------------------------------------

!  directives which may appear in the setfile or source file

! ----------------------------------------------------------------------

!  integer declaration

character( len= *), parameter :: integer_str = 'integer::'

!  integer constant declaration

character( len= *), parameter :: integer_constant_str = 'integer,parameter::'

!  logical declaration

character( len= *), parameter :: logical_str = 'logical::'

!  logical constant declaration

character( len= *), parameter :: logical_constant_str = 'logical,parameter::'

! ----------------------------------------------------------------------

!  directives which must appear in the source file

! ----------------------------------------------------------------------

!  include directive

character( len= *), parameter :: include_str = 'include'

! ----------------------------------------------------------------------

!  stop directive

character( len= *), parameter :: stop_str = 'stop'

! ----------------------------------------------------------------------

!  message directive

character( len= *), parameter :: message_str = 'message'

! ----------------------------------------------------------------------

!  if directive

character( len= *), parameter :: if_str = 'if('

! ----------------------------------------------------------------------

!  elseif directive

character( len= *), parameter :: elseif_str = 'elseif('

! ----------------------------------------------------------------------

!  )then must close an if( or elseif(

character( len= *), parameter :: then_str = ')then'

! ----------------------------------------------------------------------

!  else directive

character( len= *), parameter :: else_str = 'else'

! ----------------------------------------------------------------------

!  endif directive

character( len= *), parameter :: endif_str = 'endif'

! ----------------------------------------------------------------------

!  directives which are extensions

! ----------------------------------------------------------------------

!  ifdef directive

character( len= *), parameter :: ifdef_str = 'ifdef('

! ----------------------------------------------------------------------

!  ifndef directive

character( len= *), parameter :: ifndef_str = 'ifndef('

! ----------------------------------------------------------------------

!  undefine directive

character( len= *), parameter :: undefine_str = 'undefine::'

! ----------------------------------------------------------------------

!  macro declaration

character( len= *), parameter :: macro_str = 'macro::'

! ----------------------------------------------------------------------

!  assert directive

character( len= *), parameter :: assert_str = 'assert'

! ----------------------------------------------------------------------

!  assertif directive

character( len= *), parameter :: assertif_str = 'assertif('

! ----------------------------------------------------------------------

!  dump directive

character( len= *), parameter :: dump_str = 'dump'

!  options directive

character( len= *), parameter :: options_str = 'options'

!  report directive

character( len= *), parameter :: report_str = 'report'

! ----------------------------------------------------------------------

!  text directive

character( len= *), parameter :: text_str = 'text::'

!  copy directive

character( len= *), parameter :: copy_str = 'copy::'

!  copyif directive

character( len= *), parameter :: copyif_str = 'copyif('

! ----------------------------------------------------------------------

!  doc directive (the end doc directive is defined in process_doc_directive() )

character( len= *), parameter :: doc_str = 'doc'

!  endfile directive

character( len= *), parameter :: endfile_str = 'endfile'

!  output directive

character( len= *), parameter :: output_str = 'output'

! ----------------------------------------------------------------------

!  these strings are replaced when editing source lines

! ----------------------------------------------------------------------

!  provide file, line, date, time strings in programs

character( len= *), parameter :: file_str = '?file?'

character( len= *), parameter :: line_str = '?line?'

character( len= *), parameter :: date_str = '?date?'

character( len= *), parameter :: time_str = '?time?'

!  provide coco rcs id string in programs

character( len= *), parameter :: coco_str = '?coco?'

! ----------------------------------------------------------------------

!  on directive

character( len= *), parameter :: on_str = 'on'

!  off directive

character( len= *), parameter :: off_str = 'off'

! **********************************************************************

!  possible states encountered during execution

! ----------------------------------------------------------------------

!  codes for possible alter states

integer, parameter :: alter_none = 0

integer, parameter :: alter_delete = 1

integer, parameter :: alter_blank = 2

integer, parameter :: alter_shift_1 = 3

integer, parameter :: alter_shift_0 = 4

integer, parameter :: alter_shift_3 = 5

! ----------------------------------------------------------------------

!  wrap lengths

integer, parameter :: wrap_none = -1

integer, parameter :: wrap_off = huge( 0)

! ----------------------------------------------------------------------

!  codes for possible symbol types

integer, parameter :: type_none = 0

integer, parameter :: type_integer = 1

integer, parameter :: type_logical = 2

integer, parameter :: type_macro = 3

integer, parameter :: type_text = 4

! ----------------------------------------------------------------------

!  codes for possible if construct phases

integer, parameter :: outside_block = 0

integer, parameter :: if_block = 1

integer, parameter :: elseif_block = 2

integer, parameter :: else_block = 3

! **********************************************************************

!  communication with getopt()

! ----------------------------------------------------------------------

!  getopt() 'no more arguments'

integer, parameter :: end_of_args = -1

!  getopt() 'not in optltrs'

character( len= *), parameter :: unknown_option = '?'

! **********************************************************************

!  coco types

! **********************************************************************

!  coco files and search paths

! ----------------------------------------------------------------------

!  file type

type :: file_t

   integer :: logical_unit

   character( len= filename_len) :: name_str

   character( len= format_len) :: format_str

   character( len= free_format_len), pointer :: line

   integer :: io_status

   integer :: lines_transfered

   logical :: named_file

   logical :: create

end type file_t

! ----------------------------------------------------------------------

!  search location type

type :: path_t

   character( len= filename_len) :: name_str

   integer :: times_accessed

   type( path_t), pointer :: next

end type path_t

! **********************************************************************

!  these derived types are used to store coco constants or variables

! ----------------------------------------------------------------------

!  type stores a coco symbol & value

type :: symbol_t

   integer :: type_code

   character( len= symbol_name_len) :: name_str

   logical :: defined

   logical :: constant

   logical :: predefined

   integer :: integer_value

   logical :: logical_value

   character( len= symbol_name_len), pointer, dimension( :) :: dummy_args

   character( len= buffer_len) :: macro_value

   character( len= free_format_len), pointer, dimension( :) :: text_lines

   type( symbol_t), pointer :: next

end type symbol_t

! **********************************************************************

!  if_t stores the state of an if block

! ----------------------------------------------------------------------

!  if_t

type :: if_t

   logical :: now_selected

   logical :: ever_selected

   integer :: phase

   type( if_t), pointer :: nested

   type( if_t), pointer :: enclosing

end type if_t

! **********************************************************************

!  state_t stores a set of coco options

! ----------------------------------------------------------------------

!  state_t

type :: state_t

   integer :: alter_state

   logical :: edit_date

   logical :: edit_file

   logical :: edit_source

   logical :: edit_integers

   logical :: edit_macros

   logical :: number_source

   logical :: args_in_parens

   logical :: report_extensions

   logical :: print_summary

   logical :: warn_undeclared

   logical :: verbose_mode

   integer :: wrap_length

end type state_t

! **********************************************************************

!  report_t stores coco statistics

! ----------------------------------------------------------------------

!  report_t records the source and sink of lines

type :: report_t

   integer :: input_lines

   integer :: input_files

   integer :: include_files

   integer :: coco_lines

   integer :: selected_lines

   integer :: elided_lines

   integer :: text_blocks

   integer :: text_lines

   integer :: copied_lines

end type report_t

! **********************************************************************

!  coco variables

! **********************************************************************

!  option swtiches

! ----------------------------------------------------------------------

type( state_t) :: options
! ----------------------------------------------------------------------

!  report totals of event counts

type( report_t) :: total

! ----------------------------------------------------------------------

!  if construct outside any if construct

type( if_t), target :: outside_any_if_construct

!  if construct status

type( if_t), pointer :: if_construct

! ----------------------------------------------------------------------

!  coco symbols are stored in a singly linked list

type( symbol_t), pointer :: first_symbol

! ----------------------------------------------------------------------

!  mark when non constants are used to provide a value for a constant

logical :: all_constants

! ----------------------------------------------------------------------

!  signal when reading the setfile

logical :: processing_set_file = .true.

! **********************************************************************

!  coco file name variables

! ----------------------------------------------------------------------

!  input file, output file, or setfile

! ----------------------------------------------------------------------

!  the (first) input file

type( file_t), target :: input_file 

! ----------------------------------------------------------------------

!  the output file

type( file_t), target :: output_file

! ----------------------------------------------------------------------

!  the docfile

type( file_t), target :: doc_file

! ----------------------------------------------------------------------

!  the setfile

type( file_t), target :: set_file

! ----------------------------------------------------------------------

!  the logfile

type( file_t) :: log_file

! ----------------------------------------------------------------------

!  point to current input file for error messages

type( file_t), pointer :: current_file

! ----------------------------------------------------------------------

!  a list of source files for reports

type( file_t), allocatable, dimension(:) :: source_file_list

!  number of filenames

integer :: number_of_names

! ----------------------------------------------------------------------

!  the input/output line buffer

character( len= free_format_len), target :: line

!  the logfile line buffer

character( len= free_format_len), target :: log_line

! ----------------------------------------------------------------------

!  list of include directories is initially . only

type( path_t), pointer :: first_directory

! ----------------------------------------------------------------------

!  communicate with getopt()

! ----------------------------------------------------------------------

!  getopt() string returning non-option letter words

character( len= filename_len) :: optarg = null_string

! ----------------------------------------------------------------------

!  number of command line args

integer :: nargs

!  count command line words

integer :: optind = 0

! **********************************************************************

!  coco local

! ----------------------------------------------------------------------

!  loop index of filename args

   integer :: this_input

! **********************************************************************

!  coco text

! **********************************************************************

continue

! ----------------------------------------------------------------------

!  initialize coco program variables

   call initialize_coco()

! ----------------------------------------------------------------------

!  process command line to get options and filenames

   call process_command_line

! ----------------------------------------------------------------------

!  see if setfile exists and process it if it does

   call seek_set_file

! ----------------------------------------------------------------------

!  set option to default values if the command line or the setfile hasn't set them

   call set_option_defaults

! ----------------------------------------------------------------------

!  open the output file but link not current_file

   call open_file( output_file)

! **********************************************************************

!  read all input file(s)

   number_of_input_files: select case( number_of_names)

   case( 0, 1) number_of_input_files

!  process the input file

      call process_input_file( input_file)

!  end of input

   case default number_of_input_files

!  process several input files

      read_all_files: do this_input = 2, number_of_names

!  process the input using coco default units

         call process_input_file( source_file_list( this_input) )

!  repeat for each input file

      enddo read_all_files

!  end of input

   end select number_of_input_files

! **********************************************************************

!  if the output file has content, copy the setfile to it

   made_output: if( output_file% lines_transfered > 0 )then

!  mark the setfile in the output (whether it is present or not)

      line = mark_set_file

      call write_coco_line( output_file)

! ----------------------------------------------------------------------

!  if processed a setfile

      append_set_file: if( set_file% named_file )then

!  copy setfile file to output

         call copy_set_file

!  if processed setfile

      endif append_set_file

   endif made_output

! ----------------------------------------------------------------------

!  if processed a docfile

   close_doc_file: if( doc_file% named_file )then

!  copy setfile file to output

      call close_file( doc_file)

!  if processed docfile

   endif close_doc_file

! ----------------------------------------------------------------------

!  close the output file

   call close_file( output_file)

! ----------------------------------------------------------------------

!  report to logfile

   summary: if( options% print_summary )then

      call write_report

   endif summary

! ----------------------------------------------------------------------

!  close the logfile

   call close_file( log_file)

! ----------------------------------------------------------------------

!  coco exit

stop 'coco normal exit'

! **********************************************************************

!  coco library

! **********************************************************************

contains

! **********************************************************************
! **********************************************************************

!  initialize_coco() prepares coco for execution

subroutine initialize_coco()

! **********************************************************************

!  initialize_coco() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  initialize derived types values

   options = state_t( alter_none, .true., .true., .true., .true., .true., &
                      .false., .false., .false., .true., .false., .false., wrap_none)

   total = report_t( 0, 0, 0, 0, 0, 0, 0, 0, 0)

!  magic if-block outside any if block

   outside_any_if_construct = if_t( .true., .true., outside_block, null(), null() )

!  files

   input_file = file_t( input_unit, '<stdin>', string_fmt, null(), 0, 0, .false., .false.)

   output_file = file_t( output_unit, '<stdout>', string_fmt, null(), 0, 0, .false., .true.)

   doc_file = file_t( doc_unit, null_string, string_fmt, null(), 0, 0, .false., .true.)

   set_file = file_t( set_unit, null_string, string_fmt, null(), 0, 0, .false., .false.)

   log_file = file_t( error_unit, '<stderr>', integer_fmt, null(), 0, 0, .false., .true.)

!  initialize pointers

   nullify( if_construct)

   if_construct => outside_any_if_construct

   nullify( first_symbol)

   nullify( current_file)

   log_file% line => log_line

   output_file% line => line

   nullify( first_directory)

! ----------------------------------------------------------------------

!  initialize_coco() exit

return

! **********************************************************************

!  initialize_coco()

end subroutine initialize_coco

! **********************************************************************
! **********************************************************************

!  %%% open and close files, write logfile messages, parse command line

! **********************************************************************
! **********************************************************************

!  open_file() open a file and remark

subroutine open_file( this_file)

! **********************************************************************

!  open_file() interface

! ----------------------------------------------------------------------

!  the file to be opened

type( file_t), target, intent( inout) :: this_file

! **********************************************************************

!  open_file() constants

! ----------------------------------------------------------------------

!  open for reading or writing

   character( len= *), parameter :: read_action = 'READ'

   character( len= *), parameter :: write_action = 'WRITE'

!  open existing file or create a new one

   character( len= *), parameter :: read_status = 'OLD'

   character( len= *), parameter :: write_status = 'REPLACE'

! **********************************************************************

!  open_file() local

! ----------------------------------------------------------------------

!  open for reading or writing

   character( len= io_specifier_len) :: open_status

   character( len= io_specifier_len) :: open_action

! **********************************************************************

!  open_file() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  open the file if file is named

   file_has_name: if( this_file% named_file )then

!  establish open parameters for reading or writing

      direction: if( this_file% create )then

         open_status = write_status

         open_action = write_action

      else direction

         open_status = read_status

         open_action = read_action

      endif direction

!  open this file

      open( unit= this_file% logical_unit, &
            file= this_file% name_str, &
            status= open_status, &
            action= open_action, &
            iostat= this_file% io_status)

      current_file => this_file

      named_status: if( this_file% io_status > 0 )then

         call msg_quit( "can't open file: " // trim( this_file% name_str) )

      elseif( options% verbose_mode )then named_status

         call msg_continue( "opened file: " // trim( this_file% name_str) )

         nullify( current_file)

      endif named_status

   endif file_has_name

!  the logfile is never the current input file, since it receives error messages

   current_input_only: select case( this_file% logical_unit)

   case( input_unit, set_unit, read_unit: )

      current_file => this_file

      this_file% line => line

   case( output_unit)

      this_file% line => line

   case( log_unit)

      this_file% line => log_line

   end select current_input_only

! ----------------------------------------------------------------------

!  open_file() exit

return

! **********************************************************************

!  open_file()

end subroutine open_file

! **********************************************************************
! **********************************************************************

!  open_scratch() open an unformatted scratch file

subroutine open_scratch( this_file)

! **********************************************************************

!  open_scratch() interface

! ----------------------------------------------------------------------

!  the scratch file to be opened

type( file_t), target, intent( inout) :: this_file

! **********************************************************************

!  open_scratch() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  open the file

   open( unit= this_file% logical_unit, &
         status= 'SCRATCH', &
         action= 'READWRITE', &
         form= 'UNFORMATTED', &
         iostat= this_file% io_status)

   scratch_status: if( this_file% io_status > 0 )then

      current_file => this_file

      call msg_quit( "can't open scratch file: <scratch>")

   endif scratch_status

!  link to line buffer

   this_file% line => line

! ----------------------------------------------------------------------

!  open_scratch() exit

return

! **********************************************************************

!  open_scratch()

end subroutine open_scratch

! **********************************************************************
! **********************************************************************

!  close_file() close a file and remark

subroutine close_file( this_file)

! **********************************************************************

!  close_file() interface

! ----------------------------------------------------------------------

!  the file to be closed

type( file_t), target, intent( inout) :: this_file

! **********************************************************************

!  close_file() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  close the named file

   close_named: if( this_file% named_file )then

      close( unit= this_file% logical_unit, &
             status= 'KEEP', &
             iostat= this_file% io_status)

      logfile_close: if( this_file% logical_unit == log_unit )then

         this_file% logical_unit = error_unit

      endif logfile_close

      current_file => this_file

      close_status: if( this_file% io_status > 0 )then

         call msg_quit( "can't close file: " // trim( this_file% name_str) )

      elseif( options% verbose_mode )then close_status

        call msg_continue( "closed file: " // trim( this_file% name_str) )

      endif close_status

   endif close_named

!  file is not connected

   nullify( current_file)

! ----------------------------------------------------------------------

!  close_file() exit

return

! **********************************************************************

!  close_file()

end subroutine close_file

! **********************************************************************
! **********************************************************************

!  close_scratch() close a file and remark

subroutine close_scratch( this_file)

! **********************************************************************

!  close_scratch() interface

! ----------------------------------------------------------------------

!  the scratch file to be closed

type( file_t), target, intent( inout) :: this_file

! **********************************************************************

!  close_scratch() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  close the scratch file

   close( unit= this_file% logical_unit, &
          status= 'DELETE', &
          iostat= this_file% io_status)

   close_status: if( this_file% io_status > 0 )then

      current_file => this_file

      call msg_quit( "can't close scratch file: <scratch>")

   endif close_status

! ----------------------------------------------------------------------

!  close_scratch() exit

return

! **********************************************************************

!  close_scratch()

end subroutine close_scratch

! **********************************************************************
! **********************************************************************

!  set_option_defaults() set options to their default values

subroutine set_option_defaults

! **********************************************************************

!  Some options are initially set to absurd values in order to allow
!  the command line option to override the corresponding setfile directive.
!  These options need to be set to useful values after the setfile
!  has been initially read but before coco further executes.

!  These options are: the alter mode and the wrap length.

!  The options selected are also made mutually consistent.

! **********************************************************************

!  set_option_defaults() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  if the command line or the setfile hasn't set the alter state, set it to the default

   alter_default: if( options% alter_state == alter_none )then

      options% alter_state = alter_shift_3

   endif alter_default

!  if the command line or the setfile hasn't set the wrap length, set it to the default

   wrap_default: if( options% wrap_length == wrap_none )then

      options% wrap_length = free_format_len

   endif wrap_default

! ----------------------------------------------------------------------

!  ensure the correct relationship among the options

! ----------------------------------------------------------------------

!  edit specific items only if editing generally

   options% edit_date = options% edit_date .and. options% edit_source
   options% edit_file = options% edit_file .and. options% edit_source
   options% edit_integers = options% edit_integers .and. options% edit_source
   options% edit_macros = options% edit_macros .and. options% edit_source

! ----------------------------------------------------------------------

!  report specific items only if reporting generally

   options% args_in_parens = options% args_in_parens .and. options% print_summary
   options% report_extensions = options% report_extensions .and. options% print_summary
   options% warn_undeclared = options% warn_undeclared .and. options% print_summary
   options% verbose_mode = options% verbose_mode .and. options% print_summary

! ----------------------------------------------------------------------

!  set_option_defaults() exit

return

! **********************************************************************

!  set_option_defaults()

end subroutine set_option_defaults

! **********************************************************************
! **********************************************************************

!  msg_quit() process error and stop

subroutine msg_quit( msg)

! **********************************************************************

!  msg_quit() interface

! ----------------------------------------------------------------------

!  the error message

character( len= *), intent( in) :: msg

! **********************************************************************

!  msg_quit() local

! ----------------------------------------------------------------------

!  strings conatining the line number and iostat of the failed operation

   character( len= conversion_len) :: number_str

   character( len= conversion_len) :: iostat_str

! **********************************************************************

!  msg_quit() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  if file is associated with this error

   file_msg: if( associated( current_file) )then

!  if a line is associated with this error

      line_msg: if( associated( current_file% line) )then

         write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( current_file% line)

      endif line_msg

!  if io error caused this error

      io_error: if( current_file% io_status > 0 )then

!  decode line number & iostat

         write( unit= number_str, fmt= conversion_fmt) current_file% lines_transfered

         write( unit= iostat_str, fmt= conversion_fmt) current_file% io_status

!  write error message with file data

         write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( 'coco error: file: ' &
                // trim( current_file% name_str) // ', line: ' // trim( adjustl( number_str)) &
                // ', ' // ', iostat: ' // trim( adjustl( iostat_str)) // ': ' // msg)

!  if io error caused not this error

      else io_error

!  decode line number

         write( unit= number_str, fmt= conversion_fmt) current_file% lines_transfered

!  write error message with file data

         write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( 'coco error: file: ' &
                // trim( current_file% name_str) // ', line: ' // trim( adjustl( number_str)) &
                // ', ' // msg)

      endif io_error

!  if file associated not with this error

   else file_msg

!  write error message without file data

      write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( 'coco error: ' // msg)

   endif file_msg

! ----------------------------------------------------------------------

!  msg_quit() exit

stop 'coco error exit'

! **********************************************************************

!  msg_quit()

end subroutine msg_quit

! **********************************************************************
! **********************************************************************

!  msg_continue() print message or continue processing

subroutine msg_continue( msg)

! **********************************************************************

!  msg_continue() interface

! ----------------------------------------------------------------------

!  the warning or informational message

character( len= *), intent( in) :: msg

! **********************************************************************

!  msg_continue() local

! ----------------------------------------------------------------------

!  string containing the current input line number

   character( len= conversion_len) :: number_str

! **********************************************************************

!  msg_continue() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  if file associated with this message

   file_msg: if( associated( current_file) )then

!  decode line number

      write( unit= number_str, fmt= conversion_fmt) current_file% lines_transfered

!  write message with file data

      write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( 'coco message: file: ' &
             // trim( current_file% name_str) // ', line: ' // trim( adjustl( number_str)) &
             // ': ' // msg)

!  if file associated not with this message

   else file_msg

!  write message without file data

      write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( 'coco message: ' // msg)

   endif file_msg

! ----------------------------------------------------------------------

!  msg_continue() exit

return

! **********************************************************************

!  msg_continue()

end subroutine msg_continue                                       

! **********************************************************************
! **********************************************************************

!  process_command_line() process command line

subroutine process_command_line

! **********************************************************************

!  process_command_line calls getopt() to get any options, then
!  process_command_line gets filenames from the command line

! **********************************************************************

!  default coco filenames constants

! **********************************************************************

!  input filename constants

! ----------------------------------------------------------------------

!  suffix used to construct input filename if one name is on the command line

   character( len= *), parameter :: input_suffix = dot // 'fpp'

! **********************************************************************

!  output filename constants

! ----------------------------------------------------------------------

!  suffix used to construct output filename if one name is on the command line

   character( len= *), parameter :: output_suffix = dot // 'f90'

! **********************************************************************

!  setfile constants

! ----------------------------------------------------------------------

!  suffix used to construct setfile name if name is on the command line

   character( len= *), parameter :: set_suffix = dot // 'set'

! **********************************************************************

!  suffix length

   integer, parameter :: suffix_len = &
         max( len( input_suffix), len( output_suffix), len( set_suffix) )

! **********************************************************************

!  other command line constants

! ----------------------------------------------------------------------

!  coco usage (error message)

   character( len= *), parameter :: usage_msg = &
      'usage: coco [ -V  | -h | [[opts] [ basename | output input [...]]]'

! **********************************************************************

!  coco communicate with getopt()

! ----------------------------------------------------------------------

!  valid option letters

   character( len= *), parameter :: opt_letters = 'a:dD:efF:hiI:l:mnprsuvVw: '

! **********************************************************************

!  process_command_line local

! ----------------------------------------------------------------------

!  getopt() option letter

   integer :: optltr

!  input filenames

   character( len= buffer_len) :: argword

!  dot divides basename and suffix

   integer :: basename_len

!  loop through input filenames

   integer :: this_word

!  allocation status

   integer :: astat

! **********************************************************************

!  process_command_line() text

! ----------------------------------------------------------------------

continue

!  get number of command line args

   nargs = command_argument_count()

!  do until end of args is returned

   optltr = getopt( opt_letters)

!  process options

   cl_options: do while( optltr /= end_of_args)

!  select which option

      which_option: select case( char( optltr))

! ----------------------------------------------------------------------

!  set the alter state

      case( 'a') which_option

         call process_alter_option( optarg)

!  turn off ?date? & ?time? editing

      case( 'd') which_option

         options% edit_date = .false.

!  declare a symbol

      case( 'D') which_option

         call process_symbol_option( optarg)

!  turn off source editing

      case( 'e') which_option

         options% edit_source = .false.

!  turn off ?file? & ?line? editing

      case( 'f') which_option

         options% edit_file = .false.

!  write a documentation file

      case( 'F') which_option

         doc_file% name_str = optarg

         doc_file% named_file = .true.

         call open_file( doc_file)

!  help

      case( 'h') which_option

         call print_help

         stop 'coco normal exit'

!  turn off ?integer? & ?logical? editing

      case( 'i') which_option

         options% edit_integers = .false.

!  set directories to search for include files

      case( 'I') which_option

         call process_include_option( optarg)

!  set logfile (NOTE: optarg has len= filename_len, so no overflow can occur.)

      case( 'l') which_option

         log_file% logical_unit = log_unit

         log_file% name_str = optarg

         log_file% named_file = .true.

         call open_file( log_file)

!  turn off ?macro? editing

      case( 'm') which_option

         options% edit_macros = .false.

!  turn on line numbers

      case( 'n') which_option

         options% number_source = .true.

!  turn on (arg) checking

      case( 'p') which_option

         options% args_in_parens = .true.

!  turn on reporting extensions

      case( 'r') which_option

         options% report_extensions = .true.

!  turn off summary report

      case( 's') which_option

         options% print_summary = .false.

!  turn off undefined report

      case( 'u') which_option

         options% warn_undeclared = .true.

!  turn on verbose

      case( 'v') which_option

         options% verbose_mode = .true.

!  print coco version data

      case( 'V') which_option

         write( unit= error_unit, fmt= string_fmt) coco_rcs_id

         stop 'coco normal exit'

!  turn off wrapping source output

      case( 'w') which_option

         call process_wrap_value( optarg)

!  command line error

      case default which_option

         write( unit= error_unit, fmt= string_fmt) usage_msg

         stop 'coco normal exit'

      end select which_option

! ----------------------------------------------------------------------

      optltr = getopt( opt_letters)

   enddo cl_options

! ----------------------------------------------------------------------

!  the rest of the command line words (if any) must be file names

! ----------------------------------------------------------------------

!  number of command line args left unprocessed

   args_left: if( optarg == unknown_option )then

      number_of_names = nargs - optind

      optind = optind + 1

      no_more_args: if( number_of_names > 0 )then

         call get_command_argument( number= optind, value= optarg)

      endif no_more_args

   else args_left

      number_of_names = nargs - optind + 1

   endif args_left

! ----------------------------------------------------------------------

!  process filenames

   filenames: select case( number_of_names)

! ----------------------------------------------------------------------

!  one filename arg

   case( 1) filenames

!  check that basename is not too long

      base_too_long: if( ( len_trim( optarg) + suffix_len) > filename_len )then

         call msg_quit( 'filename too long: ' // trim( optarg) )

      endif base_too_long

!  use basename to make input filename

      input_file% logical_unit = read_unit

      input_file% named_file = .true.

      input_file% name_str = trim( optarg) // input_suffix

!  use basename to make output filename

      output_file% logical_unit = write_unit

      output_file% named_file = .true.

      output_file% name_str = trim( optarg) // output_suffix

!  use basename to make setfile filename

      set_file% logical_unit = set_unit

      set_file% named_file = .true.

      set_file% name_str = trim( optarg) // set_suffix

! ----------------------------------------------------------------------

!  more than one filename arg

   case( 2: ) filenames

!  read source from read_unit

      input_file% logical_unit = read_unit

      input_file% named_file = .true.

!  allocate source file list

      allocate( source_file_list( 2: number_of_names), stat= astat)

      alloc_error: if( astat > 0 )then

         call msg_quit( "can't allocate input file array")

      endif alloc_error

!  check that output name is not too long

      output_too_long: if( len_trim( optarg) > filename_len )then

         call msg_quit( 'output filename too long: ' // trim( optarg) )

      endif output_too_long

!  set up output file

      output_file% logical_unit = write_unit

      output_file% named_file = .true.

      output_file% name_str = optarg

!  compute setfile name

      basename_len = index( output_file% name_str, dot, back= .true.)

      no_dot: if( basename_len == 0 )then

         basename_len = len_trim( output_file% name_str) + len( dot)

      endif no_dot

!  check that setfile name is not too long

      set_too_long: if( basename_len + suffix_len > filename_len )then

         call msg_quit( 'setfile name too long: ' // trim( output_file% name_str) // set_suffix )

      endif set_too_long

!  set up setfile

      set_file% logical_unit = set_unit

      set_file% named_file = .true.

      set_file% name_str = output_file% name_str( : basename_len - len( dot)) // set_suffix

!  record input files in source file list

      list_inputs: do this_word = 2, number_of_names

!  establish the components of this input file except the name

         source_file_list( this_word) = input_file

!  get next arg string

         optind = optind + 1

         call get_command_argument( number= optind, value= argword)

!  check that output name is not too long

         next_too_long: if( len_trim( argword) > filename_len )then

            call msg_quit( 'input filename too long: ' // trim( optarg) )

         endif next_too_long

         source_file_list( this_word)% name_str = argword

      enddo list_inputs

!  only possible values

   end select filenames

! ----------------------------------------------------------------------

!  process_command_line() exit

return

! **********************************************************************

!  process_command_line()

end subroutine process_command_line

! **********************************************************************
! **********************************************************************

!  getopt() return next known option from command line or unknown

integer function getopt( optstring)

! **********************************************************************

!  getopt() interface

! ----------------------------------------------------------------------

!  the string of valid option letters

character( len= *), intent( in) :: optstring

! **********************************************************************

!  getopt() constants

! ----------------------------------------------------------------------

!  special characters

   character( len= *), parameter :: dash = '-'

   character( len= *), parameter :: colon = ':'

! **********************************************************************

!  getopt() local

! ----------------------------------------------------------------------

!  argument buffer

   character( len= filename_len) :: optword

!  index in optstring

   integer :: index_optstring

! **********************************************************************

!  getopt() text

continue

! ----------------------------------------------------------------------

!  initialize for next option

   check_inc: if( optind >= nargs )then

      optarg = unknown_option
      getopt = end_of_args

      return

   endif check_inc

! ----------------------------------------------------------------------

!  get next option

   optind = optind + 1

   call get_command_argument( number= optind, value= optword)

!  if word is not -?

   not_an_option: if( optword( 1: 1) /= dash )then

      optarg = optword
      getopt = end_of_args

      return

!  if word is --

   elseif( optword( 2: 2) == dash )then not_an_option

      optarg = unknown_option
      getopt = end_of_args

      return

   endif not_an_option

! ----------------------------------------------------------------------

!  optword is -x (not --)

   index_optstring = index( optstring, optword( 2: 2))

   is_opt: if( index_optstring > 0 )then

!  if this optltr must have another word

      opt_string: if( optstring( index_optstring + 1: index_optstring + 1) == colon )then

!  it can be separated by a blank

         next_word: if( optword( 3: 3) == blank )then

            optind = optind + 1
            call get_command_argument( number= optind, value= optarg)

!  or not be separated by a blank

         else next_word

            optarg = optword( 3: )

         endif next_word

      endif opt_string

      getopt = ichar( optword( 2: 2))

!  if this optltr must not have another word

   else is_opt

      optarg = optword
      getopt = ichar( unknown_option)

   endif is_opt

! ----------------------------------------------------------------------

!  getopt() exit

return

! **********************************************************************

!  getopt()

end function getopt                                               

! **********************************************************************
! **********************************************************************

!  %%% process particular command line options

! **********************************************************************
! **********************************************************************

!  process_alter_option() process alter arguments

subroutine process_alter_option( alter_opt)

! **********************************************************************

!  process_alter_option() interface

! ----------------------------------------------------------------------

!  the alter option from the command line

character( len= *), intent( in) :: alter_opt                        

! **********************************************************************

!  entry: alter_opt is command line arg following -a
!         "d" | "b" | "0" | "1" | "3"

!  exit: alter_opt is processed or error exit

! **********************************************************************

!  process_alter_option() constants

! ----------------------------------------------------------------------

!  possible alter option strings

   character( len= *), parameter :: delete_str = 'd'

   character( len= *), parameter :: blank_str = 'b'

   character( len= *), parameter :: shift0_str = '0'

   character( len= *), parameter :: shift1_str = '1'

   character( len= *), parameter :: shift3_str = '3'

! **********************************************************************

!  process_alter_option() local

! ----------------------------------------------------------------------

!  decoding the option is done in lower case which may require a case change

   character( len= 1) :: lower_case_opt

! **********************************************************************

!  process_alter_option() text

continue

! ----------------------------------------------------------------------

!  check for unknown option

   too_long: if( len_trim( alter_opt) > 1 )then

      call msg_quit( "unknown -a option: " // trim( alter_opt) )

   endif too_long

!  force arg to lower case

   fix_case: select case( alter_opt( 1: 1))

   case( 'A': 'Z') fix_case

      lower_case_opt = achar( iachar( alter_opt( 1: 1)) + change_case)

   case default fix_case

      lower_case_opt = alter_opt

   end select fix_case

! ----------------------------------------------------------------------

!  legal alter argument or error

   alter_value_str: select case( lower_case_opt)

!  alter delete

   case( delete_str) alter_value_str

      options% alter_state = alter_delete

!  alter blank

   case( blank_str) alter_value_str

      options% alter_state = alter_blank

!  alter shift1

   case( shift1_str) alter_value_str

      options% alter_state = alter_shift_1

!  alter shift0

   case( shift0_str) alter_value_str

      options% alter_state = alter_shift_0

!  alter shift3

   case( shift3_str) alter_value_str

      options% alter_state = alter_shift_3

!  unknown alter code ( not one of { b, d, 0, 1, 3 } )

   case default alter_value_str

      call msg_quit( "unknown -a option: " // trim( alter_opt) )

!  legal alter statement or error

   end select alter_value_str

! ----------------------------------------------------------------------

!  process_alter_option() exit

return

! **********************************************************************

!  process_alter_option()

end subroutine process_alter_option

! **********************************************************************
! **********************************************************************

!  process_symbol_option() process define arguments

subroutine process_symbol_option( symbol_opt)

! **********************************************************************

!  process_symbol_option() interface

! ----------------------------------------------------------------------

!  the symbol string from the command line

character( len= *), intent( in) :: symbol_opt                       

! **********************************************************************

!  entry: symbol_opt is string following -D { log | int=val }

!  exit: symbol_opt is processed or error exit

! **********************************************************************

!  process_symbol_option() constants

! ----------------------------------------------------------------------

   character( len= *), parameter :: log_value_str = '=.true.'

! **********************************************************************

!  process_symbol_option() local

! ----------------------------------------------------------------------

!  find characters

   integer :: next_char

!  construct a declaration string to process

   character( len= filename_len) :: decl_str

! **********************************************************************

!  process_symbol_option() text

continue

! ----------------------------------------------------------------------

!  force names to lower case

   each_char: do next_char = 1, len( symbol_opt)

      to_lower: select case( symbol_opt( next_char: next_char))

      case( 'A': 'Z') to_lower

         decl_str( next_char: next_char) = achar( iachar( symbol_opt( next_char: next_char)) + change_case)

      case default to_lower

         decl_str( next_char: next_char) = symbol_opt( next_char: next_char)

      end select to_lower

   enddo each_char

! ----------------------------------------------------------------------

!  an equal sign must separate a value from the name

   next_char = index( decl_str, equals)

!  if there's an equals, it's an integer

   int_or_log: if( next_char > 0 )then

!  declare the integer constant

      call process_integer_constant( decl_str)

!  if there's no equals, it's a logical ( = .true.)

   else int_or_log

!  construct the logical (it's true)

      decl_str = trim( decl_str) // log_value_str

!  declare the logical constant

      call process_logical_constant( decl_str)

!  integer or logical

   endif int_or_log

! ----------------------------------------------------------------------

!  if reporting use of extensions

   extensions: if( options% report_extensions )then

      call msg_continue( "defined symbol from command line: " // trim( symbol_opt))

   endif extensions

! ----------------------------------------------------------------------

!  process_symbol_option() exit

return

! **********************************************************************

!  process_symbol_option()

end subroutine process_symbol_option

! **********************************************************************
! **********************************************************************

!  print_help() write summary report to specified unit

subroutine print_help

! **********************************************************************

!  entry: in response to -h command line option

!  exit: print help message

! **********************************************************************

!  print_help() constants

! ----------------------------------------------------------------------

!  the help message

   character( len= *), dimension( 20), parameter :: help_msg = (/ &
                      ' -a ?           set alter state, ? = { b, d, 0, 1, 3}       ', &
                      ' -d             turn off ?date? & ?time? editing            ', &
                      ' -D name[=n]    declare integer or logical constant         ', &
                      ' -e             turn off all source editing                 ', &
                      ' -f             turn off ?file? & ?line? editing            ', &
                      ' -F file        write documentation text to file            ', &
                      ' -h             print this help message and quit            ', &
                      ' -i             turn off ?integer? & ?logical? editing      ', &
                      ' -I dir         search dir for include files (after .)      ', &
                      ' -l file        write log messages to file (default stderr) ', &
                      ' -m             turn off ?macro? editing                    ', &
                      ' -n             print line numbers on source lines          ', &
                      ' -p             warn when actual args might need parenthesis', &
                      ' -r             report all use of extensions                ', &
                      ' -s             work silently, print no summary             ', &
                      ' -u             report setfile symbols undefined in source  ', &
                      ' -v             report file opening and closing             ', &
                      ' -V             print coco version and quit                 ', &
                      ' -w n           wrap lines to n columns (0= off, 72= fixed) ', &
                      ' --             optionally separate options from file names ' /)

! **********************************************************************

!  print_help() local

! ----------------------------------------------------------------------

!  implied do variable

   integer :: do_idx

! **********************************************************************

!  print_help() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

   write( unit= error_unit, fmt= string_fmt) ( trim( help_msg( do_idx)), do_idx= 1, size( help_msg))

! ----------------------------------------------------------------------

!  print_help() exit

return

! **********************************************************************

!  print_help()

end subroutine print_help

! **********************************************************************
! **********************************************************************

!  process_include_option() process include directory options

subroutine process_include_option( directory_opt)

! **********************************************************************

!  process_include_option() interface

! ----------------------------------------------------------------------

!  the directory string from the command line

character( len= *), intent( in) :: directory_opt                   

! **********************************************************************

!  entry: directory_opt is a directory to be added to the list
!         of directories to be searched for inlcude files

!  exit: directory_opt is on the list

! **********************************************************************

!  process_include_option() local

! ----------------------------------------------------------------------

!  point to a directory type

   type( path_t), pointer :: path_ptr

!  unquote the directory name if needed

   character( len= filename_len) :: directory_str

!  lengths of quoted string

   integer :: quoted_len

!  lengths of unquoted string

   integer :: unquoted_len

! **********************************************************************

!  process_include_option() text

continue

! ----------------------------------------------------------------------

!  if the directory is quoted, unquote it

   is_quoted: select case( directory_opt( 1: 1) )

   case( single_quote, double_quote) is_quoted

      call unquote_string( directory_opt, directory_str, quoted_len, unquoted_len)

      null_unquoted: if( quoted_len == 0 .or. unquoted_len == 0 )then

         call msg_quit( "null name passed to -I option")

      endif null_unquoted

   case default is_quoted

      directory_str = directory_opt

   end select is_quoted

! ----------------------------------------------------------------------

!  if name is already on the path

   nullify( path_ptr)

   call seek_directory( directory_str, path_ptr)

   on_list_or_add: if( associated( path_ptr) )then

      call msg_continue( "redundant include directory ignored: " // trim( directory_opt) )

   else on_list_or_add

      call add_directory( directory_str)

!  if reporting use of extensions

      extensions: if( options% report_extensions )then

         call msg_continue( "added include directory from command line: " // trim( directory_opt) )

      endif extensions

   endif on_list_or_add

! ----------------------------------------------------------------------

!  process_include_option() exit

return

! **********************************************************************

!  process_include_option()

end subroutine process_include_option

! **********************************************************************
! **********************************************************************

!  write_options() write summary report to specified unit

subroutine write_options

! **********************************************************************

!  write_options() constants

! ----------------------------------------------------------------------

!  possible alter states

integer, parameter :: lower_alter = min( alter_delete, alter_blank, alter_shift_1, alter_shift_0, alter_shift_3)

integer, parameter :: upper_alter = max( alter_delete, alter_blank, alter_shift_1, alter_shift_0, alter_shift_3)

!  possible alter state labels

character( len= 16), dimension( lower_alter: upper_alter), parameter :: alter_labels = (/ &
                                       'deleted         ', &
                                       'blank line      ', &
                                       'initial !       ', &
                                       'shifted 1 + !   ', &
                                       'shifted 3 + !?> ' /)

! **********************************************************************

!  write_options() local

! ----------------------------------------------------------------------

!  construct output lines

   character( len= source_line_len) :: output_line

! **********************************************************************

!  write_options() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  write a header

   write( unit= log_file% logical_unit, fmt= log_file% format_str) "coco options:"

! ----------------------------------------------------------------------

!  identify the alter state

   check_index: select case( options% alter_state)

   case( lower_alter: upper_alter) check_index

      output_line = 'alter state causes lines to be ' // alter_labels( options% alter_state)

   case default check_index

      output_line = 'alter state is undefined'

   end select check_index

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether editing date & time

   edit_date_time: if( options% edit_date )then

      output_line = 'editing ' // date_str // ' and ' // time_str // ' strings'

   else edit_date_time

      output_line = 'not editing ' // date_str // ' and ' // time_str // ' strings'

   endif edit_date_time

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether editing file & line

   edit_file_line: if( options% edit_file )then

      output_line = 'editing ' // file_str // ' and ' // line_str // ' strings'

   else edit_file_line

      output_line = 'not editing ' // file_str // ' and ' // line_str // ' strings'

   endif edit_file_line

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether editing at all

   edit_control: if( options% edit_source )then

      output_line = 'editing source lines'

   else edit_control

      output_line = 'not editing source lines'

   endif edit_control

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether editing integers and logicals

   edit_ints_logs: if( options% edit_integers )then

      output_line = 'editing integer and logicals'

   else edit_ints_logs

      output_line = 'not editing integer and logicals'

   endif edit_ints_logs

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether editing macros

   edit_macro: if( options% edit_macros )then

      output_line = 'editing macros'

   else edit_macro

      output_line = 'not editing macros'

   endif edit_macro

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether warning whether args have enclosing parens

   edit_parens: if( options% args_in_parens )then

      output_line = 'warning when macro & text actual args are not enclosed in parenthesis'

   else edit_parens

      output_line = 'not warning when macro & text actual args are not enclosed in parenthesis'

   endif edit_parens

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether reporting extensions

   rpt_exten: if( options% report_extensions )then

      output_line = 'reporting coco extensions'

   else rpt_exten

      output_line = 'not reporting coco extensions'

   endif rpt_exten

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether printing coco summary

   rpt_prt: if( options% print_summary )then

      output_line = 'printing coco report'

   else rpt_prt

      output_line = 'not printing coco report'

   endif rpt_prt

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether printing "! file: line" on source lines

   rpt_number: if( options% number_source )then

      output_line = 'numbering source lines'

   else rpt_number

      output_line = 'not numbering source lines'

   endif rpt_number

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether warning when symbol is in setfile but not source

   rpt_warn: if( options% warn_undeclared )then

      output_line = 'warning when setfile symbols not in source'

   else rpt_warn

      output_line = 'not warning when setfile symbols not in source'

   endif rpt_warn

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether verbose mode is on

   rpt_verbose: if( options% verbose_mode )then

      output_line = 'verbose mode is on'

   else rpt_verbose

      output_line = 'verbose mode is off'

   endif rpt_verbose

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line)

!  identify whether verbose mode is on

   rpt_wrap: if( options% wrap_length /= wrap_off )then

      output_line = 'wrapping source lines at length '

   else rpt_wrap

      output_line = 'not wrapping source lines'

   endif rpt_wrap

   write( unit= log_file% logical_unit, fmt= log_file% format_str) trim( output_line) // blank, options% wrap_length

! ----------------------------------------------------------------------

!  write_options() exit

return

! **********************************************************************

!  write_options()

end subroutine write_options

! **********************************************************************
! **********************************************************************

!  write_report() write summary report to specified unit

subroutine write_report

! **********************************************************************

!  write_report() local

! ----------------------------------------------------------------------

!  print date and time in header

   character( len= 8) :: today

   character( len= 10) :: now

! ----------------------------------------------------------------------

!  print include path

   type( path_t), pointer :: path_ptr

!  search lists for symbols not defined in the coco program proper

   type( symbol_t), pointer :: symbol_ptr

! ----------------------------------------------------------------------

!  print input files

   integer :: this_file

! **********************************************************************

!  write_report() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  banner includes the date and time

   call date_and_time( date= today, time= now)

   write( unit= log_file% logical_unit, fmt= log_file% format_str) 'coco executed: ' // today // blank // now

! ----------------------------------------------------------------------

!  identify the setfile

   write( unit= log_file% logical_unit, fmt= log_file% format_str) 'setfile: ' // trim( set_file% name_str)

! ----------------------------------------------------------------------

!  identify the output file

   write( unit= log_file% logical_unit, fmt= log_file% format_str) 'output: ' // trim( output_file% name_str)

! ----------------------------------------------------------------------

!  identify the input file(s)

   one_or_more: if( allocated( source_file_list) )then

      write( unit= log_file% logical_unit, fmt= log_file% format_str, advance= 'NO') 'input:'

      more_than_one: do this_file = 2, number_of_names

         write( unit= log_file% logical_unit, fmt= log_file% format_str, advance= 'NO') &
                blank // trim( source_file_list( this_file)% name_str)

      enddo more_than_one

      write( unit= log_file% logical_unit, fmt= log_file% format_str)

   else one_or_more

      write( unit= log_file% logical_unit, fmt= log_file% format_str) 'input: ' // trim( input_file% name_str)

   endif one_or_more

! ----------------------------------------------------------------------

!  identify the document file, if there is one

   got_doc: if( doc_file% named_file )then

      write( unit= log_file% logical_unit, fmt= log_file% format_str) &
         'docfile: ' // trim( doc_file% name_str), doc_file% lines_transfered

   endif got_doc

! ----------------------------------------------------------------------

!  identify the include path

   write( unit= log_file% logical_unit, fmt= log_file% format_str, advance= 'NO') 'include path: .'

   nullify( path_ptr)

   path_ptr => first_directory

   inc_path: do while( associated( path_ptr) )

      write( unit= log_file% logical_unit, fmt= directory_fmt, advance= 'NO') &
             blank // trim( path_ptr% name_str) // open_paren, path_ptr% times_accessed, close_paren

      path_ptr => path_ptr% next

   enddo inc_path

!  end line using null string

   write( unit= log_file% logical_unit, fmt= log_file% format_str)

! ----------------------------------------------------------------------

!  if undefined symbols report is requested

   undefined_complaints: if( options% warn_undeclared )then

!  complain about any integers or logicals declared in the setfile but not in source

      nullify( symbol_ptr)

      symbol_ptr => first_symbol

      search_syms: do while( associated( symbol_ptr))

         found_sym: if( symbol_ptr% predefined )then

            write( unit= log_file% logical_unit, fmt= log_file% format_str) &
               'symbol declared in setfile but not in any source file: ' // trim( symbol_ptr% name_str)

         endif found_sym

         symbol_ptr => symbol_ptr% next

      enddo search_syms

   endif undefined_complaints

! ----------------------------------------------------------------------

!  number of files read

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'files read: ', total% input_files

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'include files read: ', total% include_files

!  number of setfile lines read

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'set lines read: ', set_file% lines_transfered

!  number of coco lines read

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'coco lines read: ', total% coco_lines

!  number of source lines read

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'source lines read: ', total% input_lines

!  number of lines written

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'source lines written: ', output_file% lines_transfered

!  number of selected lines written

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'selected source lines: ', total% selected_lines

!  number of elided lines

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'elided source lines: ', total% elided_lines

!  number of text blocks read

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'text blocks read: ', total% text_blocks

!  number of text lines read

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'text lines read: ', total% text_lines

!  number of text lines written

   write( unit= log_file% logical_unit, fmt= log_file% format_str) &
          'text lines written: ', total% copied_lines

! ----------------------------------------------------------------------

!  write_report() exit

return

! **********************************************************************

!  write_report()

end subroutine write_report

! **********************************************************************
! **********************************************************************

!  process_wrap_value() set the wrap length option length

subroutine process_wrap_value( number_str)

! **********************************************************************

!  process_wrap_value() interface

! ----------------------------------------------------------------------

!  the wrap length string from the command line

character( len= *), intent( in) :: number_str

! **********************************************************************

!  process_wrap_value() local

! ----------------------------------------------------------------------

!  index of a non-digit

   integer :: char_idx

!  convert string to characters

   character( len= conversion_len) :: conversion_str

!  test proposed wrap length

   integer :: wrap_len

! **********************************************************************

!  process_wrap_value() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  legal wrap string value or error

   bad_char: if( char_idx > 0 )then

      char_idx = verify( number_str, digit_chars)

      call msg_quit( "bad character in wrap length: " // trim( number_str))

   endif bad_char

! ----------------------------------------------------------------------

!  convert chacacters to integer

   conversion_str = number_str

   conversion_str = adjustr( conversion_str)

   read( unit= conversion_str, fmt= conversion_fmt) wrap_len

! ----------------------------------------------------------------------

!  check proposed wrap length

   set_within_bounds: select case( wrap_len)

!  do no wrapping

   case( 0) set_within_bounds

      options% wrap_length = wrap_off

!  within bounds so accept as if

   case( fixed_format_len: free_format_len) set_within_bounds

      options% wrap_length = wrap_len

!  out of bounds so set within bounds

   case default set_within_bounds

      call msg_continue( "invalid wrap length set within bounds: " // trim( number_str))

      options% wrap_length = min( free_format_len, max( fixed_format_len, wrap_len))

   end select set_within_bounds

! ----------------------------------------------------------------------

!  process_wrap_value() exit

return

! **********************************************************************

!  process_wrap_value()

end subroutine process_wrap_value

! **********************************************************************
! **********************************************************************

!  %%% seek and process the setfile (if any)

! **********************************************************************
! **********************************************************************

!  seek_setfile() write summary report to specified unit

subroutine seek_set_file                                            

! **********************************************************************

!  seek_set_file constants

! ----------------------------------------------------------------------

!  default set_file name

   character( len= *), parameter :: default_name = 'coco.set'

! **********************************************************************

!  seek_set_file() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  see if there is name for the set_file

   named_set_file: if( set_file% named_file )then

!  inquire by file looking for named setfile

      inquire( file= set_file% name_str, exist= set_file% named_file, iostat= set_file% io_status)

      inq_named: if( set_file% io_status > 0 )then

         call msg_quit( "can't inquire setfile: " // trim( set_file% name_str))

      endif inq_named

!  done checking setfile name

   endif named_set_file

! ----------------------------------------------------------------------

!  no named setfile so try to find the default setfile

   default_set_file: if( .not. set_file% named_file )then

!  inquire by file looking for default setfile

      inquire( file= default_name, exist= set_file% named_file, iostat= set_file% io_status)

      inq_default: if( set_file% io_status > 0 )then

         call msg_quit( "can't inquire default setfile: " // default_name)

      endif inq_default

!  if found the default setfile ensure the variable correctly specifies it

      use_default: if( set_file% named_file )then

         set_file% logical_unit = set_unit

         set_file% name_str = default_name

      endif use_default

   endif default_set_file

! ----------------------------------------------------------------------

!  if have setfile, open it, process it, close it

   read_set_file: if( set_file% named_file )then

      call process_set_file

   else read_set_file

      set_file% name_str = '<no setfile>'

   endif read_set_file

   processing_set_file = .false.

! ----------------------------------------------------------------------

!  seek_set_file() exit

return

! **********************************************************************

!  seek_set_file()

end subroutine seek_set_file

! **********************************************************************
! **********************************************************************

!  process_sefile() open, process, close the coco setfile

subroutine process_set_file                                         

! **********************************************************************

!  process_set_file() steps

!  1. open the setfile
!  2. open the set scratch file
!  2. read the setfile line by line
!  3. call blank_compress_lower_case() to construct a coco statement
!  4. ignore coco comments
!  5. call process_set_statement() to process coco set statement
!  6. close setfile

! **********************************************************************

!  process_set_file() local

! ----------------------------------------------------------------------

!  process the setfile statement by statement

   character( len= buffer_len) :: set_statement

! ----------------------------------------------------------------------

!  signal complete statement

   logical :: complete

! **********************************************************************

!  process_set_file() text

continue

! ----------------------------------------------------------------------

!  open the setfile for reading

   call open_file( set_file)

! ----------------------------------------------------------------------

!  count files processed

   total% input_files = total% input_files + 1

!  as if finished a complete statement at beginning of file

   complete = .true.

! ----------------------------------------------------------------------

!  main read setfile lines loop

   read_lines: do

! ----------------------------------------------------------------------

!  read a setfile line

      read( unit= set_file% logical_unit, fmt= set_file% format_str, iostat= set_file% io_status) set_file% line

      read_set: if( set_file% io_status > 0 )then

         call msg_quit( "can't read setfile: " // trim( set_file% name_str))

      endif read_set

! ----------------------------------------------------------------------

!  read until end of file

      read_eof: if( set_file% io_status < 0 )then

!  reset statement processing for the next file

         call blank_compress_lower_case( set_statement, null_string)

!  if in a statement continuation sequence

         premature_eof: if( .not. complete )then

            call msg_quit( "end of file encountered within a continuation sequence")

         endif premature_eof

!  exit the read lines loop

         exit read_lines

      endif read_eof

!  count setfile lines

      set_file% lines_transfered = set_file% lines_transfered + 1

! ----------------------------------------------------------------------

!  process setfile lines or error if source lines

      coco_line: if( line( : len( coco_key)) == coco_key )then

!  count coco lines

         total% coco_lines = total% coco_lines + 1

!  process setfile lines, ignore coco comments

         coco_statement: if( is_coco_statement( line( len( coco_key) + 1: )) )then

! ----------------------------------------------------------------------

!  read a complete statement line by line

            call gather_coco_statement( line, set_statement, complete)

!  if not yet a complete statement go get the rest of it

            get_statement: if( .not. complete )then

               cycle read_lines

            endif get_statement

!  process the complete setfile statement

            call process_set_statement( set_statement)

!  process setfile lines, ignore coco comments

         endif coco_statement

!  source line in setfile

      else coco_line

         call msg_quit( "source lines are not allowed in the setfile")

!  end processing set statements

      endif coco_line

! ----------------------------------------------------------------------

!  end main read setfile lines loop

   enddo read_lines

   total% input_lines = total% input_lines + set_file% lines_transfered

! ----------------------------------------------------------------------

!  close the setfile

   call close_file( set_file)

! ----------------------------------------------------------------------

!  process_set_file() exit

return

! **********************************************************************

!  process_set_file()

end subroutine process_set_file

! **********************************************************************
! **********************************************************************

!  copy_set_file() copy setfile to output file

subroutine copy_set_file                                             

! **********************************************************************

!  copy_set_file() text

! ----------------------------------------------------------------------

continue

! ----------------------------------------------------------------------

!  open the set file

   call open_file( set_file)

! ----------------------------------------------------------------------

!  copy each line

   copy_lines: do

!  read a line

      read( unit= set_file% logical_unit, fmt= set_file% format_str, &
            iostat= set_file% io_status) set_file% line

      read_set_file: if( set_file% io_status > 0 )then

         call msg_quit( "can't copy setfile")

      endif read_set_file

!  read entire scratch file

      set_eof: if( set_file% io_status < 0 )then

         exit copy_lines

      endif set_eof

!  write a line

      call write_coco_line( output_file)

   enddo copy_lines

! ----------------------------------------------------------------------

!  close the setfile

   call close_file( set_file)

! ----------------------------------------------------------------------

!  copy_set_file() exit

return

! **********************************************************************

!  copy_set_file()

end subroutine copy_set_file

! **********************************************************************
! **********************************************************************

!  %%% process statements many of which may appear only in the setfile

! **********************************************************************
! **********************************************************************

!  process_set_statement() process set line

subroutine process_set_statement( set_stmt)

! **********************************************************************

!  process_set_statement() interface

! ----------------------------------------------------------------------

!  the statement string from the set file

character( len= *), intent( in) :: set_stmt                       

! **********************************************************************

!  entry: set_stmt is blank_compress_lower_case set statement past the coco key
!         "alter:..." | "integer..." | "logical..." | "directory'...'" |
!         "wrap:..." | "edit:..." | "warn:..." | "logfile'...'" |
!         "summary:..." | "verbose:..." | "doc'...'" | "parens:..."

!  exit: set_stmt is processed or error exit

! **********************************************************************

!  process_set_statement() text

continue

! ----------------------------------------------------------------------

!  catergorize setfile statement: alter, integer, logical, directory, wrap

! ----------------------------------------------------------------------

!  if the directive is an alter directive

   which_directive: if( set_stmt( : len( alter_str)) == alter_str )then

      call process_alter_directive( set_stmt( len( alter_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile integer declaration

   elseif( set_stmt( : len( integer_str)) == integer_str )then which_directive

      call process_integer_declaration( set_stmt( len( integer_str) + 1: ) )

! ----------------------------------------------------------------------

!  integer constant declaration

   elseif( set_stmt( : len( integer_constant_str)) == integer_constant_str )then which_directive

      call process_integer_constant( set_stmt( len( integer_constant_str) + 1: ))

! ----------------------------------------------------------------------

!  if the directive is a setfile logical declaration

   elseif( set_stmt( : len( logical_str)) == logical_str )then which_directive

      call process_logical_declaration( set_stmt( len( logical_str) + 1: ) )

! ----------------------------------------------------------------------

!  logical constant declaration

   elseif( set_stmt( : len( logical_constant_str)) == logical_constant_str )then which_directive

      call process_logical_constant( set_stmt( len( logical_constant_str) + 1: ))

! ----------------------------------------------------------------------

!  if the directive is a setfile directory directive

   elseif( set_stmt( : len( directory_str)) == directory_str )then which_directive

      call process_directory_directive( set_stmt( len( directory_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile docfile directive

   elseif( set_stmt( : len( docfile_str)) == docfile_str )then which_directive

      call process_docfile_directive( set_stmt( len( docfile_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile logfile directive

   elseif( set_stmt( : len( logfile_str)) == logfile_str )then which_directive

      call process_logfile_directive( set_stmt( len( logfile_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile wrap directive

   elseif( set_stmt( : len( wrap_str)) == wrap_str )then which_directive

      call process_wrap_directive( set_stmt( len( wrap_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile edit directive

   elseif( set_stmt( : len( edit_str)) == edit_str )then which_directive

      call process_edit_directive( set_stmt( len( edit_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile summary directive

   elseif( set_stmt( : len( summary_str)) == summary_str )then which_directive

      call process_summary_directive( set_stmt( len( summary_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile number: directive

   elseif( set_stmt( : len( number_str)) == number_str )then which_directive

      call process_number_directive( set_stmt( len( number_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile parens directive

   elseif( set_stmt( : len( parens_str)) == parens_str )then which_directive

      call process_paren_directive( set_stmt( len( parens_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile warn directive

   elseif( set_stmt( : len( warn_str)) == warn_str )then which_directive

      call process_warn_directive( set_stmt( len( warn_str) + 1: ) )

! ----------------------------------------------------------------------

!  if the directive is a setfile verbose directive

   elseif( set_stmt( : len( verbose_str)) == verbose_str )then which_directive

      call process_verbose_directive( set_stmt( len( verbose_str) + 1: ) )

! ----------------------------------------------------------------------

!  otherwise complain about the unknown directive

   else which_directive

      call msg_quit( "unknown setfile directive: " // trim( set_stmt) )

!  catergorize setfile statement: alter or integer or logical

   endif which_directive

! ----------------------------------------------------------------------

!  process_set_statement() exit

return

! **********************************************************************

!  process_set_statement()

end subroutine process_set_statement

! **********************************************************************
! **********************************************************************

!  process_alter_directive() process alter directives

subroutine process_alter_directive( alter_dir)

! **********************************************************************

!  process_alter_directive() interface

! ----------------------------------------------------------------------

!  the alter directive from the setfile

character( len= *), intent( in) :: alter_dir                        

! **********************************************************************

!  entry: alter_dir is blank_compress_lower_case alter directive past the colon
!         "delete" | "blank" | "shift0" | "shift1" | "shift3"

!  exit: alter_dir is processed or error exit

! **********************************************************************

!  process_alter_directive() constants

! ----------------------------------------------------------------------

!  possible alter strings

   character( len= *), parameter :: delete_str = 'delete'

   character( len= *), parameter :: blank_str = 'blank'

   character( len= *), parameter :: shift0_str = 'shift0'

   character( len= *), parameter :: shift1_str = 'shift1'

   character( len= *), parameter :: shift3_str = 'shift3'

! **********************************************************************

!  process_alter_directive() local

! ----------------------------------------------------------------------

!  count number of some statements to disallow more than one

   logical, save :: too_many_alter_statements = .false.

! **********************************************************************

!  process_alter_directive() text

continue

! ----------------------------------------------------------------------

!  only one alter directive per setfile

   too_many_alters: if( too_many_alter_statements )then

      call msg_quit( "too many alter statements")

   else too_many_alters

      too_many_alter_statements = .true.

   endif too_many_alters

!  if the alter state has not been set from the command line

   not_set: if( options% alter_state == alter_none )then

! ----------------------------------------------------------------------

!  legal alter statement or error

! ----------------------------------------------------------------------

!  decode alter state

      alter_value_str: select case( alter_dir)

 !  alter delete

     case( delete_str) alter_value_str

         options% alter_state = alter_delete

!  alter blank

      case( blank_str) alter_value_str

         options% alter_state = alter_blank

!  alter shift1

      case( shift1_str) alter_value_str

         options% alter_state = alter_shift_1

!  alter shift0

      case( shift0_str) alter_value_str

         options% alter_state = alter_shift_0

!  alter shift3

      case( shift3_str) alter_value_str

         options% alter_state = alter_shift_3

!  unknown alter

      case default alter_value_str

         call msg_quit( "unknown alter directive: " // trim( alter_dir))

!  legal alter statement or error

      end select alter_value_str

   endif not_set

! ----------------------------------------------------------------------

!  process_alter_directive() exit

return

! **********************************************************************

!  process_alter_directive()

end subroutine process_alter_directive

! **********************************************************************
! **********************************************************************

!  process_directory_directive() process include directory options

subroutine process_directory_directive( directory_dir)

! **********************************************************************

!  process_directory_directive() interface

! ----------------------------------------------------------------------

!  the directory directive from the setfile

character( len= *), intent( in) :: directory_dir                    

! **********************************************************************

!  entry: directory_opt is a directory to be added to the list
!         of directories to be searched for inlcude files

!  exit: directory_opt is on the list

! **********************************************************************

!  process_directory_directive() local

! ----------------------------------------------------------------------

!  point to a directory type

   type( path_t), pointer :: directory_ptr

!  the name of a directory

   character( len= filename_len) :: name_str

!  count length of quoted string

   integer :: directive_len

!  count length of unquoted string

   integer :: name_len

! **********************************************************************

!  process_directory_directive() text

continue

! ----------------------------------------------------------------------

!  unquote string to find path string

   call unquote_string( directory_dir, name_str, directive_len, name_len )

   no_name_str: if( name_len == 0 .or. directive_len == 0 )then

      call msg_quit( "no directory name: " // trim( directory_dir) )

   endif no_name_str

!  verify no extra characters beyond name

   extra_chars: if( directory_dir( directive_len + 1: ) /= blank )then

      call msg_quit( "extra characters after directory path name: " // trim( directory_dir))

   endif extra_chars

! ----------------------------------------------------------------------

!  if name is already on the path

   call seek_directory( name_str, directory_ptr)

   on_list_or_add: if( associated( directory_ptr) )then

      call msg_continue( "redundant include directory ignored: " // trim( directory_dir) )

!  if name is not already on the path

   else on_list_or_add

      call add_directory( name_str)

!  if reporting use of extensions

      extensions: if( options% report_extensions )then

         call msg_continue( "added include directory from setfile: " // trim( directory_dir) )

      endif extensions

   endif on_list_or_add

! ----------------------------------------------------------------------

!  process_directory_directive() exit

return

! **********************************************************************

!  process_directory_directive()

end subroutine process_directory_directive

! **********************************************************************
! **********************************************************************

!  seek_directory() return a pointer to directory_str or null()

subroutine seek_directory( name_str, directory_ptr)

! **********************************************************************

!  seek_directory() interface

! ----------------------------------------------------------------------

!  the name of the directory to seek

character( len= *), intent( in) :: name_str

!  a pointer to the directory entry if found or null()

type( path_t), pointer :: directory_ptr

! **********************************************************************

!  entry: directory_str is a directory to be added to the list
!         of directories to be searched for inlcude files

!  exit: directory_str is on the list

! **********************************************************************

!  seek_directory() text

continue

! ----------------------------------------------------------------------

!  search from beginning to end of path list

   nullify( directory_ptr)

   directory_ptr => first_directory

!  if the name is already in the path

   scan_path: do while( associated( directory_ptr) )

      found_name: if( name_str == directory_ptr% name_str )then

         exit scan_path

      endif found_name

      directory_ptr => directory_ptr% next

   enddo scan_path

! ----------------------------------------------------------------------

!  seek_directory() exit

return

! **********************************************************************

!  seek_directory()

end subroutine seek_directory

! **********************************************************************
! **********************************************************************

!  add_directory() return a pointer to directory_str or null()

subroutine add_directory( directory_str)

! **********************************************************************

!  add_directory() interface

! ----------------------------------------------------------------------

!  the name of the directory to add to the directory list

character( len= *), intent( in) :: directory_str                    

! **********************************************************************

!  entry: directory_str is a directory to be added to the list
!         of directories to be searched for inlcude files

!  exit: directory_str is on the list

! **********************************************************************

!  add_directory() local

! ----------------------------------------------------------------------

!  end of linked list, null() if no linked list yet

   type( path_t), save, pointer :: current_directory => null()

!  check allocation status

   integer :: astat

! **********************************************************************

!  add_directory() text

continue

! ----------------------------------------------------------------------

!  append to list

   start_or_append: if( associated( first_directory) )then

      allocate( current_directory% next, stat= astat)

      append_status: if( astat > 0 )then

         call msg_quit( "can't append to path list: " // trim( directory_str) )

      endif append_status

      current_directory => current_directory% next

!  start list

   else start_or_append

      allocate( first_directory, stat= astat)

      start_status: if( astat > 0 )then

         call msg_quit( "can't start path list: " // trim( directory_str) )

      endif start_status

      current_directory => first_directory

   endif start_or_append

!  update new entry

   current_directory% name_str = directory_str

   current_directory% times_accessed = 0

   nullify( current_directory% next)

! ----------------------------------------------------------------------

!  add_directory() exit

return

! **********************************************************************

!  add_directory()

end subroutine add_directory

! **********************************************************************
! **********************************************************************

!  process_docfile_directive() process include docfile options

subroutine process_docfile_directive( docfile_dir)

! **********************************************************************

!  process_docfile_directive() interface

! ----------------------------------------------------------------------

!  the docfile directive from the setfile

character( len= *), intent( in) :: docfile_dir                      

! **********************************************************************

!  entry: docfile_opt is a docfile to be added to the list
!         of directories to be searched for inlcude files

!  exit: docfile_opt is on the list

! **********************************************************************

!  process_docfile_directive() local

! ----------------------------------------------------------------------

!  the name of the file to be opened

   character( len= filename_len) :: docfile_name

!  the length of the quoted string

   integer :: quoted_len

!  the length of the unquoted string

   integer :: unquoted_len

!  count number of some statements to disallow more than one

   logical, save :: too_many_docfile_statements = .false.

! **********************************************************************

!  process_docfile_directive() text

continue

! ----------------------------------------------------------------------

!  only one docfile statement per setfile

   too_many_docfiles: if( too_many_docfile_statements )then

      call msg_quit( "too many docfile statements")

   else too_many_docfiles

      too_many_docfile_statements = .true.

   endif too_many_docfiles

!  unquote string on directive

   call unquote_string( docfile_dir, docfile_name, unquoted_len, quoted_len)

   no_name: if( unquoted_len == 0 .or. quoted_len == 0 )then

      call msg_quit( "no name found on docfile directive: " // trim( docfile_dir) )

   endif no_name

!  verify no extra characters beyond name

   extra_chars: if( docfile_dir( unquoted_len + 1: ) /= blank )then

      call msg_quit( "extra characters after docfile file name: " // trim( docfile_dir))

   endif extra_chars

! ----------------------------------------------------------------------

!  if docfile named on command line ignore the directive

   already_named: if( doc_file% named_file )then

      call msg_continue( "command line overrides setfile, docfile directive ignored: " // trim( docfile_dir) )

!  if docfile not named on command line open the named file

   else already_named

      doc_file% name_str = docfile_name

      doc_file% named_file = .true.

      call open_file( doc_file)

   endif already_named

! ----------------------------------------------------------------------

!  process_docfile_directive() exit

return

! **********************************************************************

!  process_docfile_directive()

end subroutine process_docfile_directive

! **********************************************************************
! **********************************************************************

!  process_logfile_directive() process include logfile options

subroutine process_logfile_directive( logfile_dir)

! **********************************************************************

!  process_logfile_directive() interface

! ----------------------------------------------------------------------

!  the logfile directive from the setfile

character( len= *), intent( in) :: logfile_dir                      

! **********************************************************************

!  entry: logfile_opt is a logfile to be added to the list
!         of directories to be searched for inlcude files

!  exit: logfile_opt is on the list

! **********************************************************************

!  process_logfile_directive() local

! ----------------------------------------------------------------------

!  the name of the file to be opened

   character( len= filename_len) :: logfile_name

!  the length of the quoted string

   integer :: quoted_len

!  the length of the unquoted string

   integer :: unquoted_len

!  count number of some statements to disallow more than one

   logical, save :: too_many_logfile_statements = .false.

! **********************************************************************

!  process_logfile_directive() text

continue

! ----------------------------------------------------------------------

!  only one logfile statement per setfile

   too_many_logfiles: if( too_many_logfile_statements )then

      call msg_quit( "too many logfile statements")

   else too_many_logfiles

      too_many_logfile_statements = .true.

   endif too_many_logfiles

!  unquote string on directive

   call unquote_string( logfile_dir, logfile_name, unquoted_len, quoted_len)

   no_name: if( unquoted_len == 0 .or. quoted_len == 0 )then

      call msg_quit( "no name found on logfile directive: " // trim( logfile_dir) )

   endif no_name

!  verify no extra characters beyond name

   extra_chars: if( logfile_dir( unquoted_len + 1: ) /= blank )then

      call msg_quit( "extra characters after logfile file name: " // trim( logfile_dir))

   endif extra_chars

! ----------------------------------------------------------------------

!  if logfile named on command line ignore the directive

   already_named: if( log_file% named_file )then

      call msg_continue( "command line overrides setfile, logfile directive ignored: " // trim( logfile_dir) )

!  if logfile not named on command line open the named file

   else already_named

      log_file% logical_unit = log_unit

      log_file% name_str = logfile_name

      log_file% named_file = .true.

      call open_file( log_file)

   endif already_named

! ----------------------------------------------------------------------

!  process_logfile_directive() exit

return

! **********************************************************************

!  process_logfile_directive()

end subroutine process_logfile_directive

! **********************************************************************
! **********************************************************************

!  process_wrap_directive() process wrap directives

subroutine process_wrap_directive( wrap_dir)

! **********************************************************************

!  process_wrap_directive() interface

! ----------------------------------------------------------------------

!  the wrap directive from the setfile

character( len= *), intent( in) :: wrap_dir                         

! **********************************************************************

!  entry: wrap_dir is blank_compress_lower_case wrap directive
!         it must be a number string

!  exit: wrap_dir is processed or error exit

! **********************************************************************

!  process_wrap_directive() local

! ----------------------------------------------------------------------

!  count number of some statements to disallow more than one

   logical, save :: too_many_wrap_statements = .false.

! **********************************************************************

!  process_wrap_directive() text

continue

! ----------------------------------------------------------------------

!  only one wrap statement per setfile

   too_many_wraps: if( too_many_wrap_statements )then

      call msg_quit( "too many wrap statements")

   else too_many_wraps

      too_many_wrap_statements = .true.

   endif too_many_wraps

! ----------------------------------------------------------------------

!  process wrap value if not already set on command line

   set_on_cl: if( options% wrap_length == wrap_none )then

      call process_wrap_value( wrap_dir)

   endif set_on_cl

!  if reporting use of extensions

   extensions: if( options% report_extensions )then

      call msg_continue( "processed wrap directive from setfile: " // trim( wrap_dir) )

   endif extensions

! ----------------------------------------------------------------------

!  process_wrap_directive() exit

return

! **********************************************************************

!  process_wrap_directive()

end subroutine process_wrap_directive

! **********************************************************************
! **********************************************************************

!  process_edit_directive() process edit directives

subroutine process_edit_directive( edit_dir)

! **********************************************************************

!  process_edit_directive() interface

! ----------------------------------------------------------------------

!  the edit directive from the setfile

character( len= *), intent( in) :: edit_dir

! **********************************************************************

!  entry: edit_dir is blank_compress_lower_case edit directive
!         it must be "on" or "off"

!  exit: edit_dir is processed or error exit

! **********************************************************************

!  process_edit_directive() local

! ----------------------------------------------------------------------

!  count number of some statements to disallow more than one

   logical, save :: too_many_edit_statements = .false.

! **********************************************************************

!  process_edit_directive() text

continue

! ----------------------------------------------------------------------

!  only one edit statement per setfile

   too_many_edits: if( too_many_edit_statements )then

      call msg_quit( "too many edit statements")

   else too_many_edits

      too_many_edit_statements = .true.

   endif too_many_edits

! ----------------------------------------------------------------------

!  process edit switch

   on_off: if( edit_dir == on_str )then

      options% edit_source = .true.

   elseif( edit_dir == off_str)then on_off

      options% edit_source = .false.

   else on_off

      call msg_quit( "unknown option on edit directive: " // trim( edit_dir) )

   endif on_off

!  if reporting use of extensions

   extensions: if( options% report_extensions )then

      call msg_continue( "processed edit directive from setfile: " // trim( edit_dir) )

   endif extensions

! ----------------------------------------------------------------------

!  process_edit_directive() exit

return

! **********************************************************************

!  process_edit_dir