Index: trunk/src/parsing/parsing.nw =================================================================== --- trunk/src/parsing/parsing.nw (revision 8828) +++ trunk/src/parsing/parsing.nw (revision 8829) @@ -1,6123 +1,6123 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: text handling and parsing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Text handling} \includemodulegraph{parsing} \whizard\ has to handle complex structures in input (and output) data. Doing this in a generic and transparent way requires a generic lexer and parser. The necessary modules are implemented here: \begin{description} \item[ifiles] Implementation of line-oriented internal files in a more flexible way (linked lists of variable-length strings) than the Fortran builtin features. \item[lexers] Read text and transform it into a token stream. \item[syntax\_rules] Define the rules for interpreting tokens, to be used by the WHIZARD parser. \item[parser] Categorize tokens (keyword, string, number etc.) and use a set of syntax rules to transform the input into a parse tree. \item[xml] Read and parse XML text, separate from the WHIZARD parser. \end{description} @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Internal files} The internal files introduced here ([[ifile]]) are a replacement for the built-in internal files, which are fixed-size arrays of fixed-length character strings. The [[ifile]] type is a doubly-linked list of variable-length character strings with line numbers. <<[[ifiles.f90]]>>= <> module ifiles <> <> <> <> <> interface <> end interface end module ifiles @ %def ifiles @ <<[[ifiles_sub.f90]]>>= <> submodule (ifiles) ifiles_s use system_defs, only: EOF use io_units implicit none contains <> end submodule ifiles_s @ %def ifiles_s @ \subsection{The line type} The line entry type is for internal use, it is the list entry to be collected in an [[ifile]] object. <>= type :: line_entry_t private type(line_entry_t), pointer :: previous => null () type(line_entry_t), pointer :: next => null () type(string_t) :: string integer :: index end type line_entry_t @ %def line_entry_t @ Create a new list entry, given a varying string as input. The line number and pointers are not set, these make sense only within an [[ifile]]. <>= subroutine line_entry_create (line, string) type(line_entry_t), pointer :: line type(string_t), intent(in) :: string allocate (line) line%string = string end subroutine line_entry_create @ %def line_entry_create @ Destroy a single list entry: Since the pointer components should not be deallocated explicitly, just deallocate the object itself. <>= subroutine line_entry_destroy (line) type(line_entry_t), pointer :: line deallocate (line) end subroutine line_entry_destroy @ %def line_entry_destroy @ \subsection{The ifile type} The internal file is a linked list of line entries. <>= public :: ifile_t <>= type :: ifile_t private type(line_entry_t), pointer :: first => null () type(line_entry_t), pointer :: last => null () integer :: n_lines = 0 contains <> end type ifile_t @ %def ifile_t @ We need no explicit initializer, but a routine which recursively deallocates the contents may be appropriate. After this, existing line pointers may become undefined, so they should be nullified before the file is destroyed. <>= public :: ifile_clear <>= module subroutine ifile_clear (ifile) class(ifile_t), intent(inout) :: ifile end subroutine ifile_clear <>= module subroutine ifile_clear (ifile) class(ifile_t), intent(inout) :: ifile type(line_entry_t), pointer :: current do while (associated (ifile%first)) current => ifile%first ifile%first => current%next call line_entry_destroy (current) end do nullify (ifile%last) ifile%n_lines = 0 end subroutine ifile_clear @ %def ifile_clear @ The finalizer is just an alias for the above. <>= public :: ifile_final <>= procedure :: final => ifile_clear <>= interface ifile_final module procedure ifile_clear end interface @ %def ifile_final @ \subsection{I/O on ifiles} Fill an ifile from an ordinary external file, i.e., I/O unit. If the ifile is not empty, the old contents will be destroyed. We can read a fixed-length character string, an ISO varying string, an ordinary internal file (character-string array), or from an external unit. In the latter case, lines are appended until EOF is reached. Finally, there is a variant which reads from another ifile, effectively copying it. <>= public :: ifile_read <>= interface ifile_read module procedure ifile_read_from_string module procedure ifile_read_from_char module procedure ifile_read_from_unit module procedure ifile_read_from_char_array module procedure ifile_read_from_ifile end interface <>= module subroutine ifile_read_from_string (ifile, string) type(ifile_t), intent(inout) :: ifile type(string_t), intent(in) :: string end subroutine ifile_read_from_string module subroutine ifile_read_from_char (ifile, char) type(ifile_t), intent(inout) :: ifile character(*), intent(in) :: char end subroutine ifile_read_from_char module subroutine ifile_read_from_char_array (ifile, char) type(ifile_t), intent(inout) :: ifile character(*), dimension(:), intent(in) :: char end subroutine ifile_read_from_char_array module subroutine ifile_read_from_unit (ifile, unit, iostat) type(ifile_t), intent(inout) :: ifile integer, intent(in) :: unit integer, intent(out), optional :: iostat end subroutine ifile_read_from_unit module subroutine ifile_read_from_ifile (ifile, ifile_in) type(ifile_t), intent(inout) :: ifile type(ifile_t), intent(in) :: ifile_in end subroutine ifile_read_from_ifile <>= module subroutine ifile_read_from_string (ifile, string) type(ifile_t), intent(inout) :: ifile type(string_t), intent(in) :: string call ifile_clear (ifile) call ifile_append (ifile, string) end subroutine ifile_read_from_string module subroutine ifile_read_from_char (ifile, char) type(ifile_t), intent(inout) :: ifile character(*), intent(in) :: char call ifile_clear (ifile) call ifile_append (ifile, char) end subroutine ifile_read_from_char module subroutine ifile_read_from_char_array (ifile, char) type(ifile_t), intent(inout) :: ifile character(*), dimension(:), intent(in) :: char call ifile_clear (ifile) call ifile_append (ifile, char) end subroutine ifile_read_from_char_array module subroutine ifile_read_from_unit (ifile, unit, iostat) type(ifile_t), intent(inout) :: ifile integer, intent(in) :: unit integer, intent(out), optional :: iostat call ifile_clear (ifile) call ifile_append (ifile, unit, iostat) end subroutine ifile_read_from_unit module subroutine ifile_read_from_ifile (ifile, ifile_in) type(ifile_t), intent(inout) :: ifile type(ifile_t), intent(in) :: ifile_in call ifile_clear (ifile) call ifile_append (ifile, ifile_in) end subroutine ifile_read_from_ifile @ %def ifile_read @ Append to an ifile. The same as reading, but without resetting the ifile. In addition, there is a routine for appending a whole ifile. <>= public :: ifile_append <>= generic :: append => & ifile_append_from_char procedure, private :: ifile_append_from_char <>= interface ifile_append module procedure ifile_append_from_string module procedure ifile_append_from_char module procedure ifile_append_from_unit module procedure ifile_append_from_char_array module procedure ifile_append_from_ifile end interface <>= module subroutine ifile_append_from_string (ifile, string) class(ifile_t), intent(inout) :: ifile type(string_t), intent(in) :: string end subroutine ifile_append_from_string module subroutine ifile_append_from_char (ifile, char) class(ifile_t), intent(inout) :: ifile character(*), intent(in) :: char end subroutine ifile_append_from_char module subroutine ifile_append_from_char_array (ifile, char) class(ifile_t), intent(inout) :: ifile character(*), dimension(:), intent(in) :: char end subroutine ifile_append_from_char_array module subroutine ifile_append_from_ifile (ifile, ifile_in) class(ifile_t), intent(inout) :: ifile type(ifile_t), intent(in) :: ifile_in end subroutine ifile_append_from_ifile module subroutine ifile_append_from_unit (ifile, unit, iostat) class(ifile_t), intent(inout) :: ifile integer, intent(in) :: unit integer, intent(out), optional :: iostat end subroutine ifile_append_from_unit <>= module subroutine ifile_append_from_string (ifile, string) class(ifile_t), intent(inout) :: ifile type(string_t), intent(in) :: string type(line_entry_t), pointer :: current call line_entry_create (current, string) current%index = ifile%n_lines + 1 if (associated (ifile%last)) then current%previous => ifile%last ifile%last%next => current else ifile%first => current end if ifile%last => current ifile%n_lines = current%index end subroutine ifile_append_from_string module subroutine ifile_append_from_char (ifile, char) class(ifile_t), intent(inout) :: ifile character(*), intent(in) :: char call ifile_append_from_string (ifile, var_str (trim (char))) end subroutine ifile_append_from_char module subroutine ifile_append_from_char_array (ifile, char) class(ifile_t), intent(inout) :: ifile character(*), dimension(:), intent(in) :: char integer :: i do i = 1, size (char) call ifile_append_from_string (ifile, var_str (trim (char(i)))) end do end subroutine ifile_append_from_char_array module subroutine ifile_append_from_unit (ifile, unit, iostat) class(ifile_t), intent(inout) :: ifile integer, intent(in) :: unit integer, intent(out), optional :: iostat type(string_t) :: buffer integer :: ios ios = 0 READ_LOOP: do call get (unit, buffer, iostat = ios) if (ios == EOF .or. ios > 0) exit READ_LOOP call ifile_append_from_string (ifile, buffer) end do READ_LOOP if (present (iostat)) then iostat = ios else if (ios > 0) then call get (unit, buffer) ! trigger error again end if end subroutine ifile_append_from_unit module subroutine ifile_append_from_ifile (ifile, ifile_in) class(ifile_t), intent(inout) :: ifile type(ifile_t), intent(in) :: ifile_in type(line_entry_t), pointer :: current current => ifile_in%first do while (associated (current)) call ifile_append_from_string (ifile, current%string) current => current%next end do end subroutine ifile_append_from_ifile @ %def ifile_append @ Write the ifile contents to an external unit <>= public :: ifile_write <>= module subroutine ifile_write (ifile, unit, iostat) type(ifile_t), intent(in) :: ifile integer, intent(in), optional :: unit integer, intent(out), optional :: iostat end subroutine ifile_write <>= module subroutine ifile_write (ifile, unit, iostat) type(ifile_t), intent(in) :: ifile integer, intent(in), optional :: unit integer, intent(out), optional :: iostat integer :: u type(line_entry_t), pointer :: current u = given_output_unit (unit); if (u < 0) return current => ifile%first do while (associated (current)) call put_line (u, current%string, iostat) current => current%next end do end subroutine ifile_write @ %def ifile_write @ Convert the ifile to an array of strings, which is allocated by this function: <>= public :: ifile_to_string_array <>= module subroutine ifile_to_string_array (ifile, string) type(ifile_t), intent(in) :: ifile type(string_t), dimension(:), intent(inout), allocatable :: string end subroutine ifile_to_string_array <>= module subroutine ifile_to_string_array (ifile, string) type(ifile_t), intent(in) :: ifile type(string_t), dimension(:), intent(inout), allocatable :: string type(line_entry_t), pointer :: current integer :: i allocate (string (ifile_get_length (ifile))) current => ifile%first do i = 1, ifile_get_length (ifile) string(i) = current%string current => current%next end do end subroutine ifile_to_string_array @ %def ifile_to_string_array @ \subsection{Ifile tools} <>= public :: ifile_get_length <>= module function ifile_get_length (ifile) result (length) integer :: length type(ifile_t), intent(in) :: ifile end function ifile_get_length <>= module function ifile_get_length (ifile) result (length) integer :: length type(ifile_t), intent(in) :: ifile length = ifile%n_lines end function ifile_get_length @ %def ifile_get_length @ \subsection{Line pointers} Instead of the implicit pointer used in ordinary file access, we define explicit pointers, so there can be more than one at a time. <>= public :: line_p <>= type :: line_p private type(line_entry_t), pointer :: p => null () end type line_p @ %def line @ Assign a file pointer to the first or last line in an ifile: <>= public :: line_init <>= module subroutine line_init (line, ifile, back) type(line_p), intent(inout) :: line type(ifile_t), intent(in) :: ifile logical, intent(in), optional :: back end subroutine line_init <>= module subroutine line_init (line, ifile, back) type(line_p), intent(inout) :: line type(ifile_t), intent(in) :: ifile logical, intent(in), optional :: back if (present (back)) then if (back) then line%p => ifile%last else line%p => ifile%first end if else line%p => ifile%first end if end subroutine line_init @ %def line_init @ Remove the pointer association: <>= public :: line_final <>= module subroutine line_final (line) type(line_p), intent(inout) :: line end subroutine line_final <>= module subroutine line_final (line) type(line_p), intent(inout) :: line nullify (line%p) end subroutine line_final @ %def line_final @ Go one step forward <>= public :: line_advance <>= module subroutine line_advance (line) type(line_p), intent(inout) :: line end subroutine line_advance <>= module subroutine line_advance (line) type(line_p), intent(inout) :: line if (associated (line%p)) line%p => line%p%next end subroutine line_advance @ %def line_advance @ Go one step backward <>= public :: line_backspace <>= module subroutine line_backspace (line) type(line_p), intent(inout) :: line end subroutine line_backspace <>= module subroutine line_backspace (line) type(line_p), intent(inout) :: line if (associated (line%p)) line%p => line%p%previous end subroutine line_backspace @ %def line_backspace @ Check whether we are accessing a valid line <>= public :: line_is_associated <>= module function line_is_associated (line) result (ok) logical :: ok type(line_p), intent(in) :: line end function line_is_associated <>= module function line_is_associated (line) result (ok) logical :: ok type(line_p), intent(in) :: line ok = associated (line%p) end function line_is_associated @ %def line_is_associated @ \subsection{Access lines via pointers} We do not need the ifile as an argument to these functions, because the [[line]] type will point to an existing ifile. <>= public :: line_get_string <>= module function line_get_string (line) result (string) type(string_t) :: string type(line_p), intent(in) :: line end function line_get_string <>= module function line_get_string (line) result (string) type(string_t) :: string type(line_p), intent(in) :: line if (associated (line%p)) then string = line%p%string else string = "" end if end function line_get_string @ %def line_get_string @ Variant where the line pointer is advanced after reading. <>= public :: line_get_string_advance <>= module function line_get_string_advance (line) result (string) type(string_t) :: string type(line_p), intent(inout) :: line end function line_get_string_advance <>= module function line_get_string_advance (line) result (string) type(string_t) :: string type(line_p), intent(inout) :: line if (associated (line%p)) then string = line%p%string call line_advance (line) else string = "" end if end function line_get_string_advance @ %def line_get_string_advance <>= public :: line_get_index <>= module function line_get_index (line) result (index) integer :: index type(line_p), intent(in) :: line end function line_get_index <>= module function line_get_index (line) result (index) integer :: index type(line_p), intent(in) :: line if (associated (line%p)) then index = line%p%index else index = 0 end if end function line_get_index @ %def line_get_index <>= public :: line_get_length <>= module function line_get_length (line) result (length) integer :: length type(line_p), intent(in) :: line end function line_get_length <>= module function line_get_length (line) result (length) integer :: length type(line_p), intent(in) :: line if (associated (line%p)) then length = len (line%p%string) else length = 0 end if end function line_get_length @ %def line_get_length @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Lexer} The lexer purpose is to read from a line-separated character input stream (usually a file) and properly chop the stream into lexemes (tokens). [The parser will transform lexemes into meaningful tokens, to be stored in a parse tree, therefore we do not use the term 'token' here.] The input is read line-by-line, but interpreted free-form, except for quotes and the comment syntax. (Fortran 2003 would allow us to use a stream type for reading.) In an object-oriented approach, we can dynamically create and destroy lexers, including the lexer setup. The main lexer function is to return a lexeme according to the basic lexer rules (quotes, comments, whitespace, special classes). There is also a routine to write back a lexeme to the input stream (but only once). For the rules, we separate the possible characters into classes. Whitespace usually consists of blank, tab, and line-feed, where any number of consecutive whitespace is equivalent to one. Quoted strings are enclosed by a pair of quote characters, possibly multiline. Comments are similar to quotes, but interpreted as whitespace. Numbers are identified (not distinguishing real and integer) but not interpreted. Other character classes make up identifiers. <<[[lexers.f90]]>>= <> module lexers <> use ifiles, only: ifile_t use ifiles, only: line_p <> <> <> <> <> interface <> end interface end module lexers @ %def lexers @ <<[[lexers_sub.f90]]>>= <> submodule (lexers) lexers_s use io_units use string_utils use system_defs, only: EOF, EOR use system_defs, only: LF - use system_defs, only: WHITESPACE_CHARS, LCLETTERS, UCLETTERS, DIGITS + use system_defs, only: WHITESPACE_CHARS, LCLETTERS, UCLETTERS, DIGIT_CHARS use ifiles, only: line_get_string_advance use ifiles, only: line_is_associated, line_init, line_final use diagnostics implicit none contains <> end submodule lexers_s @ %def lexers_s @ \subsection{Input streams} For flexible input, we define a generic stream type that refers to either an external file, an external unit which is already open, a string, an [[ifile]] object (internal file, i.e., string list), or a line pointer to an [[ifile]] object. The stream type actually follows the idea of a formatted external file, which is line-oriented. Thus, the stream reader always returns a whole record (input line). Note that only in the string version, the stream contents are stored inside the stream object. In the [[ifile]] version, the stream contains only the line pointer, while in the external-file case, the line pointer is implicitly created by the runtime library. <>= public :: stream_t <>= type :: stream_t type(string_t), pointer :: filename => null () integer, pointer :: unit => null () type(string_t), pointer :: string => null () type(ifile_t), pointer :: ifile => null () type(line_p), pointer :: line => null () integer :: record = 0 logical :: eof = .false. contains <> end type stream_t @ %def stream_t @ The initializers refer to the specific version. The stream should be undefined before calling this. <>= public :: stream_init <>= generic :: init => & stream_init_filename, & stream_init_unit, & stream_init_string, & stream_init_ifile, & stream_init_line procedure, private :: stream_init_filename procedure, private :: stream_init_unit procedure, private :: stream_init_string procedure, private :: stream_init_ifile procedure, private :: stream_init_line <>= interface stream_init module procedure stream_init_filename module procedure stream_init_unit module procedure stream_init_string module procedure stream_init_ifile module procedure stream_init_line end interface <>= module subroutine stream_init_filename (stream, filename) class(stream_t), intent(out) :: stream character(*), intent(in) :: filename end subroutine stream_init_filename module subroutine stream_init_unit (stream, unit) class(stream_t), intent(out) :: stream integer, intent(in) :: unit end subroutine stream_init_unit module subroutine stream_init_string (stream, string) class(stream_t), intent(out) :: stream type(string_t), intent(in) :: string end subroutine stream_init_string module subroutine stream_init_ifile (stream, ifile) class(stream_t), intent(out) :: stream type(ifile_t), intent(in) :: ifile end subroutine stream_init_ifile module subroutine stream_init_line (stream, line) class(stream_t), intent(out) :: stream type(line_p), intent(in) :: line end subroutine stream_init_line <>= module subroutine stream_init_filename (stream, filename) class(stream_t), intent(out) :: stream character(*), intent(in) :: filename integer :: unit unit = free_unit () open (unit=unit, file=filename, status="old", action="read") call stream_init_unit (stream, unit) allocate (stream%filename) stream%filename = filename end subroutine stream_init_filename module subroutine stream_init_unit (stream, unit) class(stream_t), intent(out) :: stream integer, intent(in) :: unit allocate (stream%unit) stream%unit = unit stream%eof = .false. end subroutine stream_init_unit module subroutine stream_init_string (stream, string) class(stream_t), intent(out) :: stream type(string_t), intent(in) :: string allocate (stream%string) stream%string = string end subroutine stream_init_string module subroutine stream_init_ifile (stream, ifile) class(stream_t), intent(out) :: stream type(ifile_t), intent(in) :: ifile type(line_p) :: line call line_init (line, ifile) call stream_init_line (stream, line) allocate (stream%ifile) stream%ifile = ifile end subroutine stream_init_ifile module subroutine stream_init_line (stream, line) class(stream_t), intent(out) :: stream type(line_p), intent(in) :: line allocate (stream%line) stream%line = line end subroutine stream_init_line @ %def stream_init @ The finalizer restores the initial state. If an external file was opened, it is closed. <>= public :: stream_final <>= procedure :: final => stream_final <>= module subroutine stream_final (stream) class(stream_t), intent(inout) :: stream end subroutine stream_final <>= module subroutine stream_final (stream) class(stream_t), intent(inout) :: stream if (associated (stream%filename)) then close (stream%unit) deallocate (stream%unit) deallocate (stream%filename) else if (associated (stream%unit)) then deallocate (stream%unit) else if (associated (stream%string)) then deallocate (stream%string) else if (associated (stream%ifile)) then call line_final (stream%line) deallocate (stream%line) deallocate (stream%ifile) else if (associated (stream%line)) then call line_final (stream%line) deallocate (stream%line) end if end subroutine stream_final @ %def stream_final @ This returns the next record from the input stream. Depending on the stream type, the stream pointers are modified: Reading from external unit, the external file is advanced (implicitly). Reading from string, the string is replaced by an empty string. Reading from [[ifile]], the line pointer is advanced. Note that the [[iostat]] argument is mandatory. <>= public :: stream_get_record <>= module subroutine stream_get_record (stream, string, iostat) type(stream_t), intent(inout) :: stream type(string_t), intent(out) :: string integer, intent(out) :: iostat end subroutine stream_get_record <>= module subroutine stream_get_record (stream, string, iostat) type(stream_t), intent(inout) :: stream type(string_t), intent(out) :: string integer, intent(out) :: iostat if (associated (stream%unit)) then if (stream%eof) then iostat = EOF else call get (stream%unit, string, iostat=iostat) if (iostat == EOR) then iostat = 0 stream%record = stream%record + 1 end if if (iostat == EOF) then iostat = 0 stream%eof = .true. if (len (string) /= 0) stream%record = stream%record + 1 end if end if else if (associated (stream%string)) then if (len (stream%string) /= 0) then string = stream%string stream%string = "" iostat = 0 stream%record = stream%record + 1 else string = "" iostat = EOF end if else if (associated (stream%line)) then if (line_is_associated (stream%line)) then string = line_get_string_advance (stream%line) iostat = 0 stream%record = stream%record + 1 else string = "" iostat = EOF end if else call msg_bug (" Attempt to read from uninitialized input stream") end if end subroutine stream_get_record @ %def stream_get_record @ Return the current stream source as a message string. <>= public :: stream_get_source_info_string <>= module function stream_get_source_info_string (stream) result (string) type(string_t) :: string type(stream_t), intent(in) :: stream end function stream_get_source_info_string <>= module function stream_get_source_info_string (stream) result (string) type(string_t) :: string type(stream_t), intent(in) :: stream character(20) :: buffer if (associated (stream%filename)) then string = "File '" // stream%filename // "' (unit = " write (buffer, "(I0)") stream%unit string = string // trim (buffer) // ")" else if (associated (stream%unit)) then write (buffer, "(I0)") stream%unit string = "Unit " // trim (buffer) else if (associated (stream%string)) then string = "Input string" else if (associated (stream%ifile) .or. associated (stream%line)) then string = "Internal file" else string = "" end if end function stream_get_source_info_string @ %def stream_get_source_info_string @ Return the index of the record just read as a message string. <>= public :: stream_get_record_info_string <>= module function stream_get_record_info_string (stream) result (string) type(string_t) :: string type(stream_t), intent(in) :: stream end function stream_get_record_info_string <>= module function stream_get_record_info_string (stream) result (string) type(string_t) :: string type(stream_t), intent(in) :: stream character(20) :: buffer string = stream_get_source_info_string (stream) if (string /= "") string = string // ", " write (buffer, "(I0)") stream%record string = string // "line " // trim (buffer) end function stream_get_record_info_string @ %def stream_get_record_info_string @ \subsection{Keyword list} The lexer should be capable of identifying a token as a known keyword. To this end, we store a list of keywords: <>= public :: keyword_list_t <>= type :: keyword_entry_t private type(string_t) :: string type(keyword_entry_t), pointer :: next => null () end type keyword_entry_t type :: keyword_list_t private type(keyword_entry_t), pointer :: first => null () type(keyword_entry_t), pointer :: last => null () end type keyword_list_t @ %def keyword_entry_t keyword_list_t @ Add a new string to the keyword list, unless it is already there: <>= public :: keyword_list_add <>= module subroutine keyword_list_add (keylist, string) type(keyword_list_t), intent(inout) :: keylist type(string_t), intent(in) :: string end subroutine keyword_list_add <>= module subroutine keyword_list_add (keylist, string) type(keyword_list_t), intent(inout) :: keylist type(string_t), intent(in) :: string type(keyword_entry_t), pointer :: k_entry_new if (.not. keyword_list_contains (keylist, string)) then allocate (k_entry_new) k_entry_new%string = string if (associated (keylist%first)) then keylist%last%next => k_entry_new else keylist%first => k_entry_new end if keylist%last => k_entry_new end if end subroutine keyword_list_add @ %def keyword_list_add @ Return true if a string is a keyword. <>= public :: keyword_list_contains <>= module function keyword_list_contains (keylist, string) result (found) type(keyword_list_t), intent(in) :: keylist type(string_t), intent(in) :: string logical :: found end function keyword_list_contains <>= module function keyword_list_contains (keylist, string) result (found) type(keyword_list_t), intent(in) :: keylist type(string_t), intent(in) :: string logical :: found found = .false. call check_rec (keylist%first) contains recursive subroutine check_rec (k_entry) type(keyword_entry_t), pointer :: k_entry if (associated (k_entry)) then if (k_entry%string /= string) then call check_rec (k_entry%next) else found = .true. end if end if end subroutine check_rec end function keyword_list_contains @ %def keyword_list_contains @ Write the keyword list <>= public :: keyword_list_write <>= interface keyword_list_write module procedure keyword_list_write_unit end interface <>= module subroutine keyword_list_write_unit (keylist, unit) type(keyword_list_t), intent(in) :: keylist integer, intent(in) :: unit end subroutine keyword_list_write_unit <>= module subroutine keyword_list_write_unit (keylist, unit) type(keyword_list_t), intent(in) :: keylist integer, intent(in) :: unit write (unit, "(A)") "Keyword list:" if (associated (keylist%first)) then call keyword_write_rec (keylist%first) write (unit, *) else write (unit, "(1x,A)") "[empty]" end if contains recursive subroutine keyword_write_rec (k_entry) type(keyword_entry_t), intent(in), pointer :: k_entry if (associated (k_entry)) then write (unit, "(1x,A)", advance="no") char (k_entry%string) call keyword_write_rec (k_entry%next) end if end subroutine keyword_write_rec end subroutine keyword_list_write_unit @ %def keyword_list_write @ Clear the keyword list <>= public :: keyword_list_final <>= module subroutine keyword_list_final (keylist) type(keyword_list_t), intent(inout) :: keylist end subroutine keyword_list_final <>= module subroutine keyword_list_final (keylist) type(keyword_list_t), intent(inout) :: keylist call keyword_destroy_rec (keylist%first) nullify (keylist%last) contains recursive subroutine keyword_destroy_rec (k_entry) type(keyword_entry_t), pointer :: k_entry if (associated (k_entry)) then call keyword_destroy_rec (k_entry%next) deallocate (k_entry) end if end subroutine keyword_destroy_rec end subroutine keyword_list_final @ %def keyword_list_final @ \subsection{Lexeme templates} This type is handled like a rudimentary regular expression. It determines the lexer behavior when matching a string. The actual objects made from this type and the corresponding matching routines are listed below. <>= type :: template_t !!! !!! Compiler bug in ifort 20/21/22: no structure constants for !!! !!! types with private components in submodules possible !!! private integer :: type character(256) :: charset1, charset2 integer :: len1, len2 end type template_t @ %def template_t @ These are the types that valid lexemes can have: <>= public :: T_KEYWORD, T_IDENTIFIER, T_QUOTED, T_NUMERIC <>= integer, parameter :: T_KEYWORD = 1 integer, parameter :: T_IDENTIFIER = 2, T_QUOTED = 3, T_NUMERIC = 4 @ %def T_KEYWORD T_IDENTIFIER T_QUOTED T_NUMERIC @ These are special types: <>= integer, parameter :: EMPTY = 0, WHITESPACE = 10 integer, parameter :: NO_MATCH = 11, IO_ERROR = 12, OVERFLOW = 13 integer, parameter :: UNMATCHED_QUOTE = 14 @ %def EMPTY WHITESPACE NO_MATCH IO_ERROR OVERFLOW UNMATCHED_QUOTE @ In addition, we have [[EOF]] which is a negative integer, normally $-1$. @ Printout for debugging: <>= subroutine lexeme_type_write (type, unit) integer, intent(in) :: type integer, intent(in) :: unit select case (type) case (EMPTY); write(unit,"(A)",advance="no") " EMPTY " case (WHITESPACE); write(unit,"(A)",advance="no") " WHITESPACE " case (T_IDENTIFIER);write(unit,"(A)",advance="no") " IDENTIFIER " case (T_QUOTED); write(unit,"(A)",advance="no") " QUOTED " case (T_NUMERIC); write(unit,"(A)",advance="no") " NUMERIC " case (IO_ERROR); write(unit,"(A)",advance="no") " IO_ERROR " case (OVERFLOW); write(unit,"(A)",advance="no") " OVERFLOW " case (UNMATCHED_QUOTE); write(unit,"(A)",advance="no") " UNMATCHEDQ " case (NO_MATCH); write(unit,"(A)",advance="no") " NO_MATCH " case (EOF); write(unit,"(A)",advance="no") " EOF " case default; write(unit,"(A)",advance="no") " [illegal] " end select end subroutine lexeme_type_write subroutine template_write (tt, unit) type(template_t), intent(in) :: tt integer, intent(in) :: unit call lexeme_type_write (tt%type, unit) write (unit, "(A)", advance="no") "'" // tt%charset1(1:tt%len1) // "'" write (unit, "(A)", advance="no") " '" // tt%charset2(1:tt%len2) // "'" end subroutine template_write @ %def template_write @ The matching functions all return the number of matched characters in the provided string. If this number is zero, the match has failed. The [[template]] functions are declared [[pure]] because they appear in [[forall]] loops below. A template for whitespace: <>= pure function template_whitespace (chars) result (tt) character(*), intent(in) :: chars type(template_t) :: tt tt = template_t (WHITESPACE, chars, "", len (chars), 0) end function template_whitespace @ %def template_whitespace @ Just match the string against the character set. <>= subroutine match_whitespace (tt, s, n) type(template_t), intent(in) :: tt character(*), intent(in) :: s integer, intent(out) :: n n = verify (s, tt%charset1(1:tt%len1)) - 1 if (n < 0) n = len (s) end subroutine match_whitespace @ %def match_whitespace @ A template for normal identifiers. To match, a lexeme should have a first character in class [[chars1]] and an arbitrary number of further characters in class [[chars2]]. If the latter is empty, we are looking for a single-character lexeme. <>= pure function template_identifier (chars1, chars2) result (tt) character(*), intent(in) :: chars1, chars2 type(template_t) :: tt tt = template_t (T_IDENTIFIER, chars1, chars2, len(chars1), len(chars2)) end function template_identifier @ %def template_identifier @ Here, the first letter must match, the others may or may not. <>= subroutine match_identifier (tt, s, n) type(template_t), intent(in) :: tt character(*), intent(in) :: s integer, intent(out) :: n if (verify (s(1:1), tt%charset1(1:tt%len1)) == 0) then n = verify (s(2:), tt%charset2(1:tt%len2)) if (n == 0) n = len (s) else n = 0 end if end subroutine match_identifier @ %def match_identifier @ A template for quoted strings. The same template applies for comments. The first character set indicates the left quote (could be a sequence of several characters), the second one the matching right quote. <>= pure function template_quoted (chars1, chars2) result (tt) character(*), intent(in) :: chars1, chars2 type(template_t) :: tt tt = template_t (T_QUOTED, chars1, chars2, len (chars1), len (chars2)) end function template_quoted @ %def template_quoted @ Here, the beginning of the string must exactly match the first character set, then we look for the second one. If found, return. If there is a first quote but no second one, return a negative number, indicating this error condition. <>= subroutine match_quoted (tt, s, n, range) type(template_t), intent(in) :: tt character(*), intent(in) :: s integer, intent(out) :: n integer, dimension(2), intent(out) :: range character(tt%len1) :: ch1 character(tt%len2) :: ch2 integer :: i ch1 = tt%charset1 if (s(1:tt%len1) == ch1) then ch2 = tt%charset2 do i = tt%len1 + 1, len (s) - tt%len2 + 1 if (s(i:i+tt%len2-1) == ch2) then n = i + tt%len2 - 1 range(1) = tt%len1 + 1 range(2) = i - 1 return end if end do n = -1 range = 0 else n = 0 range = 0 end if end subroutine match_quoted @ %def match_quoted @ A template for real numbers. The first character set is the set of allowed exponent letters. In accordance with the other functions we return the lexeme as a string but do not read it. <>= pure function template_numeric (chars) result (tt) character(*), intent(in) :: chars type(template_t) :: tt tt = template_t (T_NUMERIC, chars, "", len (chars), 0) end function template_numeric @ %def template_numeric @ A numeric lexeme may be real or integer. We purposely do not allow for a preceding sign. If the number is followed by an exponent, this is included, otherwise the rest is ignored. There is a possible pitfall with this behavior: while the string [[1e3]] will be interpreted as a single number, the analogous string [[1a3]] will be split into the number [[1]] and an identifier [[a3]]. There is no easy way around such an ambiguity. We should make sure that the syntax does not contain identifiers like [[a3]] or [[e3]]. <>= subroutine match_numeric (tt, s, n) type(template_t), intent(in) :: tt character(*), intent(in) :: s integer, intent(out) :: n integer :: i, n0 character(10), parameter :: digits = "0123456789" character(2), parameter :: signs = "-+" n = verify (s, digits) - 1 if (n < 0) then n = 0 return else if (s(n+1:n+1) == ".") then i = verify (s(n+2:), digits) - 1 if (i < 0) then n = len (s) return else if (i > 0 .or. n > 0) then n = n + 1 + i end if end if n0 = n if (n > 0) then if (verify (s(n+1:n+1), tt%charset1(1:tt%len1)) == 0) then n = n + 1 if (verify (s(n+1:n+1), signs) == 0) n = n + 1 i = verify (s(n+1:), digits) - 1 if (i < 0) then n = len (s) else if (i == 0) then n = n0 else n = n + i end if end if end if end subroutine match_numeric @ %def match_numeric @ The generic matching routine. With Fortran 2003 we would define separate types and use a SELECT TYPE instead. <>= subroutine match_template (tt, s, n, range) type(template_t), intent(in) :: tt character(*), intent(in) :: s integer, intent(out) :: n integer, dimension(2), intent(out) :: range select case (tt%type) case (WHITESPACE) call match_whitespace (tt, s, n) range = 0 case (T_IDENTIFIER) call match_identifier (tt, s, n) range(1) = 1 range(2) = len_trim (s) case (T_QUOTED) call match_quoted (tt, s, n, range) case (T_NUMERIC) call match_numeric (tt, s, n) range(1) = 1 range(2) = len_trim (s) case default call msg_bug ("Invalid lexeme template encountered") end select end subroutine match_template @ %def match_template @ Match against an array of templates. Return the index of the first template that matches together with the number of characters matched and the range of the relevant substring. If all fails, these numbers are zero. <>= subroutine match (tt, s, n, range, ii) type(template_t), dimension(:), intent(in) :: tt character(*), intent(in) :: s integer, intent(out) :: n integer, dimension(2), intent(out) :: range integer, intent(out) :: ii integer :: i do i = 1, size (tt) call match_template (tt(i), s, n, range) if (n /= 0) then ii = i return end if end do n = 0 ii = 0 end subroutine match @ %def match @ \subsection{The lexer setup} This object contains information about character classes. As said above, one class consists of quoting chars (matching left and right), another one of comment chars (similar), a class of whitespace, and several classes of characters that make up identifiers. When creating the lexer setup, the character classes are transformed into lexeme templates which are to be matched in a certain predefined order against the input stream. BLANK should always be taken as whitespace, some things may depend on this. TAB is also fixed by convention, but may in principle be modified. Newline (DOS!) and linefeed are also defined as whitespace. @ The lexer setup, containing the list of lexeme templates. No defaults yet. The type with index zero will be assigned to the [[NO_MATCH]] lexeme. The keyword list is not stored, just a pointer to it. We anticipate that the keyword list is part of the syntax table, and the lexer needs not alter it. Furthermore, the lexer is typically finished before the syntax table is. <>= integer, parameter :: CASE_KEEP = 0, CASE_UP = 1, CASE_DOWN = 2 @ %def CASE_KEEP CASE_UP CASE_DOWN <>= type :: lexer_setup_t private type(template_t), dimension(:), allocatable :: tt integer, dimension(:), allocatable :: type integer :: keyword_case = CASE_KEEP type(keyword_list_t), pointer :: keyword_list => null () end type lexer_setup_t @ %def lexer_setup @ Fill the lexer setup object. Some things are hardcoded here (whitespace, alphanumeric identifiers), some are free: comment chars (but these must be single, and comments must be terminated by line-feed), quote chars and matches (must be single), characters to be read as one-character lexeme, special classes (characters of one class that should be glued together as identifiers). <>= subroutine lexer_setup_init (setup, & comment_chars, quote_chars, quote_match, & single_chars, special_class, & keyword_list, upper_case_keywords) type(lexer_setup_t), intent(inout) :: setup character(*), intent(in) :: comment_chars character(*), intent(in) :: quote_chars, quote_match character(*), intent(in) :: single_chars character(*), dimension(:), intent(in) :: special_class type(keyword_list_t), pointer :: keyword_list logical, intent(in), optional :: upper_case_keywords integer :: n, i if (present (upper_case_keywords)) then if (upper_case_keywords) then setup%keyword_case = CASE_UP else setup%keyword_case = CASE_DOWN end if else setup%keyword_case = CASE_KEEP end if n = 1 + len (comment_chars) + len (quote_chars) + 1 & + len (single_chars) + size (special_class) + 1 allocate (setup%tt(n)) allocate (setup%type(0:n)) n = 0 setup%type(n) = NO_MATCH n = n + 1 setup%tt(n) = template_whitespace (WHITESPACE_CHARS) setup%type(n) = EMPTY forall (i = 1:len(comment_chars)) setup%tt(n+i) = template_quoted (comment_chars(i:i), LF) setup%type(n+i) = EMPTY end forall n = n + len (comment_chars) forall (i = 1:len(quote_chars)) setup%tt(n+i) = template_quoted (quote_chars(i:i), quote_match(i:i)) setup%type(n+i) = T_QUOTED end forall n = n + len (quote_chars) setup%tt(n+1) = template_numeric ("EeDd") setup%type(n+1) = T_NUMERIC n = n + 1 forall (i = 1:len (single_chars)) setup%tt(n+i) = template_identifier (single_chars(i:i), "") setup%type(n+i) = T_IDENTIFIER end forall n = n + len (single_chars) forall (i = 1:size (special_class)) setup%tt(n+i) = template_identifier & (trim (special_class(i)), trim (special_class(i))) setup%type(n+i) = T_IDENTIFIER end forall n = n + size (special_class) setup%tt(n+1) = template_identifier & - (LCLETTERS//UCLETTERS, LCLETTERS//DIGITS//"_"//UCLETTERS) + (LCLETTERS//UCLETTERS, LCLETTERS//DIGIT_CHARS//"_"//UCLETTERS) setup%type(n+1) = T_IDENTIFIER n = n + 1 if (n /= size (setup%tt)) & call msg_bug ("Size mismatch in lexer setup") setup%keyword_list => keyword_list end subroutine lexer_setup_init @ %def lexer_setup_init @ The destructor is needed only if the object is not itself part of an allocatable array <>= subroutine lexer_setup_final (setup) type(lexer_setup_t), intent(inout) :: setup deallocate (setup%tt, setup%type) setup%keyword_list => null () end subroutine lexer_setup_final @ %def lexer_setup_final @ For debugging: Write the lexer setup <>= subroutine lexer_setup_write (setup, unit) type(lexer_setup_t), intent(in) :: setup integer, intent(in) :: unit integer :: i write (unit, "(A)") "Lexer setup:" if (allocated (setup%tt)) then do i = 1, size (setup%tt) call template_write (setup%tt(i), unit) write (unit, '(A)', advance = "no") " -> " call lexeme_type_write (setup%type(i), unit) write (unit, *) end do else write (unit, *) "[empty]" end if if (associated (setup%keyword_list)) then call keyword_list_write (setup%keyword_list, unit) end if end subroutine lexer_setup_write @ %def lexer_setup_write @ \subsection{The lexeme type} An object of this type is returned by the lexer. Apart from the lexeme string, it gives information about the relevant substring (first and last character index) and the lexeme type. Interpreting the string is up to the parser. <>= public :: lexeme_t <>= type :: lexeme_t private integer :: type = EMPTY type(string_t) :: s integer :: b = 0, e = 0 end type lexeme_t @ %def lexeme_t @ Debugging aid: <>= public :: lexeme_write <>= module subroutine lexeme_write (t, unit) type(lexeme_t), intent(in) :: t integer, intent(in) :: unit end subroutine lexeme_write <>= module subroutine lexeme_write (t, unit) type(lexeme_t), intent(in) :: t integer, intent(in) :: unit integer :: u u = given_output_unit (unit); if (u < 0) return select case (t%type) case (T_KEYWORD) write (u, *) "KEYWORD: '" // char (t%s) // "'" case (T_IDENTIFIER) write (u, *) "IDENTIFIER: '" // char (t%s) // "'" case (T_QUOTED) write (u, *) "QUOTED: '" // char (t%s) // "'" case (T_NUMERIC) write (u, *) "NUMERIC: '" // char (t%s) // "'" case (UNMATCHED_QUOTE) write (u, *) "Unmatched quote: "// char (t%s) case (OVERFLOW); write (u, *) "Overflow: "// char (t%s) case (EMPTY); write (u, *) "Empty lexeme" case (NO_MATCH); write (u, *) "No match" case (IO_ERROR); write (u, *) "IO error" case (EOF); write (u, *) "EOF" case default write (u, *) "Error" end select end subroutine lexeme_write @ %def lexeme_write @ Store string and type in a lexeme. The range determines the beginning and end of the relevant part of the string. Check for a keyword. <>= subroutine lexeme_set (t, keyword_list, s, range, type, keyword_case) type(lexeme_t), intent(out) :: t type(keyword_list_t), pointer :: keyword_list type(string_t), intent(in) :: s type(string_t) :: keyword integer, dimension(2), intent(in) :: range integer, intent(in) :: type integer, intent(in), optional :: keyword_case t%type = type if (present (keyword_case)) then select case (keyword_case) case (CASE_KEEP); keyword = s case (CASE_UP); keyword = upper_case (s) case (CASE_DOWN); keyword = lower_case (s) end select else keyword = s end if if (type == T_IDENTIFIER) then if (associated (keyword_list)) then if (keyword_list_contains (keyword_list, keyword)) & t%type = T_KEYWORD end if end if select case (t%type) case (T_KEYWORD); t%s = keyword case default; t%s = s end select t%b = range(1) t%e = range(2) end subroutine lexeme_set subroutine lexeme_clear (t) type(lexeme_t), intent(out) :: t t%type = EMPTY t%s = "" end subroutine lexeme_clear @ %def lexeme_set lexeme_clear @ Retrieve the lexeme string, the relevant part of it, and the type. The last function returns true if there is a break condition reached (error or EOF). <>= public :: lexeme_get_string public :: lexeme_get_contents public :: lexeme_get_delimiters public :: lexeme_get_type <>= module function lexeme_get_string (t) result (s) type(string_t) :: s type(lexeme_t), intent(in) :: t end function lexeme_get_string module function lexeme_get_contents (t) result (s) type(string_t) :: s type(lexeme_t), intent(in) :: t end function lexeme_get_contents module function lexeme_get_delimiters (t) result (del) type(string_t), dimension(2) :: del type(lexeme_t), intent(in) :: t end function lexeme_get_delimiters module function lexeme_get_type (t) result (type) integer :: type type(lexeme_t), intent(in) :: t end function lexeme_get_type <>= module function lexeme_get_string (t) result (s) type(string_t) :: s type(lexeme_t), intent(in) :: t s = t%s end function lexeme_get_string module function lexeme_get_contents (t) result (s) type(string_t) :: s type(lexeme_t), intent(in) :: t s = extract (t%s, t%b, t%e) end function lexeme_get_contents module function lexeme_get_delimiters (t) result (del) type(string_t), dimension(2) :: del type(lexeme_t), intent(in) :: t del(1) = extract (t%s, finish = t%b-1) del(2) = extract (t%s, start = t%e+1) end function lexeme_get_delimiters module function lexeme_get_type (t) result (type) integer :: type type(lexeme_t), intent(in) :: t type = t%type end function lexeme_get_type @ %def lexeme_get_string lexeme_get_contents lexeme_get_type @ Check for a generic break condition (error/eof) and for eof in particular. <>= public :: lexeme_is_break public :: lexeme_is_eof <>= module function lexeme_is_break (t) result (break) logical :: break type(lexeme_t), intent(in) :: t end function lexeme_is_break module function lexeme_is_eof (t) result (ok) logical :: ok type(lexeme_t), intent(in) :: t end function lexeme_is_eof <>= module function lexeme_is_break (t) result (break) logical :: break type(lexeme_t), intent(in) :: t select case (t%type) case (EOF, IO_ERROR, OVERFLOW, NO_MATCH) break = .true. case default break = .false. end select end function lexeme_is_break module function lexeme_is_eof (t) result (ok) logical :: ok type(lexeme_t), intent(in) :: t ok = t%type == EOF end function lexeme_is_eof @ %def lexeme_is_break lexeme_is_eof @ \subsection{The lexer object} We store the current lexeme and the current line. The line buffer is set each time a new line is read from file. The working buffer has one character more, to hold any trailing blank. Pointers to line and column are for debugging, they will be used to make up readable error messages for the parser. <>= public :: lexer_t <>= type :: lexer_t private type(lexer_setup_t) :: setup type(stream_t), pointer :: stream => null () type(lexeme_t) :: lexeme type(string_t) :: previous_line2 type(string_t) :: previous_line1 type(string_t) :: current_line integer :: lines_read = 0 integer :: current_column = 0 integer :: previous_column = 0 type(string_t) :: buffer type(lexer_t), pointer :: parent => null () contains <> end type lexer_t @ %def lexer_t @ Create-setup wrapper <>= public :: lexer_init <>= procedure :: init => lexer_init <>= module subroutine lexer_init (lexer, & comment_chars, quote_chars, quote_match, & single_chars, special_class, & keyword_list, upper_case_keywords, & parent) class(lexer_t), intent(inout) :: lexer character(*), intent(in) :: comment_chars character(*), intent(in) :: quote_chars, quote_match character(*), intent(in) :: single_chars character(*), dimension(:), intent(in) :: special_class type(keyword_list_t), pointer :: keyword_list logical, intent(in), optional :: upper_case_keywords type(lexer_t), target, intent(in), optional :: parent end subroutine lexer_init <>= module subroutine lexer_init (lexer, & comment_chars, quote_chars, quote_match, & single_chars, special_class, & keyword_list, upper_case_keywords, & parent) class(lexer_t), intent(inout) :: lexer character(*), intent(in) :: comment_chars character(*), intent(in) :: quote_chars, quote_match character(*), intent(in) :: single_chars character(*), dimension(:), intent(in) :: special_class type(keyword_list_t), pointer :: keyword_list logical, intent(in), optional :: upper_case_keywords type(lexer_t), target, intent(in), optional :: parent call lexer_setup_init (lexer%setup, & comment_chars = comment_chars, & quote_chars = quote_chars, & quote_match = quote_match, & single_chars = single_chars, & special_class = special_class, & keyword_list = keyword_list, & upper_case_keywords = upper_case_keywords) if (present (parent)) lexer%parent => parent call lexer_clear (lexer) end subroutine lexer_init @ %def lexer_init @ Clear the lexer state, but not the setup. This should be done when the lexing starts, but it is not known whether the lexer was used before. <>= public :: lexer_clear <>= procedure :: clear => lexer_clear <>= module subroutine lexer_clear (lexer) class(lexer_t), intent(inout) :: lexer end subroutine lexer_clear <>= module subroutine lexer_clear (lexer) class(lexer_t), intent(inout) :: lexer call lexeme_clear (lexer%lexeme) lexer%previous_line2 = "" lexer%previous_line1 = "" lexer%current_line = "" lexer%lines_read = 0 lexer%current_column = 0 lexer%previous_column = 0 lexer%buffer = "" end subroutine lexer_clear @ %def lexer_clear @ Reset lexer state and delete setup <>= public :: lexer_final <>= procedure :: final => lexer_final <>= module subroutine lexer_final (lexer) class(lexer_t), intent(inout) :: lexer end subroutine lexer_final <>= module subroutine lexer_final (lexer) class(lexer_t), intent(inout) :: lexer call lexer%clear () call lexer_setup_final (lexer%setup) end subroutine lexer_final @ %def lexer_final @ \subsection{The lexer routine} For lexing we need to associate an input stream to the lexer. <>= public :: lexer_assign_stream <>= procedure :: assign_stream => lexer_assign_stream <>= module subroutine lexer_assign_stream (lexer, stream) class(lexer_t), intent(inout) :: lexer type(stream_t), intent(in), target :: stream end subroutine lexer_assign_stream <>= module subroutine lexer_assign_stream (lexer, stream) class(lexer_t), intent(inout) :: lexer type(stream_t), intent(in), target :: stream lexer%stream => stream end subroutine lexer_assign_stream @ %def lexer_assign_stream @ The lexer. The lexer function takes the lexer and returns the currently stored lexeme. If there is none, it is read from buffer, matching against the lexeme templates in the lexer setup. Empty lexemes, i.e., comments and whitespace, are discarded and the buffer is read again until we have found a nonempty lexeme (which may also be EOF or an error condition). The initial state of the lexer contains an empty lexeme, so reading from buffer is forced. The empty state is restored after returning the lexeme. A nonempty lexeme is present in the lexer only if [[lex_back]] has been executed before. The workspace is the [[lexer%buffer]], treated as a sort of input stream. We chop off lexemes from the beginning, adjusting the buffer to the left. Whenever the buffer is empty, or we are matching against an open quote which has not terminated, we read a new line and append it to the right. This may result in special conditions, which for simplicity are also returned as lexemes: I/O error, buffer overflow, end of file. If the latter happens during reading a quoted string, we return an unmatched-quote lexeme. Obviously, the special-condition lexemes have to be caught by the parser. Note that reading further lines is only necessary when reading a quoted string. Otherwise, the line-feed that ends each line is interpreted as whitespace which terminates a preceding lexeme, so there are no other valid multiline lexemes. To enable meaningful error messages, we also keep track of the line number of the last line read, and the beginning and the end of the current lexeme with respect to this line. The lexer is implemented as a function that returns the next lexeme (i.e., token). It uses the [[lexer]] setup and modifies the buffers and pointers stored within the lexer, a side effect. The lexer reads from an input stream object, which also is modified by this reading, e.g., a line pointer is advanced. <>= public :: lex <>= module subroutine lex (lexeme, lexer) type(lexeme_t), intent(out) :: lexeme type(lexer_t), intent(inout) :: lexer end subroutine lex <>= module subroutine lex (lexeme, lexer) type(lexeme_t), intent(out) :: lexeme type(lexer_t), intent(inout) :: lexer integer :: iostat1, iostat2 integer :: pos integer, dimension(2) :: range integer :: template_index, type if (.not. associated (lexer%stream)) & call msg_bug ("Lexer called without assigned stream") GET_LEXEME: do while (lexeme_get_type (lexer%lexeme) == EMPTY) if (len (lexer%buffer) /= 0) then iostat1 = 0 else call lexer_read_line (lexer, iostat1) end if select case (iostat1) case (0) MATCH_BUFFER: do call match (lexer%setup%tt, char (lexer%buffer), & pos, range, template_index) if (pos >= 0) then type = lexer%setup%type(template_index) exit MATCH_BUFFER else pos = 0 call lexer_read_line (lexer, iostat2) select case (iostat2) case (EOF); type = UNMATCHED_QUOTE; exit MATCH_BUFFER case (1); type = IO_ERROR; exit MATCH_BUFFER case (2); type = OVERFLOW; exit MATCH_BUFFER end select end if end do MATCH_BUFFER case (EOF); type = EOF case (1); type = IO_ERROR case (2); type = OVERFLOW end select call lexeme_set (lexer%lexeme, lexer%setup%keyword_list, & extract (lexer%buffer, finish=pos), range, type, & lexer%setup%keyword_case) lexer%buffer = remove (lexer%buffer, finish=pos) lexer%previous_column = lexer%current_column lexer%current_column = lexer%current_column + pos end do GET_LEXEME lexeme = lexer%lexeme call lexeme_clear (lexer%lexeme) end subroutine lex @ %def lex @ Read a line and append it to the input buffer. If the input buffer overflows, return [[iostat=2]]. Otherwise, [[iostat=1]] indicates an I/O error, and [[iostat=-1]] the EOF. The input stream may either be an external unit or a [[ifile]] object. In the latter case, a line is read and the line pointer is advanced. Note that inserting [[LF]] between input lines is the Unix convention. Since we are doing this explicitly when gluing lines together, we can pattern-match against [[LF]] without having to worry about the system. <>= subroutine lexer_read_line (lexer, iostat) type(lexer_t), intent(inout) :: lexer integer, intent(out) :: iostat type(string_t) :: current_line current_line = lexer%current_line call stream_get_record (lexer%stream, lexer%current_line, iostat) if (iostat == 0) then lexer%lines_read = lexer%lines_read + 1 lexer%previous_line2 = lexer%previous_line1 lexer%previous_line1 = current_line lexer%buffer = lexer%buffer // lexer%current_line // LF lexer%previous_column = 0 lexer%current_column = 0 end if end subroutine lexer_read_line @ %def lexer_read_line @ Once in a while we have read one lexeme to many, which can be pushed back into the input stream. Do not do this more than once. <>= public :: lexer_put_back <>= module subroutine lexer_put_back (lexer, lexeme) type(lexer_t), intent(inout) :: lexer type(lexeme_t), intent(in) :: lexeme end subroutine lexer_put_back <>= module subroutine lexer_put_back (lexer, lexeme) type(lexer_t), intent(inout) :: lexer type(lexeme_t), intent(in) :: lexeme if (lexeme_get_type (lexer%lexeme) == EMPTY) then lexer%lexeme = lexeme else call msg_bug (" Lexer: lex_back fails; probably called twice") end if end subroutine lexer_put_back @ %def lexer_put__back @ \subsection{Diagnostics} For debugging: print just the setup <>= public :: lexer_write_setup <>= module subroutine lexer_write_setup (lexer, unit) type(lexer_t), intent(in) :: lexer integer, intent(in), optional :: unit end subroutine lexer_write_setup <>= module subroutine lexer_write_setup (lexer, unit) type(lexer_t), intent(in) :: lexer integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return call lexer_setup_write (lexer%setup, u) end subroutine lexer_write_setup @ %def lexer_write_setup @ This is useful for error printing: show the current line with index and a pointer to the current column within the line. <>= public :: lexer_show_location <>= module subroutine lexer_show_location (lexer) type(lexer_t), intent(in) :: lexer end subroutine lexer_show_location <>= module subroutine lexer_show_location (lexer) type(lexer_t), intent(in) :: lexer type(string_t) :: loc_str if (associated (lexer%parent)) then call lexer_show_source (lexer%parent) call msg_message ("[includes]") else call msg_message () end if if (associated (lexer%stream)) then call msg_message & (char (stream_get_record_info_string (lexer%stream)) // ":") end if if (lexer%lines_read >= 4) call msg_result ("[...]") if (lexer%lines_read >= 3) call msg_result (char (lexer%previous_line2)) if (lexer%lines_read >= 2) call msg_result (char (lexer%previous_line1)) if (lexer%lines_read >= 1) then call msg_result (char (lexer%current_line)) loc_str = repeat (" ", lexer%previous_column) loc_str = loc_str // "^" if (lexer%current_column > lexer%previous_column) then loc_str = loc_str & // repeat ("-", max (lexer%current_column & - lexer%previous_column - 1, 0)) & // "^" end if call msg_result (char (loc_str)) end if end subroutine lexer_show_location @ %def lexer_show_location @ This just prints the current stream source. <>= recursive subroutine lexer_show_source (lexer) type(lexer_t), intent(in) :: lexer if (associated (lexer%parent)) then call lexer_show_source (lexer%parent) call msg_message ("[includes]") else call msg_message () end if if (associated (lexer%stream)) then call msg_message & (char (stream_get_source_info_string (lexer%stream)) // ":") end if end subroutine lexer_show_source @ %def lexer_show_source @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[lexers_ut.f90]]>>= <> module lexers_ut use unit_tests use lexers_uti <> <> contains <> end module lexers_ut @ %def lexers_ut @ <<[[lexers_uti.f90]]>>= <> module lexers_uti <> use lexers <> <> contains <> end module lexers_uti @ %def lexers_ut @ API: driver for the unit tests below. <>= public :: lexer_test <>= subroutine lexer_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine lexer_test @ %def lexer_test @ Test the lexer by lexing and printing all lexemes from unit [[u]], one per line, using preset conventions. <>= call test (lexer_1, "lexer_1", & "check lexer", u, results) <>= public :: lexer_1 <>= subroutine lexer_1 (u) integer, intent(in) :: u type(lexer_t), target :: lexer type(stream_t), target :: stream type(string_t) :: string type(lexeme_t) :: lexeme string = "abcdefghij" call lexer_init (lexer, & comment_chars = "", & quote_chars = "<'""", & quote_match = ">'""", & single_chars = "?*+|=,()", & special_class = ["."], & keyword_list = null ()) call stream_init (stream, string) call lexer_assign_stream (lexer, stream) do call lex (lexeme, lexer) call lexeme_write (lexeme, u) if (lexeme_is_break (lexeme)) exit end do call stream_final (stream) call lexer_final (lexer) end subroutine lexer_1 @ %def lexer_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Syntax rules} This module provides tools to handle syntax rules in an abstract way. <<[[syntax_rules.f90]]>>= <> module syntax_rules <> use ifiles, only: ifile_t use lexers <> <> <> <> <> interface <> end interface end module syntax_rules @ %def syntax_rules @ <<[[syntax_rules_sub.f90]]>>= <> submodule (syntax_rules) syntax_rules_s - use system_defs, only: LCLETTERS, UCLETTERS, DIGITS + use system_defs, only: LCLETTERS, UCLETTERS, DIGIT_CHARS use io_units use diagnostics use ifiles, only: ifile_get_length use ifiles, only: line_p, line_init, line_get_string_advance, line_final implicit none <> contains <> end submodule syntax_rules_s @ %def syntax_rules_s \subsection{Syntax rules} Syntax rules are used by the parser. They determine how to translate the stream of lexemes as returned by the lexer into the parse tree node. A rule may be terminal, i.e., replace a matching lexeme into a terminal node. The node will contain the lexeme interpreted as a recognized token: \begin{itemize} \item a keyword: unquoted fixed character string; \item a real number, to be determined at runtime; \item an integer, to be determined at runtime; \item a boolean value, to be determined at runtime; \item a quoted token (e.g., string), to be determined at runtime; \item an identifier (unquoted string that is not a recognized keyword), to be determined at runtime. \end{itemize} It may be nonterminal, i.e., contain a sequence of child rules. These are matched consecutively (and recursively) against the input stream; the resulting node will be a branch node. \begin{itemize} \item the file, i.e., the input stream as a whole; \item a sequence of syntax elements, where the last syntax element may be optional, or optional repetitive; \end{itemize} Sequences carry a flag that tells whether the last child is optional or may be repeated an arbitrary number of times, correponding to the regexp modifiers [[?]], [[*]], and [[+]]. We also need an alternative rule; this will be replaced by the node generated by one of its children that matches; thus, it does not create a node of its own. \begin{itemize} \item an alternative of syntax elements. \end{itemize} We also define special types of sequences as convenience macros: \begin{itemize} \item a list: a sequence where the elements are separated by a separator keyword (e.g., commas), the separators are thrown away when parsing the list; \item a group: a sequence of three tokens, where the first and third ones are left and right delimiters, the delimiters are thrown away; \item an argument list: a delimited list, containing both delimiters and separators. \end{itemize} It would be great to have a polymorphic type for this purpose, but until Fortran 2003 is out we have to emulate this. Here are the syntax element codes: <>= public :: S_UNKNOWN public :: S_LOGICAL, S_INTEGER, S_REAL, S_COMPLEX, S_QUOTED public :: S_IDENTIFIER, S_KEYWORD public :: S_SEQUENCE, S_LIST, S_GROUP, S_ARGS public :: S_ALTERNATIVE public :: S_IGNORE <>= integer, parameter :: & S_UNKNOWN = 0, & S_LOGICAL = 1, S_INTEGER = 2, S_REAL = 3, S_COMPLEX = 4, & S_QUOTED = 5, S_IDENTIFIER = 6, S_KEYWORD = 7, & S_SEQUENCE = 8, S_LIST = 9, S_GROUP = 10, S_ARGS = 11, & S_ALTERNATIVE = 12, & S_IGNORE = 99 @ We need arrays of rule pointers, therefore this construct. <>= type :: rule_p private type(syntax_rule_t), pointer :: p => null () end type rule_p @ %def rule_p @ Return the association status of the rule pointer: <>= elemental function rule_is_associated (rp) result (ok) logical :: ok type (rule_p), intent(in) :: rp ok = associated (rp%p) end function rule_is_associated @ %def rule_is_associated @ The rule type is one of the types listed above, represented by an integer code. The keyword, for a non-keyword rule, is an identifier used for the printed syntax table. The array of children is needed for nonterminal rules. In that case, there is a modifier for the last element (blank, "?", "*", or "+"), mirrored in the flags [[opt]] and [[rep]]. Then, we have the character constants used as separators and delimiters for this rule. Finally, the [[used]] flag can be set to indicate that this rule is the child of another rule. <>= public :: syntax_rule_t <>= type :: syntax_rule_t private integer :: type = S_UNKNOWN logical :: used = .false. type(string_t) :: keyword type(string_t) :: separator type(string_t), dimension(2) :: delimiter type(rule_p), dimension(:), allocatable :: child character(1) :: modifier = "" logical :: opt = .false., rep = .false. contains <> end type syntax_rule_t @ %def syntax_rule_t @ Initializer: Set type and key for a rule, but do not (yet) allocate anything. Finalizer: not needed (no pointer components). <>= subroutine syntax_rule_init (rule, key, type) type(syntax_rule_t), intent(inout) :: rule type(string_t), intent(in) :: key integer, intent(in) :: type rule%keyword = key rule%type = type select case (rule%type) case (S_GROUP) call syntax_rule_set_delimiter (rule) case (S_LIST) call syntax_rule_set_separator (rule) case (S_ARGS) call syntax_rule_set_delimiter (rule) call syntax_rule_set_separator (rule) end select end subroutine syntax_rule_init @ %def syntax_rule_init @ These characters will not be enclosed in quotes when writing syntax rules: <>= character(*), parameter :: & - UNQUOTED = "(),|_"//LCLETTERS//UCLETTERS//DIGITS + UNQUOTED = "(),|_"//LCLETTERS//UCLETTERS//DIGIT_CHARS @ \subsection{Accessing rules} This is the API for syntax rules: <>= public :: syntax_rule_get_type <>= module function syntax_rule_get_type (rule) result (type) integer :: type type(syntax_rule_t), intent(in) :: rule end function syntax_rule_get_type <>= module function syntax_rule_get_type (rule) result (type) integer :: type type(syntax_rule_t), intent(in) :: rule type = rule%type end function syntax_rule_get_type @ %def syntax_rule_get_type <>= public :: syntax_rule_get_key <>= module function syntax_rule_get_key (rule) result (key) class(syntax_rule_t), intent(in) :: rule type(string_t) :: key end function syntax_rule_get_key <>= procedure :: get_key => syntax_rule_get_key <>= module function syntax_rule_get_key (rule) result (key) class(syntax_rule_t), intent(in) :: rule type(string_t) :: key key = rule%keyword end function syntax_rule_get_key @ %def syntax_rule_get_key <>= public :: syntax_rule_get_separator public :: syntax_rule_get_delimiter <>= module function syntax_rule_get_separator (rule) result (separator) type(string_t) :: separator type(syntax_rule_t), intent(in) :: rule end function syntax_rule_get_separator module function syntax_rule_get_delimiter (rule) result (delimiter) type(string_t), dimension(2) :: delimiter type(syntax_rule_t), intent(in) :: rule end function syntax_rule_get_delimiter <>= module function syntax_rule_get_separator (rule) result (separator) type(string_t) :: separator type(syntax_rule_t), intent(in) :: rule separator = rule%separator end function syntax_rule_get_separator module function syntax_rule_get_delimiter (rule) result (delimiter) type(string_t), dimension(2) :: delimiter type(syntax_rule_t), intent(in) :: rule delimiter = rule%delimiter end function syntax_rule_get_delimiter @ %def syntax_rule_get_separator syntax_rule_get_delimiter @ Accessing child rules. If we use [[syntax_rule_get_n_sub]] for determining loop bounds, we do not need a check in the second routine. <>= public :: syntax_rule_get_n_sub public :: syntax_rule_get_sub_ptr <>= module function syntax_rule_get_sub_ptr (rule, i) result (sub) type(syntax_rule_t), pointer :: sub type(syntax_rule_t), intent(in), target :: rule integer, intent(in) :: i end function syntax_rule_get_sub_ptr module function syntax_rule_get_n_sub (rule) result (n) integer :: n type(syntax_rule_t), intent(in) :: rule end function syntax_rule_get_n_sub <>= module function syntax_rule_get_n_sub (rule) result (n) integer :: n type(syntax_rule_t), intent(in) :: rule if (allocated (rule%child)) then n = size (rule%child) else n = 0 end if end function syntax_rule_get_n_sub module function syntax_rule_get_sub_ptr (rule, i) result (sub) type(syntax_rule_t), pointer :: sub type(syntax_rule_t), intent(in), target :: rule integer, intent(in) :: i sub => rule%child(i)%p end function syntax_rule_get_sub_ptr subroutine syntax_rule_set_sub (rule, i, sub) type(syntax_rule_t), intent(inout) :: rule integer, intent(in) :: i type(syntax_rule_t), intent(in), target :: sub rule%child(i)%p => sub end subroutine syntax_rule_set_sub @ %def syntax_rule_get_n_sub syntax_rule_get_sub_ptr syntax_rule_set_sub @ Return the modifier flags: <>= public :: syntax_rule_last_optional public :: syntax_rule_last_repetitive <>= module function syntax_rule_last_optional (rule) result (opt) logical :: opt type(syntax_rule_t), intent(in) :: rule end function syntax_rule_last_optional module function syntax_rule_last_repetitive (rule) result (rep) logical :: rep type(syntax_rule_t), intent(in) :: rule end function syntax_rule_last_repetitive <>= module function syntax_rule_last_optional (rule) result (opt) logical :: opt type(syntax_rule_t), intent(in) :: rule opt = rule%opt end function syntax_rule_last_optional module function syntax_rule_last_repetitive (rule) result (rep) logical :: rep type(syntax_rule_t), intent(in) :: rule rep = rule%rep end function syntax_rule_last_repetitive @ %def syntax_rule_last_optional syntax_rule_last_repetitive @ Return true if the rule is atomic, i.e., logical, real, keyword etc. <>= public :: syntax_rule_is_atomic <>= module function syntax_rule_is_atomic (rule) result (atomic) logical :: atomic type(syntax_rule_t), intent(in) :: rule end function syntax_rule_is_atomic <>= module function syntax_rule_is_atomic (rule) result (atomic) logical :: atomic type(syntax_rule_t), intent(in) :: rule select case (rule%type) case (S_LOGICAL, S_INTEGER, S_REAL, S_COMPLEX, S_IDENTIFIER, & S_KEYWORD, S_QUOTED) atomic = .true. case default atomic = .false. end select end function syntax_rule_is_atomic @ %def syntax_rule_is_atomic @ \subsection{I/O} Write an account of the rule. Setting [[short]] true will suppress the node type. Setting [[key_only]] true will suppress the definition. Setting [[advance]] false will suppress the trailing newline. <>= public :: syntax_rule_write <>= procedure :: write => syntax_rule_write <>= module subroutine syntax_rule_write (rule, unit, short, key_only, advance) class(syntax_rule_t), intent(in) :: rule integer, intent(in), optional :: unit logical, intent(in), optional :: short, key_only, advance end subroutine syntax_rule_write <>= module subroutine syntax_rule_write (rule, unit, short, key_only, advance) class(syntax_rule_t), intent(in) :: rule integer, intent(in), optional :: unit logical, intent(in), optional :: short, key_only, advance logical :: typ, def, adv integer :: u u = given_output_unit (unit); if (u < 0) return typ = .true.; if (present (short)) typ = .not. short def = .true.; if (present (key_only)) def = .not. key_only adv = .true.; if (present (advance)) adv = advance select case (rule%type) case (S_UNKNOWN); call write_atom ("???", typ) case (S_IGNORE); call write_atom ("IGNORE", typ) case (S_LOGICAL); call write_atom ("LOGICAL", typ) case (S_INTEGER); call write_atom ("INTEGER", typ) case (S_REAL); call write_atom ("REAL", typ) case (S_COMPLEX); call write_atom ("COMPLEX", typ) case (S_IDENTIFIER); call write_atom ("IDENTIFIER", typ) case (S_KEYWORD); call write_atom ("KEYWORD", typ) case (S_QUOTED) call write_quotes (typ, def, & del = rule%delimiter) case (S_SEQUENCE) call write_sequence ("SEQUENCE", typ, def, size (rule%child)) case (S_GROUP) call write_sequence ("GROUP", typ, def, size (rule%child), & del = rule%delimiter) case (S_LIST) call write_sequence ("LIST", typ, def, size (rule%child), & sep = rule%separator) case (S_ARGS) call write_sequence ("ARGUMENTS", typ, def, size (rule%child), & del = rule%delimiter, & sep = rule%separator) case (S_ALTERNATIVE) call write_sequence ("ALTERNATIVE", typ, def, size (rule%child), & sep = var_str ("|")) end select if (adv) write (u, *) contains subroutine write_type (type) character(*), intent(in) :: type character(11) :: str str = type write (u, "(1x,A)", advance="no") str end subroutine write_type subroutine write_key write (u, "(1x,A)", advance="no") char (wkey (rule)) end subroutine write_key subroutine write_atom (type, typ) character(*), intent(in) :: type logical, intent(in) :: typ if (typ) call write_type (type) call write_key end subroutine write_atom subroutine write_maybe_quoted (string) character(*), intent(in) :: string character, parameter :: q = "'" character, parameter :: qq = '"' if (verify (string, UNQUOTED) == 0) then write (u, "(1x,A)", advance = "no") trim (string) else if (verify (string, q) == 0) then write (u, "(1x,A)", advance = "no") qq // trim (string) // qq else write (u, "(1x,A)", advance = "no") q // trim (string) // q end if end subroutine write_maybe_quoted subroutine write_quotes (typ, def, del) logical, intent(in) :: typ, def type(string_t), dimension(2), intent(in) :: del if (typ) call write_type ("QUOTED") call write_key if (def) then write (u, "(1x,'=')", advance="no") call write_maybe_quoted (char (del(1))) write (u, "(1x,A)", advance="no") "..." call write_maybe_quoted (char (del(2))) end if end subroutine write_quotes subroutine write_sequence (type, typ, def, n, del, sep) character(*), intent(in) :: type logical, intent(in) :: typ, def integer, intent(in) :: n type(string_t), dimension(2), intent(in), optional :: del type(string_t), intent(in), optional :: sep integer :: i if (typ) call write_type (type) call write_key if (def) then write (u, "(1x,'=')", advance="no") if (present (del)) call write_maybe_quoted (char (del(1))) do i = 1, n if (i > 1 .and. present (sep)) & call write_maybe_quoted (char (sep)) write (u, "(1x,A)", advance="no") & char (wkey (syntax_rule_get_sub_ptr(rule, i))) if (i == n) write (u, "(A)", advance="no") trim (rule%modifier) end do if (present (del)) call write_maybe_quoted (char (del(2))) end if end subroutine write_sequence end subroutine syntax_rule_write @ %def syntax_rule_write @ In the printed representation, the keyword strings are enclosed as [[<...>]], unless they are bare keywords. Bare keywords are enclosed as [['..']] if they contain a character which is not a letter, digit, or underscore. If they contain a single-quote character, they are enclosed as [[".."]]. (A keyword must not contain both single- and double-quotes.) <>= function wkey (rule) result (string) type(string_t) :: string type(syntax_rule_t), intent(in) :: rule select case (rule%type) case (S_KEYWORD) if (verify (rule%keyword, UNQUOTED) == 0) then string = rule%keyword else if (scan (rule%keyword, "'") == 0) then string = "'" // rule%keyword // "'" else string = '"' // rule%keyword // '"' end if case default string = "<" // rule%keyword // ">" end select end function wkey @ %def wkey @ \subsection{Completing syntax rules} Set the separator and delimiter entries, using defaults: <>= subroutine syntax_rule_set_separator (rule, separator) type(syntax_rule_t), intent(inout) :: rule type(string_t), intent(in), optional :: separator if (present (separator)) then rule%separator = separator else rule%separator = "," end if end subroutine syntax_rule_set_separator subroutine syntax_rule_set_delimiter (rule, delimiter) type(syntax_rule_t), intent(inout) :: rule type(string_t), dimension(2), intent(in), optional :: delimiter if (present (delimiter)) then rule%delimiter = delimiter else rule%delimiter(1) = "(" rule%delimiter(2) = ")" end if end subroutine syntax_rule_set_delimiter @ %def syntax_rule_set_separator syntax_rule_set_delimiter @ Set the modifier entry and corresponding flags: <>= function is_modifier (string) result (ok) logical :: ok type(string_t), intent(in) :: string select case (char (string)) case (" ", "?", "*", "+"); ok = .true. case default; ok = .false. end select end function is_modifier subroutine syntax_rule_set_modifier (rule, modifier) type(syntax_rule_t), intent(inout) :: rule type(string_t), intent(in) :: modifier rule%modifier = char (modifier) select case (rule%modifier) case (" ") case ("?"); rule%opt = .true. case ("*"); rule%opt = .true.; rule%rep = .true. case ("+"); rule%rep = .true. case default call msg_bug (" Syntax: sequence modifier '" // rule%modifier & // "' is not one of '+' '*' '?'") end select end subroutine syntax_rule_set_modifier @ %def is_modifier syntax_rule_set_modifier @ Check a finalized rule for completeness <>= subroutine syntax_rule_check (rule) type(syntax_rule_t), intent(in) :: rule if (rule%keyword == "") call msg_bug ("Rule key not set") select case (rule%type) case (S_UNKNOWN); call bug (" Undefined rule") case (S_IGNORE, S_LOGICAL, S_INTEGER, S_REAL, S_COMPLEX, & S_IDENTIFIER, S_KEYWORD) case (S_QUOTED) if (rule%delimiter(1) == "" .or. rule%delimiter(2) == "") & call bug (" Missing quote character(s)") case (S_SEQUENCE) case (S_GROUP) if (rule%delimiter(1) == "" .or. rule%delimiter(2) == "") & call bug (" Missing delimiter(s)") case (S_LIST) if (rule%separator == "") call bug (" Missing separator") case (S_ARGS) if (rule%delimiter(1) == "" .or. rule%delimiter(2) == "") & call bug (" Missing delimiter(s)") if (rule%separator == "") call bug (" Missing separator") case (S_ALTERNATIVE) case default call bug (" Undefined syntax code") end select select case (rule%type) case (S_SEQUENCE, S_GROUP, S_LIST, S_ARGS, S_ALTERNATIVE) if (allocated (rule%child)) then if (.not.all (rule_is_associated (rule%child))) & call bug (" Child rules not all associated") else call bug (" Parent rule without children") end if case default if (allocated (rule%child)) call bug (" Non-parent rule with children") end select contains subroutine bug (string) character(*), intent(in) :: string call msg_bug (" Syntax table: Rule " // char (rule%keyword) // ": " & // string) end subroutine bug end subroutine syntax_rule_check @ %def syntax_rule_check @ \subsection{Syntax tables} A syntax table contains the tree of syntax rules and, for direct parser access, the list of valid keywords. \subsubsection{Types} The syntax contains an array of rules and a list of keywords. The array is actually used as a tree, where the top rule is the first array element, and the other rules are recursively pointed to by this first rule. (No rule should be used twice or be unused.) The keyword list is derived from the rule tree. Objects of this type need the target attribute if they are associated with a lexer. The keyword list will be pointed to by this lexer. <>= public :: syntax_t <>= type :: syntax_t private type(syntax_rule_t), dimension(:), allocatable :: rule type(keyword_list_t) :: keyword_list end type syntax_t @ %def syntax_t @ \subsubsection{Constructor/destructor} Initialize and finalize syntax tables <>= public :: syntax_init public :: syntax_final @ There are two ways to create a syntax: hard-coded from rules or dynamically from file. <>= interface syntax_init module procedure syntax_init_from_ifile end interface @ %def syntax_init @ The syntax definition is read from an [[ifile]] object which contains the syntax definitions in textual form, one rule per line. This interface allows for determining the number of rules beforehand. To parse the rule definitions, we make up a temporary lexer. Obviously, we cannot use a generic parser yet, so we have to hardcode the parsing process. <>= module subroutine syntax_init_from_ifile (syntax, ifile) type(syntax_t), intent(out), target :: syntax type(ifile_t), intent(in) :: ifile end subroutine syntax_init_from_ifile <>= module subroutine syntax_init_from_ifile (syntax, ifile) type(syntax_t), intent(out), target :: syntax type(ifile_t), intent(in) :: ifile type(lexer_t) :: lexer type(line_p) :: line type(string_t) :: string integer :: n_token integer :: i call lexer_init (lexer, & comment_chars = "", & quote_chars = "<'""", & quote_match = ">'""", & single_chars = "?*+|=,()", & special_class = ["."], & keyword_list = null ()) allocate (syntax%rule (ifile_get_length (ifile))) call line_init (line, ifile) do i = 1, size (syntax%rule) string = line_get_string_advance (line) call set_rule_type_and_key (syntax%rule(i), string, lexer) end do call line_init (line, ifile) do i = 1, size (syntax%rule) string = line_get_string_advance (line) select case (syntax%rule(i)%type) case (S_QUOTED, S_SEQUENCE, S_GROUP, S_LIST, S_ARGS, S_ALTERNATIVE) n_token = get_n_token (string, lexer) call set_rule_contents & (syntax%rule(i), syntax, n_token, string, lexer) end select end do call line_final (line) call lexer_final (lexer) call syntax_make_keyword_list (syntax) if (.not. all (syntax%rule%used)) then do i = 1, size (syntax%rule) if (.not. syntax%rule(i)%used) then call syntax_rule_write (syntax%rule(i), 6) end if end do call msg_bug (" Syntax table: unused rules") end if end subroutine syntax_init_from_ifile @ %def syntax_init_from_ifile @ For a given rule defined in the input, the first task is to determine its type and key. With these, we can initialize the rule in the table, postponing the association of children. <>= subroutine set_rule_type_and_key (rule, string, lexer) type(syntax_rule_t), intent(inout) :: rule type(string_t), intent(in) :: string type(lexer_t), intent(inout) :: lexer type(stream_t), target :: stream type(lexeme_t) :: lexeme type(string_t) :: key character(2) :: type call lexer_clear (lexer) call stream_init (stream, string) call lexer_assign_stream (lexer, stream) call lex (lexeme, lexer) type = lexeme_get_string (lexeme) call lex (lexeme, lexer) key = lexeme_get_contents (lexeme) call stream_final (stream) if (trim (key) /= "") then select case (type) case ("IG"); call syntax_rule_init (rule, key, S_IGNORE) case ("LO"); call syntax_rule_init (rule, key, S_LOGICAL) case ("IN"); call syntax_rule_init (rule, key, S_INTEGER) case ("RE"); call syntax_rule_init (rule, key, S_REAL) case ("CO"); call syntax_rule_init (rule, key, S_COMPLEX) case ("ID"); call syntax_rule_init (rule, key, S_IDENTIFIER) case ("KE"); call syntax_rule_init (rule, key, S_KEYWORD) case ("QU"); call syntax_rule_init (rule, key, S_QUOTED) case ("SE"); call syntax_rule_init (rule, key, S_SEQUENCE) case ("GR"); call syntax_rule_init (rule, key, S_GROUP) case ("LI"); call syntax_rule_init (rule, key, S_LIST) case ("AR"); call syntax_rule_init (rule, key, S_ARGS) case ("AL"); call syntax_rule_init (rule, key, S_ALTERNATIVE) case default call lexer_show_location (lexer) call msg_bug (" Syntax definition: unknown type '" // type // "'") end select else print *, char (string) call msg_bug (" Syntax definition: empty rule key") end if end subroutine set_rule_type_and_key @ %def set_rule_type_and_key @ This function returns the number of tokens in an input line. <>= function get_n_token (string, lexer) result (n) integer :: n type(string_t), intent(in) :: string type(lexer_t), intent(inout) :: lexer type(stream_t), target :: stream type(lexeme_t) :: lexeme integer :: i call lexer_clear (lexer) call stream_init (stream, string) call lexer_assign_stream (lexer, stream) i = 0 do call lex (lexeme, lexer) if (lexeme_is_break (lexeme)) exit i = i + 1 end do n = i call stream_final (stream) end function get_n_token @ %def get_n_token @ Assign the pointer to the rule associated with a given key (assumes that the rule array is allocated) <>= public :: syntax_get_rule_ptr <>= module function syntax_get_rule_ptr (syntax, key) result (rule) type(syntax_rule_t), pointer :: rule type(syntax_t), intent(in), target :: syntax type(string_t), intent(in) :: key end function syntax_get_rule_ptr <>= module function syntax_get_rule_ptr (syntax, key) result (rule) type(syntax_rule_t), pointer :: rule type(syntax_t), intent(in), target :: syntax type(string_t), intent(in) :: key integer :: i do i = 1, size (syntax%rule) if (syntax%rule(i)%keyword == key) then rule => syntax%rule(i) return end if end do call msg_bug (" Syntax table: Rule " // char (key) // " not found") end function syntax_get_rule_ptr @ %def syntax_get_rule_ptr @ This subroutine extracts the rule contents for an input line. There are three tasks: (1) determine the number of children, depending on the rule type; (2) find and set the separator and delimiter strings, if required; (3) scan the child rules, find them in the syntax table and associate the parent rule with them. <>= subroutine set_rule_contents (rule, syntax, n_token, string, lexer) type(syntax_rule_t), intent(inout) :: rule type(syntax_t), intent(in), target :: syntax integer, intent(in) :: n_token type(string_t), intent(in) :: string type(lexer_t), intent(inout) :: lexer type(stream_t), target :: stream type(lexeme_t), dimension(n_token) :: lexeme integer :: i, n_children call lexer_clear (lexer) call stream_init (stream, string) call lexer_assign_stream (lexer, stream) do i = 1, n_token call lex (lexeme(i), lexer) end do call stream_final (stream) n_children = get_n_children () call set_delimiters if (n_children > 1) call set_separator if (n_children > 0) call set_children contains function get_n_children () result (n_children) integer :: n_children select case (rule%type) case (S_QUOTED) if (n_token /= 6) call broken_rule (rule) n_children = 0 case (S_GROUP) if (n_token /= 6) call broken_rule (rule) n_children = 1 case (S_SEQUENCE) if (is_modifier (lexeme_get_string (lexeme(n_token)))) then if (n_token <= 4) call broken_rule (rule) call syntax_rule_set_modifier & (rule, lexeme_get_string (lexeme(n_token))) n_children = n_token - 4 else if (n_token <= 3) call broken_rule (rule) n_children = n_token - 3 end if case (S_LIST) if (is_modifier (lexeme_get_string (lexeme(n_token)))) then if (n_token <= 4 .or. mod (n_token, 2) /= 1) & call broken_rule (rule) call syntax_rule_set_modifier & (rule, lexeme_get_string (lexeme(n_token))) else if (n_token <= 3 .or. mod (n_token, 2) /= 0) then call broken_rule (rule) end if n_children = (n_token - 2) / 2 case (S_ARGS) if (is_modifier (lexeme_get_string (lexeme(n_token-1)))) then if (n_token <= 6 .or. mod (n_token, 2) /= 1) & call broken_rule (rule) call syntax_rule_set_modifier & (rule, lexeme_get_string (lexeme(n_token-1))) else if (n_token <= 5 .or. mod (n_token, 2) /= 0) then call broken_rule (rule) end if n_children = (n_token - 4) / 2 case (S_ALTERNATIVE) if (n_token <= 3 .or. mod (n_token, 2) /= 0) call broken_rule (rule) n_children = (n_token - 2) / 2 end select end function get_n_children subroutine set_delimiters type(string_t), dimension(2) :: delimiter select case (rule%type) case (S_QUOTED, S_GROUP, S_ARGS) delimiter(1) = lexeme_get_contents (lexeme(4)) delimiter(2) = lexeme_get_contents (lexeme(n_token)) call syntax_rule_set_delimiter (rule, delimiter) end select end subroutine set_delimiters subroutine set_separator type(string_t) :: separator select case (rule%type) case (S_LIST) separator = lexeme_get_contents (lexeme(5)) call syntax_rule_set_separator (rule, separator) case (S_ARGS) separator = lexeme_get_contents (lexeme(6)) call syntax_rule_set_separator (rule, separator) end select end subroutine set_separator subroutine set_children allocate (rule%child(n_children)) select case (rule%type) case (S_GROUP) call syntax_rule_set_sub (rule, 1, syntax_get_rule_ptr (syntax, & lexeme_get_contents (lexeme(5)))) case (S_SEQUENCE) do i = 1, n_children call syntax_rule_set_sub (rule, i, syntax_get_rule_ptr (syntax, & lexeme_get_contents (lexeme(i+3)))) end do case (S_LIST, S_ALTERNATIVE) do i = 1, n_children call syntax_rule_set_sub (rule, i, syntax_get_rule_ptr (syntax, & lexeme_get_contents (lexeme(2*i+2)))) end do case (S_ARGS) do i = 1, n_children call syntax_rule_set_sub (rule, i, syntax_get_rule_ptr (syntax, & lexeme_get_contents (lexeme(2*i+3)))) end do end select end subroutine set_children subroutine broken_rule (rule) type(syntax_rule_t), intent(in) :: rule call lexer_show_location (lexer) call msg_bug (" Syntax definition: broken rule '" & // char (wkey (rule)) // "'") end subroutine broken_rule end subroutine set_rule_contents @ %def set_rule_contents @ This routine completes the syntax table object. We assume that the rule array is set up. We associate the top rule with the first entry in the rule array and build up the keyword list. The keyword list includes delimiters and separators. Filling it can only be done after all rules are set. We scan the rule tree. For each keyword that we find, we try to add it to the keyword list; the pointer to the last element is carried along with the recursive scanning. Before appending a keyword, we check whether it is already in the list. <>= subroutine syntax_make_keyword_list (syntax) type(syntax_t), intent(inout), target :: syntax type(syntax_rule_t), pointer :: rule rule => syntax%rule(1) call rule_scan_rec (rule, syntax%keyword_list) contains recursive subroutine rule_scan_rec (rule, keyword_list) type(syntax_rule_t), pointer :: rule type(keyword_list_t), intent(inout) :: keyword_list integer :: i if (rule%used) return rule%used = .true. select case (rule%type) case (S_UNKNOWN) call msg_bug (" Syntax: rule tree contains undefined rule") case (S_KEYWORD) call keyword_list_add (keyword_list, rule%keyword) end select select case (rule%type) case (S_LIST, S_ARGS) call keyword_list_add (keyword_list, rule%separator) end select select case (rule%type) case (S_GROUP, S_ARGS) call keyword_list_add (keyword_list, rule%delimiter(1)) call keyword_list_add (keyword_list, rule%delimiter(2)) end select select case (rule%type) case (S_SEQUENCE, S_GROUP, S_LIST, S_ARGS, S_ALTERNATIVE) if (.not. allocated (rule%child)) & call msg_bug (" Syntax: Non-terminal rule without children") case default if (allocated (rule%child)) & call msg_bug (" Syntax: Terminal rule with children") end select if (allocated (rule%child)) then do i = 1, size (rule%child) call rule_scan_rec (rule%child(i)%p, keyword_list) end do end if end subroutine rule_scan_rec end subroutine syntax_make_keyword_list @ %def syntax_make_keyword_list @ The finalizer deallocates the rule pointer array and deletes the keyword list. <>= module subroutine syntax_final (syntax) type(syntax_t), intent(inout) :: syntax end subroutine syntax_final <>= module subroutine syntax_final (syntax) type(syntax_t), intent(inout) :: syntax if (allocated (syntax%rule)) deallocate (syntax%rule) call keyword_list_final (syntax%keyword_list) end subroutine syntax_final @ %def syntax_final @ \subsection{Accessing the syntax table} Return a pointer to the top rule <>= public :: syntax_get_top_rule_ptr <>= module function syntax_get_top_rule_ptr (syntax) result (rule) type(syntax_rule_t), pointer :: rule type(syntax_t), intent(in), target :: syntax end function syntax_get_top_rule_ptr <>= module function syntax_get_top_rule_ptr (syntax) result (rule) type(syntax_rule_t), pointer :: rule type(syntax_t), intent(in), target :: syntax if (allocated (syntax%rule)) then rule => syntax%rule(1) else rule => null () end if end function syntax_get_top_rule_ptr @ %def syntax_get_top_rule_ptr @ Return a pointer to the keyword list <>= public :: syntax_get_keyword_list_ptr <>= module function syntax_get_keyword_list_ptr (syntax) result (keyword_list) type(keyword_list_t), pointer :: keyword_list type(syntax_t), intent(in), target :: syntax end function syntax_get_keyword_list_ptr <>= module function syntax_get_keyword_list_ptr (syntax) result (keyword_list) type(keyword_list_t), pointer :: keyword_list type(syntax_t), intent(in), target :: syntax keyword_list => syntax%keyword_list end function syntax_get_keyword_list_ptr @ %def syntax_get_keyword_list_ptr @ \subsection{I/O} Write a readable representation of the syntax table <>= public :: syntax_write <>= module subroutine syntax_write (syntax, unit) type(syntax_t), intent(in) :: syntax integer, intent(in), optional :: unit end subroutine syntax_write <>= module subroutine syntax_write (syntax, unit) type(syntax_t), intent(in) :: syntax integer, intent(in), optional :: unit integer :: u integer :: i u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Syntax table:" if (allocated (syntax%rule)) then do i = 1, size (syntax%rule) call syntax_rule_write (syntax%rule(i), u) end do else write (u, "(1x,A)") "[not allocated]" end if call keyword_list_write (syntax%keyword_list, u) end subroutine syntax_write @ %def syntax_write @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The parser} On a small scale, the parser interprets the string tokens returned by the lexer; they are interpreted as numbers, keywords and such and stored as a typed object. On a large scale, a text is read, parsed, and a syntax rule set is applied such that the tokens are stored as a parse tree. Syntax errors are spotted in this process, so the resulting parse tree is syntactically correct by definition. <<[[parser.f90]]>>= <> module parser <> <> use lexers use syntax_rules <> <> <> <> interface <> end interface end module parser @ %def parser @ <<[[parser_sub.f90]]>>= <> submodule (parser) parser_s use io_units use diagnostics use md5 - use system_defs, only: DIGITS + use system_defs, only: DIGIT_CHARS use format_defs, only: FMT_19 implicit none contains <> end submodule parser_s @ %def parser_s \subsection{The token type} Tokens are elements of the parsed input that carry a value: logical, integer, real, quoted string, (unquoted) identifier, or known keyword. Note that non-keyword tokens also have an abstract key attached to them. This is an obvious candidate for polymorphism. <>= type :: token_t private integer :: type = S_UNKNOWN logical, pointer :: lval => null () integer, pointer :: ival => null () real(default), pointer :: rval => null () complex(default), pointer :: cval => null () type(string_t), pointer :: sval => null () type(string_t), pointer :: kval => null () type(string_t), dimension(:), pointer :: quote => null () end type token_t @ %def token_t @ Create a token from the lexeme returned by the lexer: Allocate storage and try to interpret the lexeme according to the type that is requested by the parser. For a keyword token, match the lexeme against the requested key. If successful, set the token type, value, and key. Otherwise, set the type to [[S_UNKNOWN]]. <>= subroutine token_init (token, lexeme, requested_type, key) type(token_t), intent(out) :: token type(lexeme_t), intent(in) :: lexeme integer, intent(in) :: requested_type type(string_t), intent(in) :: key integer :: type type = lexeme_get_type (lexeme) token%type = S_UNKNOWN select case (requested_type) case (S_LOGICAL) if (type == T_IDENTIFIER) call read_logical & (char (lexeme_get_string (lexeme))) case (S_INTEGER) if (type == T_NUMERIC) call read_integer & (char (lexeme_get_string (lexeme))) case (S_REAL) if (type == T_NUMERIC) call read_real & (char (lexeme_get_string (lexeme))) case (S_COMPLEX) if (type == T_NUMERIC) call read_complex & (char (lexeme_get_string (lexeme))) case (S_IDENTIFIER) if (type == T_IDENTIFIER) call read_identifier & (lexeme_get_string (lexeme)) case (S_KEYWORD) if (type == T_KEYWORD) call check_keyword & (lexeme_get_string (lexeme), key) case (S_QUOTED) if (type == T_QUOTED) call read_quoted & (lexeme_get_contents (lexeme), lexeme_get_delimiters (lexeme)) case default print *, requested_type call msg_bug (" Invalid token type code requested by the parser") end select if (token%type /= S_UNKNOWN) then allocate (token%kval) token%kval = key end if contains subroutine read_logical (s) character(*), intent(in) :: s select case (s) case ("t", "T", "true", "TRUE", "y", "Y", "yes", "YES") allocate (token%lval) token%lval = .true. token%type = S_LOGICAL case ("f", "F", "false", "FALSE", "n", "N", "no", "NO") allocate (token%lval) token%lval = .false. token%type = S_LOGICAL end select end subroutine read_logical subroutine read_integer (s) character(*), intent(in) :: s integer :: tmp, iostat - if (verify (s, DIGITS) == 0) then + if (verify (s, DIGIT_CHARS) == 0) then read (s, *, iostat=iostat) tmp if (iostat == 0) then allocate (token%ival) token%ival = tmp token%type = S_INTEGER end if end if end subroutine read_integer subroutine read_real (s) character(*), intent(in) :: s real(default) :: tmp integer :: iostat read (s, *, iostat=iostat) tmp if (iostat == 0) then allocate (token%rval) token%rval = tmp token%type = S_REAL end if end subroutine read_real subroutine read_complex (s) character(*), intent(in) :: s complex(default) :: tmp integer :: iostat read (s, *, iostat=iostat) tmp if (iostat == 0) then allocate (token%cval) token%cval = tmp token%type = S_COMPLEX end if end subroutine read_complex subroutine read_identifier (s) type(string_t), intent(in) :: s allocate (token%sval) token%sval = s token%type = S_IDENTIFIER end subroutine read_identifier subroutine check_keyword (s, key) type(string_t), intent(in) :: s type(string_t), intent(in) :: key if (key == s) token%type = S_KEYWORD end subroutine check_keyword subroutine read_quoted (s, del) type(string_t), intent(in) :: s type(string_t), dimension(2), intent(in) :: del allocate (token%sval, token%quote(2)) token%sval = s token%quote(1) = del(1) token%quote(2) = del(2) token%type = S_QUOTED end subroutine read_quoted end subroutine token_init @ %def token_init @ Manually set a token to a keyword. <>= subroutine token_init_key (token, key) type(token_t), intent(out) :: token type(string_t), intent(in) :: key token%type = S_KEYWORD allocate (token%kval) token%kval = key end subroutine token_init_key @ %def token_init_key @ Reset a token to an empty state, freeing allocated memory, and deallocate the token itself. <>= subroutine token_final (token) type(token_t), intent(inout) :: token token%type = S_UNKNOWN if (associated (token%lval)) deallocate (token%lval) if (associated (token%ival)) deallocate (token%ival) if (associated (token%rval)) deallocate (token%rval) if (associated (token%sval)) deallocate (token%sval) if (associated (token%kval)) deallocate (token%kval) if (associated (token%quote)) deallocate (token%quote) end subroutine token_final @ %def token_final @ Check for empty=valid token: <>= function token_is_valid (token) result (valid) logical :: valid type(token_t), intent(in) :: token valid = token%type /= S_UNKNOWN end function token_is_valid @ %def token_is_valid @ Write the contents of a token. <>= subroutine token_write (token, unit) type(token_t), intent(in) :: token integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return select case (token%type) case (S_LOGICAL) write (u, "(L1)") token%lval case (S_INTEGER) write (u, "(I0)") token%ival case (S_REAL) write (u, "(" // FMT_19 // ")") token%rval case (S_COMPLEX) write (u, "('('," // FMT_19 // ",','," // FMT_19 // ",')')") token%cval case (S_IDENTIFIER) write (u, "(A)") char (token%sval) case (S_KEYWORD) write (u, "(A,A)") '[keyword] ' // char (token%kval) case (S_QUOTED) write (u, "(A)") & char (token%quote(1)) // char (token%sval) // char (token%quote(2)) case default write (u, "(A)") '[empty]' end select end subroutine token_write @ %def token_write @ Token assignment via deep copy. This is useful to avoid confusion when the token is transferred to some parse-tree node. <>= interface assignment(=) module procedure token_assign module procedure token_assign_integer module procedure token_assign_real module procedure token_assign_complex module procedure token_assign_logical module procedure token_assign_string end interface @ %def = @ We need to copy only the contents that are actually assigned, the other pointers remain disassociated. <>= module subroutine token_assign (token, token_in) type(token_t), intent(out) :: token type(token_t), intent(in) :: token_in end subroutine token_assign <>= module subroutine token_assign (token, token_in) type(token_t), intent(out) :: token type(token_t), intent(in) :: token_in token%type = token_in%type select case (token%type) case (S_LOGICAL); allocate (token%lval); token%lval = token_in%lval case (S_INTEGER); allocate (token%ival); token%ival = token_in%ival case (S_REAL); allocate (token%rval); token%rval = token_in%rval case (S_COMPLEX); allocate (token%cval); token%cval = token_in%cval case (S_IDENTIFIER); allocate (token%sval); token%sval = token_in%sval case (S_QUOTED); allocate (token%sval); token%sval = token_in%sval allocate (token%quote(2)); token%quote = token_in%quote end select if (token%type /= S_UNKNOWN) then allocate (token%kval); token%kval = token_in%kval end if end subroutine token_assign @ %def token_assign @ We need to copy only the contents that are actually assigned, the other pointers remain disassociated. <>= module subroutine token_assign_integer (token, ival) type(token_t), intent(out) :: token integer, intent(in) :: ival end subroutine token_assign_integer module subroutine token_assign_real (token, rval) type(token_t), intent(out) :: token real(default), intent(in) :: rval end subroutine token_assign_real module subroutine token_assign_complex (token, cval) type(token_t), intent(out) :: token complex(default), intent(in) :: cval end subroutine token_assign_complex module subroutine token_assign_logical (token, lval) type(token_t), intent(out) :: token logical, intent(in) :: lval end subroutine token_assign_logical module subroutine token_assign_string (token, sval) type(token_t), intent(out) :: token type(string_t), intent(in) :: sval end subroutine token_assign_string <>= module subroutine token_assign_integer (token, ival) type(token_t), intent(out) :: token integer, intent(in) :: ival token%type = S_INTEGER allocate (token%ival) token%ival = ival end subroutine token_assign_integer module subroutine token_assign_real (token, rval) type(token_t), intent(out) :: token real(default), intent(in) :: rval token%type = S_REAL allocate (token%rval) token%rval = rval end subroutine token_assign_real module subroutine token_assign_complex (token, cval) type(token_t), intent(out) :: token complex(default), intent(in) :: cval token%type = S_COMPLEX allocate (token%cval) token%cval = cval end subroutine token_assign_complex module subroutine token_assign_logical (token, lval) type(token_t), intent(out) :: token logical, intent(in) :: lval token%type = S_LOGICAL allocate (token%lval) token%lval = lval end subroutine token_assign_logical module subroutine token_assign_string (token, sval) type(token_t), intent(out) :: token type(string_t), intent(in) :: sval token%type = S_QUOTED allocate (token%sval) token%sval = sval allocate (token%quote(2)); token%quote = '"' end subroutine token_assign_string @ %def token_assign @ \subsection{Retrieve token contents} These functions all do a trivial sanity check that should avoid crashes. <>= function token_get_logical (token) result (lval) logical :: lval type(token_t), intent(in) :: token if (associated (token%lval)) then lval = token%lval else call token_mismatch (token, "logical") end if end function token_get_logical function token_get_integer (token) result (ival) integer :: ival type(token_t), intent(in) :: token if (associated (token%ival)) then ival = token%ival else call token_mismatch (token, "integer") end if end function token_get_integer function token_get_real (token) result (rval) real(default) :: rval type(token_t), intent(in) :: token if (associated (token%rval)) then rval = token%rval else call token_mismatch (token, "real") end if end function token_get_real function token_get_cmplx (token) result (cval) complex(default) :: cval type(token_t), intent(in) :: token if (associated (token%cval)) then cval = token%cval else call token_mismatch (token, "complex") end if end function token_get_cmplx function token_get_string (token) result (sval) type(string_t) :: sval type(token_t), intent(in) :: token if (associated (token%sval)) then sval = token%sval else call token_mismatch (token, "string") end if end function token_get_string function token_get_key (token) result (kval) type(string_t) :: kval type(token_t), intent(in) :: token if (associated (token%kval)) then kval = token%kval else call token_mismatch (token, "keyword") end if end function token_get_key function token_get_quote (token) result (quote) type(string_t), dimension(2) :: quote type(token_t), intent(in) :: token if (associated (token%quote)) then quote = token%quote else call token_mismatch (token, "quote") end if end function token_get_quote @ %def token_get_logical token_get_integer token_get_real @ %def token_get_string token_get_key token_get_quote <>= subroutine token_mismatch (token, type) type(token_t), intent(in) :: token character(*), intent(in) :: type write (6, "(A)", advance="no") "Token: " call token_write (token) call msg_bug (" Token type mismatch; value required as " // type) end subroutine token_mismatch @ %def token_mismatch @ \subsection{The parse tree: nodes} The parser will generate a parse tree from the input stream. Each node in this parse tree points to the syntax rule that was applied. (Since syntax rules are stored in a pointer-type array within the syntax table, they qualify as targets.) A leaf node contains a token. A branch node has subnodes. The subnodes are stored as a list, so each node also has a [[next]] pointer. <>= public :: parse_node_t <>= type :: parse_node_t private type(syntax_rule_t), pointer :: rule => null () type(token_t) :: token integer :: n_sub = 0 type(parse_node_t), pointer :: sub_first => null () type(parse_node_t), pointer :: sub_last => null () type(parse_node_t), pointer :: next => null () contains <> end type parse_node_t @ %def parse_node_t @ Container for parse node pointers, useful for creating pointer arrays: <>= public :: parse_node_p <>= type :: parse_node_p type(parse_node_t), pointer :: ptr => null () end type parse_node_p @ %def parse_node_p @ Output. The first version writes a node together with its sub-node tree, organized by indentation. <>= procedure :: write => parse_node_write_rec <>= public :: parse_node_write_rec <>= recursive module subroutine parse_node_write_rec (node, unit, short, depth) class(parse_node_t), intent(in), target :: node integer, intent(in), optional :: unit logical, intent(in), optional :: short integer, intent(in), optional :: depth end subroutine parse_node_write_rec <>= recursive module subroutine parse_node_write_rec (node, unit, short, depth) class(parse_node_t), intent(in), target :: node integer, intent(in), optional :: unit logical, intent(in), optional :: short integer, intent(in), optional :: depth integer :: u, d type(parse_node_t), pointer :: current u = given_output_unit (unit); if (u < 0) return d = 0; if (present (depth)) d = depth call parse_node_write (node, u, short=short) current => node%sub_first do while (associated (current)) write (u, "(A)", advance = "no") repeat ("| ", d) call parse_node_write_rec (current, unit, short, d+1) current => current%next end do end subroutine parse_node_write_rec @ %def parse_node_write_rec @ This does the actual output for a single node, without recursion. <>= public :: parse_node_write <>= module subroutine parse_node_write (node, unit, short) class(parse_node_t), intent(in) :: node integer, intent(in), optional :: unit logical, intent(in), optional :: short end subroutine parse_node_write <>= module subroutine parse_node_write (node, unit, short) class(parse_node_t), intent(in) :: node integer, intent(in), optional :: unit logical, intent(in), optional :: short integer :: u type(parse_node_t), pointer :: current u = given_output_unit (unit); if (u < 0) return write (u, "('+ ')", advance = "no") if (associated (node%rule)) then call syntax_rule_write (node%rule, u, & short=short, key_only=.true., advance=.false.) if (token_is_valid (node%token)) then write (u, "(' = ')", advance="no") call token_write (node%token, u) else if (associated (node%sub_first)) then write (u, "(' = ')", advance="no") current => node%sub_first do while (associated (current)) call syntax_rule_write (current%rule, u, & short=.true., key_only=.true., advance=.false.) current => current%next end do write (u, *) else write (u, *) end if else write (u, *) "[empty]" end if end subroutine parse_node_write @ %def parse_node_write @ Finalize the token and recursively finalize and deallocate all sub-nodes. <>= public :: parse_node_final <>= recursive module subroutine parse_node_final (node, recursive) type(parse_node_t), intent(inout) :: node logical, intent(in), optional :: recursive end subroutine parse_node_final <>= recursive module subroutine parse_node_final (node, recursive) type(parse_node_t), intent(inout) :: node type(parse_node_t), pointer :: current logical, intent(in), optional :: recursive logical :: rec rec = .true.; if (present (recursive)) rec = recursive call token_final (node%token) if (rec) then do while (associated (node%sub_first)) current => node%sub_first node%sub_first => node%sub_first%next call parse_node_final (current) deallocate (current) end do end if end subroutine parse_node_final @ %def parse_node_final @ \subsection{Filling nodes} The constructors allocate and initialize the node. There are two possible initializers (in a later version, should correspond to different type extensions). First, leaf (terminal) nodes. The token constructor does the actual work, looking at the requested type and key for the given rule and matching against the lexeme contents. If it fails, the token will keep the type [[S_UNKNOWN]] and remain empty. Otherwise, we have a valid node which contains the new token. If the lexeme argument is absent, the token is left empty. <>= subroutine parse_node_create_leaf (node, rule, lexeme) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule type(lexeme_t), intent(in) :: lexeme allocate (node) node%rule => rule call token_init (node%token, lexeme, & syntax_rule_get_type (rule), syntax_rule_get_key (rule)) if (.not. token_is_valid (node%token)) deallocate (node) end subroutine parse_node_create_leaf @ %def parse_node_create_leaf @ This version allows us to manually create a leaf node that holds a keyword. <>= public :: parse_node_create_key <>= module subroutine parse_node_create_key (node, rule) type(parse_node_t), intent(out) :: node type(syntax_rule_t), intent(in), target :: rule end subroutine parse_node_create_key <>= module subroutine parse_node_create_key (node, rule) type(parse_node_t), intent(out) :: node type(syntax_rule_t), intent(in), target :: rule node%rule => rule call token_init_key (node%token, syntax_rule_get_key (rule)) end subroutine parse_node_create_key @ %def parse_node_create_key @ This version allows us to manually create a leaf node that holds a fixed value. Only one of the optional values should be provided. <>= public :: parse_node_create_value <>= module subroutine parse_node_create_value (node, rule, ival, rval, cval, sval, lval) type(parse_node_t), intent(out) :: node type(syntax_rule_t), intent(in), target :: rule integer, intent(in), optional :: ival real(default), intent(in), optional :: rval complex(default), intent(in), optional :: cval type(string_t), intent(in), optional :: sval logical, intent(in), optional :: lval end subroutine parse_node_create_value <>= module subroutine parse_node_create_value (node, rule, ival, rval, cval, sval, lval) type(parse_node_t), intent(out) :: node type(syntax_rule_t), intent(in), target :: rule integer, intent(in), optional :: ival real(default), intent(in), optional :: rval complex(default), intent(in), optional :: cval type(string_t), intent(in), optional :: sval logical, intent(in), optional :: lval node%rule => rule call parse_node_set_value (node, ival, rval, cval, sval, lval) end subroutine parse_node_create_value @ %def parse_node_create_value @ Directly set the value without changing anything else. <>= public :: parse_node_set_value <>= module subroutine parse_node_set_value (node, ival, rval, cval, sval, lval) type(parse_node_t), intent(inout) :: node integer, intent(in), optional :: ival real(default), intent(in), optional :: rval complex(default), intent(in), optional :: cval type(string_t), intent(in), optional :: sval logical, intent(in), optional :: lval end subroutine parse_node_set_value <>= module subroutine parse_node_set_value (node, ival, rval, cval, sval, lval) type(parse_node_t), intent(inout) :: node integer, intent(in), optional :: ival real(default), intent(in), optional :: rval complex(default), intent(in), optional :: cval type(string_t), intent(in), optional :: sval logical, intent(in), optional :: lval if (present (ival)) then node%token = ival else if (present (rval)) then node%token = rval else if (present (cval)) then node%token = cval else if (present (lval)) then node%token = lval else if (present (sval)) then node%token = sval end if end subroutine parse_node_set_value @ %def parse_node_set_value @ Second, branch nodes. We first assign the rule: <>= public :: parse_node_create_branch <>= module subroutine parse_node_create_branch (node, rule) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule end subroutine parse_node_create_branch <>= module subroutine parse_node_create_branch (node, rule) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule allocate (node) node%rule => rule end subroutine parse_node_create_branch @ %def parse_node_create_branch @ Copy a node. This is a shallow copy. Note that we have to nullify the [[next]] pointer if we don't want to inherit the context of the original node. <>= procedure :: copy => parse_node_copy <>= module subroutine parse_node_copy (node, copy) class(parse_node_t), intent(in) :: node type(parse_node_t), pointer, intent(out) :: copy end subroutine parse_node_copy <>= module subroutine parse_node_copy (node, copy) class(parse_node_t), intent(in) :: node type(parse_node_t), pointer, intent(out) :: copy allocate (copy) select type (node) type is (parse_node_t) copy = node end select copy%next => null () end subroutine parse_node_copy @ %def parse_node_copy @ Append a sub-node. The sub-node must exist and be a valid target, otherwise nothing is done. <>= public :: parse_node_append_sub <>= procedure :: append_sub => parse_node_append_sub <>= module subroutine parse_node_append_sub (node, sub) class(parse_node_t), intent(inout) :: node type(parse_node_t), pointer :: sub end subroutine parse_node_append_sub <>= module subroutine parse_node_append_sub (node, sub) class(parse_node_t), intent(inout) :: node type(parse_node_t), pointer :: sub if (associated (sub)) then if (associated (node%sub_last)) then node%sub_last%next => sub else node%sub_first => sub end if node%sub_last => sub end if end subroutine parse_node_append_sub @ %def parse_node_append_sub @ For easy access, once the list is complete we count the number of sub-nodes. If there are no subnodes, the whole node is deleted. <>= public :: parse_node_freeze_branch <>= module subroutine parse_node_freeze_branch (node) type(parse_node_t), pointer :: node end subroutine parse_node_freeze_branch <>= module subroutine parse_node_freeze_branch (node) type(parse_node_t), pointer :: node type(parse_node_t), pointer :: current node%n_sub = 0 current => node%sub_first do while (associated (current)) node%n_sub = node%n_sub + 1 current => current%next end do if (node%n_sub == 0) deallocate (node) end subroutine parse_node_freeze_branch @ %def parse_node_freeze_branch @ Replace the syntax rule. This makes sense only if the parse node adheres to the syntax of the new rule. <>= public :: parse_node_replace_rule <>= module subroutine parse_node_replace_rule (node, rule) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule end subroutine parse_node_replace_rule <>= module subroutine parse_node_replace_rule (node, rule) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule node%rule => rule end subroutine parse_node_replace_rule @ %def parse_node_replace_rule @ Replace the last subnode by the target node. Since the subnodes are stored as a linked list, we can do this only if we copy the subnodes. Furthermore, the target node must also be copied, and the [[next]] pointer of the copy is nullified. This ensures that we cannot modify the originals at the subnode level. All copies are shallow copies. This implies that further modifications at the sub-subnode level will affect the original nodes and must therefore be forbidden. Use with care, this invites to memory mismanagement. The copy nodes can be deallocated, but not finalized, since its subnodes are the same objects as the subnodes of the target node. <>= public :: parse_node_replace_last_sub <>= module subroutine parse_node_replace_last_sub (node, pn_target) type(parse_node_t), intent(inout), target :: node type(parse_node_t), intent(in), target :: pn_target end subroutine parse_node_replace_last_sub <>= module subroutine parse_node_replace_last_sub (node, pn_target) type(parse_node_t), intent(inout), target :: node type(parse_node_t), intent(in), target :: pn_target type(parse_node_t), pointer :: current, current_copy, previous integer :: i select case (node%n_sub) case (1) allocate (current_copy) current_copy = pn_target node%sub_first => current_copy case (2:) current => node%sub_first allocate (current_copy) current_copy = current node%sub_first => current_copy previous => current_copy do i = 1, node%n_sub - 2 current => current%next allocate (current_copy) current_copy = current previous%next => current_copy previous => current_copy end do allocate (current_copy) current_copy = pn_target previous%next => current_copy case default call parse_node_write (node) call msg_bug ("'replace_last_sub' called for non-branch parse node") end select current_copy%next => null () node%sub_last => current_copy end subroutine parse_node_replace_last_sub @ %def parse_node_replace_last_sub @ \subsection{Accessing nodes} Return the node contents. Check if pointers are associated. No check when accessing a sub-node; assume that [[parse_node_n_sub]] is always used for the upper bound. The token extractor returns a pointer. <>= public :: parse_node_get_rule_ptr public :: parse_node_get_n_sub public :: parse_node_get_sub_ptr public :: parse_node_get_next_ptr public :: parse_node_get_last_sub_ptr <>= procedure :: get_rule_ptr => parse_node_get_rule_ptr procedure :: get_n_sub => parse_node_get_n_sub procedure :: get_sub_ptr => parse_node_get_sub_ptr procedure :: get_next_ptr => parse_node_get_next_ptr <>= module function parse_node_get_rule_ptr (node) result (rule) class(parse_node_t), intent(in) :: node type(syntax_rule_t), pointer :: rule end function parse_node_get_rule_ptr module function parse_node_get_last_sub_ptr (node, tag, required) result (sub) type(parse_node_t), pointer :: sub type(parse_node_t), intent(in), target :: node character(*), intent(in), optional :: tag logical, intent(in), optional :: required end function parse_node_get_last_sub_ptr module function parse_node_get_n_sub (node) result (n) class(parse_node_t), intent(in) :: node integer :: n end function parse_node_get_n_sub module function parse_node_get_sub_ptr (node, n, tag, required) result (sub) class(parse_node_t), intent(in), target :: node type(parse_node_t), pointer :: sub integer, intent(in), optional :: n character(*), intent(in), optional :: tag logical, intent(in), optional :: required end function parse_node_get_sub_ptr module function parse_node_get_next_ptr (sub, n, tag, required) result (next) class(parse_node_t), intent(in), target :: sub type(parse_node_t), pointer :: next integer, intent(in), optional :: n character(*), intent(in), optional :: tag logical, intent(in), optional :: required end function parse_node_get_next_ptr <>= module function parse_node_get_rule_ptr (node) result (rule) class(parse_node_t), intent(in) :: node type(syntax_rule_t), pointer :: rule if (associated (node%rule)) then rule => node%rule else rule => null () call parse_node_undefined (node, "rule") end if end function parse_node_get_rule_ptr module function parse_node_get_n_sub (node) result (n) class(parse_node_t), intent(in) :: node integer :: n n = node%n_sub end function parse_node_get_n_sub module function parse_node_get_sub_ptr (node, n, tag, required) result (sub) class(parse_node_t), intent(in), target :: node type(parse_node_t), pointer :: sub integer, intent(in), optional :: n character(*), intent(in), optional :: tag logical, intent(in), optional :: required integer :: i sub => node%sub_first if (present (n)) then do i = 2, n if (associated (sub)) then sub => sub%next else return end if end do end if call parse_node_check (sub, tag, required) end function parse_node_get_sub_ptr module function parse_node_get_next_ptr (sub, n, tag, required) result (next) class(parse_node_t), intent(in), target :: sub type(parse_node_t), pointer :: next integer, intent(in), optional :: n character(*), intent(in), optional :: tag logical, intent(in), optional :: required integer :: i next => sub%next if (present (n)) then do i = 2, n if (associated (next)) then next => next%next else exit end if end do end if call parse_node_check (next, tag, required) end function parse_node_get_next_ptr module function parse_node_get_last_sub_ptr (node, tag, required) result (sub) type(parse_node_t), pointer :: sub type(parse_node_t), intent(in), target :: node character(*), intent(in), optional :: tag logical, intent(in), optional :: required sub => node%sub_last call parse_node_check (sub, tag, required) end function parse_node_get_last_sub_ptr @ %def parse_node_get_rule_ptr @ %def parse_node_get_n_sub parse_node_get_sub_ptr @ %def parse_node_get_next_ptr @ %def parse_node_get_last_sub_ptr <>= subroutine parse_node_undefined (node, obj) type(parse_node_t), intent(in) :: node character(*), intent(in) :: obj call parse_node_write (node, 6) call msg_bug (" Parse-tree node: " // obj // " requested, but undefined") end subroutine parse_node_undefined @ %def parse_node_undefined @ Check if a parse node has a particular tag, and if it is associated: <>= public :: parse_node_check <>= module subroutine parse_node_check (node, tag, required) type(parse_node_t), pointer :: node character(*), intent(in), optional :: tag logical, intent(in), optional :: required end subroutine parse_node_check <>= module subroutine parse_node_check (node, tag, required) type(parse_node_t), pointer :: node character(*), intent(in), optional :: tag logical, intent(in), optional :: required if (associated (node)) then if (present (tag)) then if (parse_node_get_rule_key (node) /= tag) & call parse_node_mismatch (tag, node) end if else if (present (required)) then if (required) & call msg_bug (" Missing node, expected <" // tag // ">") end if end if end subroutine parse_node_check @ %def parse_node_check @ This is called by a parse-tree scanner if the expected and the actual nodes do not match <>= public :: parse_node_mismatch <>= module subroutine parse_node_mismatch (string, parse_node) character(*), intent(in) :: string type(parse_node_t), intent(in) :: parse_node end subroutine parse_node_mismatch <>= module subroutine parse_node_mismatch (string, parse_node) character(*), intent(in) :: string type(parse_node_t), intent(in) :: parse_node call parse_node_write (parse_node) call msg_bug (" Syntax mismatch, expected <" // string // ">.") end subroutine parse_node_mismatch @ %def parse_node_mismatch @ The following functions are wrappers for extracting the token contents. <>= public :: parse_node_get_logical public :: parse_node_get_integer public :: parse_node_get_real public :: parse_node_get_cmplx public :: parse_node_get_string public :: parse_node_get_key public :: parse_node_get_rule_key <>= procedure :: get_logical => parse_node_get_logical procedure :: get_integer => parse_node_get_integer procedure :: get_real => parse_node_get_real procedure :: get_cmplx => parse_node_get_cmplx procedure :: get_string => parse_node_get_string procedure :: get_key => parse_node_get_key procedure :: get_rule_key => parse_node_get_rule_key <>= module function parse_node_get_logical (node) result (lval) class(parse_node_t), intent(in), target :: node logical :: lval end function parse_node_get_logical module function parse_node_get_integer (node) result (ival) class(parse_node_t), intent(in), target :: node integer :: ival end function parse_node_get_integer module function parse_node_get_real (node) result (rval) class(parse_node_t), intent(in), target :: node real(default) :: rval end function parse_node_get_real module function parse_node_get_cmplx (node) result (cval) class(parse_node_t), intent(in), target :: node complex(default) :: cval end function parse_node_get_cmplx module function parse_node_get_string (node) result (sval) class(parse_node_t), intent(in), target :: node type(string_t) :: sval end function parse_node_get_string module function parse_node_get_key (node) result (kval) class(parse_node_t), intent(in), target :: node type(string_t) :: kval end function parse_node_get_key module function parse_node_get_rule_key (node) result (kval) class(parse_node_t), intent(in), target :: node type(string_t) :: kval end function parse_node_get_rule_key module function parse_node_get_token_ptr (node) result (token) type(token_t), pointer :: token type(parse_node_t), intent(in), target :: node end function parse_node_get_token_ptr <>= module function parse_node_get_logical (node) result (lval) class(parse_node_t), intent(in), target :: node logical :: lval lval = token_get_logical (parse_node_get_token_ptr (node)) end function parse_node_get_logical module function parse_node_get_integer (node) result (ival) class(parse_node_t), intent(in), target :: node integer :: ival ival = token_get_integer (parse_node_get_token_ptr (node)) end function parse_node_get_integer module function parse_node_get_real (node) result (rval) class(parse_node_t), intent(in), target :: node real(default) :: rval rval = token_get_real (parse_node_get_token_ptr (node)) end function parse_node_get_real module function parse_node_get_cmplx (node) result (cval) class(parse_node_t), intent(in), target :: node complex(default) :: cval cval = token_get_cmplx (parse_node_get_token_ptr (node)) end function parse_node_get_cmplx module function parse_node_get_string (node) result (sval) class(parse_node_t), intent(in), target :: node type(string_t) :: sval sval = token_get_string (parse_node_get_token_ptr (node)) end function parse_node_get_string module function parse_node_get_key (node) result (kval) class(parse_node_t), intent(in), target :: node type(string_t) :: kval kval = token_get_key (parse_node_get_token_ptr (node)) end function parse_node_get_key module function parse_node_get_rule_key (node) result (kval) class(parse_node_t), intent(in), target :: node type(string_t) :: kval kval = syntax_rule_get_key (parse_node_get_rule_ptr (node)) end function parse_node_get_rule_key module function parse_node_get_token_ptr (node) result (token) type(token_t), pointer :: token type(parse_node_t), intent(in), target :: node if (token_is_valid (node%token)) then token => node%token else call parse_node_undefined (node, "token") end if end function parse_node_get_token_ptr @ %def parse_node_get_logical parse_node_get_integer parse_node_get_real @ %def parse_node_get_string parse_node_get_key parse_node_get_rule_key @ %def parse_node_get_token_ptr @ Return a MD5 sum for a parse node. The method is to write the node to a scratch file and to evaluate the MD5 sum of that file. <>= public :: parse_node_get_md5sum <>= module function parse_node_get_md5sum (pn) result (md5sum_pn) character(32) :: md5sum_pn type(parse_node_t), intent(in) :: pn end function parse_node_get_md5sum <>= module function parse_node_get_md5sum (pn) result (md5sum_pn) character(32) :: md5sum_pn type(parse_node_t), intent(in) :: pn integer :: u u = free_unit () open (unit = u, status = "scratch", action = "readwrite") call parse_node_write_rec (pn, unit=u) rewind (u) md5sum_pn = md5sum (u) close (u) end function parse_node_get_md5sum @ %def parse_node_get_md5sum @ \subsection{The parse tree} The parse tree is a tree of nodes, where leaf nodes hold a valid token, while branch nodes point to a list of sub-nodes. <>= public :: parse_tree_t <>= type :: parse_tree_t private type(parse_node_t), pointer :: root_node => null () contains <> end type parse_tree_t @ %def parse_tree_t @ The parser. Its arguments are the parse tree (which should be empty initially), the lexer (which should be already set up), the syntax table (which should be valid), and the input stream. The input stream is completely parsed, using the lexer setup and the syntax rules as given, and the parse tree is built accordingly. If [[check_eof]] is absent or true, the parser will complain about trailing garbage. Otherwise, it will ignore it. By default, the input stream is matched against the top rule in the specified syntax. If [[key]] is given, it is matched against the rule with the specified key instead. Failure at the top level means that no rule could match at all; in this case the error message will show the top rule. <>= public :: parse_tree_init <>= procedure :: parse => parse_tree_init <>= module subroutine parse_tree_init & (parse_tree, syntax, lexer, key, check_eof) class(parse_tree_t), intent(inout) :: parse_tree type(lexer_t), intent(inout) :: lexer type(syntax_t), intent(in), target :: syntax type(string_t), intent(in), optional :: key logical, intent(in), optional :: check_eof end subroutine parse_tree_init <>= module subroutine parse_tree_init & (parse_tree, syntax, lexer, key, check_eof) class(parse_tree_t), intent(inout) :: parse_tree type(lexer_t), intent(inout) :: lexer type(syntax_t), intent(in), target :: syntax type(string_t), intent(in), optional :: key logical, intent(in), optional :: check_eof type(syntax_rule_t), pointer :: rule type(lexeme_t) :: lexeme type(parse_node_t), pointer :: node logical :: ok, check check = .true.; if (present (check_eof)) check = check_eof call lexer_clear (lexer) if (present (key)) then rule => syntax_get_rule_ptr (syntax, key) else rule => syntax_get_top_rule_ptr (syntax) end if if (associated (rule)) then call parse_node_match_rule (node, rule, ok) if (ok) then parse_tree%root_node => node else call parse_error (rule, lexeme) end if if (check) then call lex (lexeme, lexer) if (.not. lexeme_is_eof (lexeme)) then call lexer_show_location (lexer) call msg_fatal (" Syntax error " & // "(at or before the location indicated above)") end if end if else call msg_bug (" Parser failed because syntax is empty") end if contains <> end subroutine parse_tree_init @ %def parse @ The parser works recursively, following the rule tree, building the tree of nodes on the fly. If the given rule matches, the node is filled on return. If not, the node remains empty. <>= recursive subroutine parse_node_match_rule (node, rule, ok) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule logical, intent(out) :: ok logical, parameter :: debug = .false. integer :: type if (debug) write (6, "(A)", advance="no") "Parsing rule: " if (debug) call syntax_rule_write (rule, 6) node => null () type = syntax_rule_get_type (rule) if (syntax_rule_is_atomic (rule)) then call lex (lexeme, lexer) if (debug) write (6, "(A)", advance="no") "Token: " if (debug) call lexeme_write (lexeme, 6) call parse_node_create_leaf (node, rule, lexeme) ok = associated (node) if (.not. ok) call lexer_put_back (lexer, lexeme) else select case (type) case (S_ALTERNATIVE); call parse_alternative (node, rule, ok) case (S_GROUP); call parse_group (node, rule, ok) case (S_SEQUENCE); call parse_sequence (node, rule, .false., ok) case (S_LIST); call parse_sequence (node, rule, .true., ok) case (S_ARGS); call parse_args (node, rule, ok) case (S_IGNORE); call parse_ignore (node, ok) end select end if if (debug) then if (ok) then write (6, "(A)", advance="no") "Matched rule: " else write (6, "(A)", advance="no") "Failed rule: " end if call syntax_rule_write (rule) if (associated (node)) call parse_node_write (node) end if end subroutine parse_node_match_rule @ %def parse_node_match_rule @ Parse an alternative: try each case. If the match succeeds, the node has been filled, so return. If nothing works, return failure. <>= recursive subroutine parse_alternative (node, rule, ok) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule logical, intent(out) :: ok integer :: i do i = 1, syntax_rule_get_n_sub (rule) call parse_node_match_rule (node, syntax_rule_get_sub_ptr (rule, i), ok) if (ok) return end do ok = .false. end subroutine parse_alternative @ %def parse_alternative @ Parse a group: the first and third lexemes have to be the delimiters, the second one is parsed as the actual node, using now the child rule. If the first match fails, return with failure. If the other matches fail, issue an error, since we cannot lex back more than one item. <>= recursive subroutine parse_group (node, rule, ok) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule logical, intent(out) :: ok type(string_t), dimension(2) :: delimiter delimiter = syntax_rule_get_delimiter (rule) call lex (lexeme, lexer) if (lexeme_get_string (lexeme) == delimiter(1)) then call parse_node_match_rule (node, syntax_rule_get_sub_ptr (rule, 1), ok) if (ok) then call lex (lexeme, lexer) if (lexeme_get_string (lexeme) == delimiter(2)) then ok = .true. else call parse_error (rule, lexeme) end if else call parse_error (rule, lexeme) end if else call lexer_put_back (lexer, lexeme) ok = .false. end if end subroutine parse_group @ %def parse_group @ Parsing a sequence. The last rule element may be special: optional and/or repetitive. Each sub-node that matches is appended to the sub-node list of the parent node. If [[sep]] is true, we look for a separator after each element. <>= recursive subroutine parse_sequence (node, rule, sep, ok) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule logical, intent(in) :: sep logical, intent(out) :: ok type(parse_node_t), pointer :: current integer :: i, n logical :: opt, rep, cont type(string_t) :: separator call parse_node_create_branch (node, rule) if (sep) separator = syntax_rule_get_separator (rule) n = syntax_rule_get_n_sub (rule) opt = syntax_rule_last_optional (rule) rep = syntax_rule_last_repetitive (rule) ok = .true. cont = .true. SCAN_RULE: do i = 1, n call parse_node_match_rule & (current, syntax_rule_get_sub_ptr (rule, i), cont) if (cont) then call parse_node_append_sub (node, current) if (sep .and. (i>= recursive subroutine parse_args (node, rule, ok) type(parse_node_t), pointer :: node type(syntax_rule_t), intent(in), target :: rule logical, intent(out) :: ok type(string_t), dimension(2) :: delimiter delimiter = syntax_rule_get_delimiter (rule) call lex (lexeme, lexer) if (lexeme_get_string (lexeme) == delimiter(1)) then call parse_sequence (node, rule, .true., ok) if (ok) then call lex (lexeme, lexer) if (lexeme_get_string (lexeme) == delimiter(2)) then ok = .true. else call parse_error (rule, lexeme) end if else call parse_error (rule, lexeme) end if else call lexer_put_back (lexer, lexeme) ok = .false. end if end subroutine parse_args @ %def parse_args @ The IGNORE syntax reads one lexeme and discards it if it is numeric, logical or string/identifier (but not a keyword). This is a successful match. Otherwise, the match fails. The node pointer is returned disassociated in any case. <>= subroutine parse_ignore (node, ok) type(parse_node_t), pointer :: node logical, intent(out) :: ok call lex (lexeme, lexer) select case (lexeme_get_type (lexeme)) case (T_NUMERIC, T_IDENTIFIER, T_QUOTED) ok = .true. case default ok = .false. end select node => null () end subroutine parse_ignore @ %def parse_ignore @ If the match fails and we cannot step back: <>= subroutine parse_error (rule, lexeme) type(syntax_rule_t), intent(in) :: rule type(lexeme_t), intent(in) :: lexeme character(80) :: buffer integer :: u, iostat call lexer_show_location (lexer) u = free_unit () open (u, status = "scratch") write (u, "(A)", advance="no") "Expected syntax:" call syntax_rule_write (rule, u) write (u, "(A)", advance="no") "Found token:" call lexeme_write (lexeme, u) rewind (u) do read (u, "(A)", iostat=iostat) buffer if (iostat /= 0) exit call msg_message (trim (buffer)) end do call msg_fatal (" Syntax error " & // "(at or before the location indicated above)") end subroutine parse_error @ %def parse_error @ The finalizer recursively deallocates all nodes and their contents. For each node, [[parse_node_final]] is called on the sub-nodes, which in turn deallocates the token or sub-node array contained within each of them. At the end, only the top node remains to be deallocated. <>= public :: parse_tree_final <>= procedure :: final => parse_tree_final <>= module subroutine parse_tree_final (parse_tree) class(parse_tree_t), intent(inout) :: parse_tree end subroutine parse_tree_final <>= module subroutine parse_tree_final (parse_tree) class(parse_tree_t), intent(inout) :: parse_tree if (associated (parse_tree%root_node)) then call parse_node_final (parse_tree%root_node) deallocate (parse_tree%root_node) end if end subroutine parse_tree_final @ %def parse_tree_final @ Print the parse tree. Print one token per line, indented according to the depth of the node. The [[verbose]] version includes type identifiers for the nodes. <>= public :: parse_tree_write <>= procedure :: write => parse_tree_write <>= module subroutine parse_tree_write (parse_tree, unit, verbose) class(parse_tree_t), intent(in) :: parse_tree integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine parse_tree_write <>= module subroutine parse_tree_write (parse_tree, unit, verbose) class(parse_tree_t), intent(in) :: parse_tree integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: short u = given_output_unit (unit); if (u < 0) return short = .true.; if (present (verbose)) short = .not. verbose write (u, "(A)") "Parse tree:" if (associated (parse_tree%root_node)) then call parse_node_write_rec (parse_tree%root_node, unit, short, 1) else write (u, *) "[empty]" end if end subroutine parse_tree_write @ %def parse_tree_write @ This is a generic error that can be issued if the parse tree does not meet the expectaions of the parser. This most certainly indicates a bug. <>= public :: parse_tree_bug <>= module subroutine parse_tree_bug (node, keys) type(parse_node_t), intent(in) :: node character(*), intent(in) :: keys end subroutine parse_tree_bug <>= module subroutine parse_tree_bug (node, keys) type(parse_node_t), intent(in) :: node character(*), intent(in) :: keys call parse_node_write (node) call msg_bug (" Inconsistency in parse tree: expected " // keys) end subroutine parse_tree_bug @ %def parse_tree_bug @ \subsection{Access the parser} For scanning the parse tree we give access to the top node, as a node pointer. Of course, there should be no write access. <>= procedure :: get_root_ptr => parse_tree_get_root_ptr <>= module function parse_tree_get_root_ptr (parse_tree) result (node) class(parse_tree_t), intent(in) :: parse_tree type(parse_node_t), pointer :: node end function parse_tree_get_root_ptr <>= module function parse_tree_get_root_ptr (parse_tree) result (node) class(parse_tree_t), intent(in) :: parse_tree type(parse_node_t), pointer :: node node => parse_tree%root_node end function parse_tree_get_root_ptr @ %def parse_tree_get_root_ptr @ \subsection{Tools} This operation traverses the parse tree and simplifies any occurences of a set of syntax rules. If such a parse node has only one sub-node, it is replaced by that subnode. (This makes sense only of the rules to eliminate have no meaningful token.) <>= public :: parse_tree_reduce <>= module subroutine parse_tree_reduce (parse_tree, rule_key) type(parse_tree_t), intent(inout) :: parse_tree type(string_t), dimension(:), intent(in) :: rule_key end subroutine parse_tree_reduce <>= module subroutine parse_tree_reduce (parse_tree, rule_key) type(parse_tree_t), intent(inout) :: parse_tree type(string_t), dimension(:), intent(in) :: rule_key type(parse_node_t), pointer :: pn pn => parse_tree%root_node if (associated (pn)) then call parse_node_reduce (pn, null(), null()) end if contains recursive subroutine parse_node_reduce (pn, pn_prev, pn_parent) type(parse_node_t), intent(inout), pointer :: pn type(parse_node_t), intent(in), pointer :: pn_prev, pn_parent type(parse_node_t), pointer :: pn_sub, pn_sub_prev, pn_tmp pn_sub_prev => null () pn_sub => pn%sub_first do while (associated (pn_sub)) call parse_node_reduce (pn_sub, pn_sub_prev, pn) pn_sub_prev => pn_sub pn_sub => pn_sub%next end do if (parse_node_get_n_sub (pn) == 1) then if (matches (parse_node_get_rule_key (pn), rule_key)) then pn_tmp => pn pn => pn%sub_first if (associated (pn_prev)) then pn_prev%next => pn else if (associated (pn_parent)) then pn_parent%sub_first => pn else parse_tree%root_node => pn end if if (associated (pn_tmp%next)) then pn%next => pn_tmp%next else if (associated (pn_parent)) then pn_parent%sub_last => pn end if call parse_node_final (pn_tmp, recursive=.false.) deallocate (pn_tmp) end if end if end subroutine parse_node_reduce function matches (key, key_list) result (flag) logical :: flag type(string_t), intent(in) :: key type(string_t), dimension(:), intent(in) :: key_list integer :: i flag = .true. do i = 1, size (key_list) if (key == key_list(i)) return end do flag = .false. end function matches end subroutine parse_tree_reduce @ %def parse_tree_reduce @ \subsection{Applications} For a file of the form \begin{verbatim} process foo, bar process xyz \end{verbatim} get the \verb|| entry node for the first matching process tag. If no matching entry is found, the node pointer remains unassociated. <>= public :: parse_tree_get_process_ptr <>= module function parse_tree_get_process_ptr (parse_tree, process) result (node) type(parse_node_t), pointer :: node type(parse_tree_t), intent(in), target :: parse_tree type(string_t), intent(in) :: process end function parse_tree_get_process_ptr <>= module function parse_tree_get_process_ptr (parse_tree, process) result (node) type(parse_node_t), pointer :: node type(parse_tree_t), intent(in), target :: parse_tree type(string_t), intent(in) :: process type(parse_node_t), pointer :: node_root, node_process_def type(parse_node_t), pointer :: node_process_phs, node_process_list integer :: j node_root => parse_tree%get_root_ptr () if (associated (node_root)) then node_process_phs => parse_node_get_sub_ptr (node_root) SCAN_FILE: do while (associated (node_process_phs)) node_process_def => parse_node_get_sub_ptr (node_process_phs) node_process_list => parse_node_get_sub_ptr (node_process_def, 2) do j = 1, parse_node_get_n_sub (node_process_list) if (parse_node_get_string & (parse_node_get_sub_ptr (node_process_list, j)) & == process) then node => parse_node_get_next_ptr (node_process_def) return end if end do node_process_phs => parse_node_get_next_ptr (node_process_phs) end do SCAN_FILE node => null () else node => null () end if end function parse_tree_get_process_ptr @ %def parse_tree_get_process_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[parser_ut.f90]]>>= <> module parser_ut use unit_tests use parser_uti <> <> contains <> end module parser_ut @ %def parser_ut @ <<[[parser_uti.f90]]>>= <> module parser_uti use syntax_rules use parser <> <> contains <> end module parser_uti @ %def parser_ut @ API: driver for the unit tests below. <>= public :: parse_test <>= subroutine parse_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine parse_test @ %def parse_test @ This checks the parser. <>= call test (parse_1, "parse_1", & "check the parser", & u, results) <>= public :: parse_1 <>= subroutine parse_1 (u) use ifiles use lexers integer, intent(in) :: u type(ifile_t) :: ifile type(syntax_t), target :: syntax type(lexer_t) :: lexer type(stream_t), target :: stream type(parse_tree_t), target :: parse_tree write (u, "(A)") "* Test output: Parsing" write (u, "(A)") "* Purpose: test parse routines" write (u, "(A)") call ifile_append (ifile, "SEQ expr = term addition*") call ifile_append (ifile, "SEQ addition = plus_or_minus term") call ifile_append (ifile, "SEQ term = factor multiplication*") call ifile_append (ifile, "SEQ multiplication = times_or_over factor") call ifile_append (ifile, "SEQ factor = atom exponentiation*") call ifile_append (ifile, "SEQ exponentiation = '^' atom") call ifile_append (ifile, "ALT atom = real | delimited_expr") call ifile_append (ifile, "GRO delimited_expr = ( expr )") call ifile_append (ifile, "ALT plus_or_minus = '+' | '-'") call ifile_append (ifile, "ALT times_or_over = '*' | '/'") call ifile_append (ifile, "KEY '+'") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY '*'") call ifile_append (ifile, "KEY '/'") call ifile_append (ifile, "KEY '^'") call ifile_append (ifile, "REA real") write (u, "(A)") "* File contents (syntax definition):" call ifile_write (ifile, u) write (u, "(A)") "EOF" write (u, "(A)") call syntax_init (syntax, ifile) call ifile_final (ifile) call syntax_write (syntax, u) write (u, "(A)") call lexer_init (lexer, & comment_chars = "", & quote_chars = "'", & quote_match = "'", & single_chars = "+-*/^()", & special_class = [""] , & keyword_list = syntax_get_keyword_list_ptr (syntax)) call lexer_write_setup (lexer, u) write (u, "(A)") call ifile_append (ifile, "(27+8^3-2/3)*(4+7)^2*99") write (u, "(A)") "* File contents (input file):" call ifile_write (ifile, u) write (u, "(A)") "EOF" print * call stream_init (stream, ifile) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax, lexer) call stream_final (stream) call parse_tree_write (parse_tree, u, .true.) print * write (u, "(A)") "* Cleanup, everything should now be empty:" write (u, "(A)") call parse_tree_final (parse_tree) call parse_tree_write (parse_tree, u, .true.) write (u, "(A)") call lexer_final (lexer) call lexer_write_setup (lexer, u) write (u, "(A)") call ifile_final (ifile) write (u, "(A)") "* File contents:" call ifile_write (ifile, u) write (u, "(A)") "EOF" write (u, "(A)") call syntax_final (syntax) call syntax_write (syntax, u) write (u, "(A)") write (u, "(A)") "* Test output end: parser_1" end subroutine parse_1 @ %def parse_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{XML Parser} The XML parser is actually independent from the previous modules of lexer and parser. However, for a generic I/O interface we make use of the [[stream_t]] facility. We need the XML parser for reading and writing LHEF data files. Only a subset of XML is actually relevant. The parser is of the ``pull'' type, i.e., the program steers the reading of XML data in a context-sensitive manner. <<[[xml.f90]]>>= <> module xml <> use lexers <> <> <> interface <> end interface end module xml @ %def xml @ <<[[xml_sub.f90]]>>= <> submodule (xml) xml_s use io_units use system_defs, only: BLANK, TAB use diagnostics use ifiles implicit none contains <> end submodule xml_s @ %def xml_s \subsection{Cached Stream} The stream type as defined in the [[lexer]] module is versatile regarding the choice of input channel, but it does not allow reading a section more than once. Here, we define an extension where we can return a string to the stream, which is stored in a cache variable, and presented to the caller for the next read. <>= public :: cstream_t <>= type, extends (stream_t) :: cstream_t logical :: cache_is_empty = .true. type(string_t) :: cache contains <> end type cstream_t @ %def cached_stream @ The initializers are simply inherited. Finalizer: also inherited, in essence: <>= procedure :: final => cstream_final <>= module subroutine cstream_final (stream) class(cstream_t), intent(inout) :: stream end subroutine cstream_final <>= module subroutine cstream_final (stream) class(cstream_t), intent(inout) :: stream stream%cache_is_empty = .true. call stream%stream_t%final () end subroutine cstream_final @ %def cstream_final @ Get record: now, if there is a cache string, return this instead of the record from the stream. <>= procedure :: get_record => cstream_get_record <>= module subroutine cstream_get_record (cstream, string, iostat) class(cstream_t), intent(inout) :: cstream type(string_t), intent(out) :: string integer, intent(out) :: iostat end subroutine cstream_get_record <>= module subroutine cstream_get_record (cstream, string, iostat) class(cstream_t), intent(inout) :: cstream type(string_t), intent(out) :: string integer, intent(out) :: iostat if (cstream%cache_is_empty) then call stream_get_record (cstream%stream_t, string, iostat) else string = cstream%cache cstream%cache_is_empty = .true. iostat = 0 end if end subroutine cstream_get_record @ %def cstream_get_record @ Revert: return the (partially read) record to the stream, putting it in the cache. <>= procedure :: revert_record => cstream_revert_record <>= module subroutine cstream_revert_record (cstream, string) class(cstream_t), intent(inout) :: cstream type(string_t), intent(in) :: string end subroutine cstream_revert_record <>= module subroutine cstream_revert_record (cstream, string) class(cstream_t), intent(inout) :: cstream type(string_t), intent(in) :: string if (cstream%cache_is_empty) then cstream%cache = string cstream%cache_is_empty = .false. else call msg_bug ("CStream: attempt to revert twice") end if end subroutine cstream_revert_record @ %def cstream_revert_record @ \subsection{Attributes} A tag attribute has a name and a value; both are strings. When the attribute is defined, the [[known]] flag indicates this. <>= type :: attribute_t type(string_t) :: name type(string_t) :: value logical :: known = .false. contains <> end type attribute_t @ %def attribute_t @ Output in standard format, non-advancing. (If the value is unknown, we indicate this by a question mark, which is non-standard.) <>= procedure :: write => attribute_write <>= module subroutine attribute_write (object, unit) class(attribute_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine attribute_write <>= module subroutine attribute_write (object, unit) class(attribute_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A,'=')", advance = "no") char (object%name) if (object%known) then write (u, "(A,A,A)", advance = "no") '"', char (object%value), '"' else write (u, "('?')", advance = "no") end if end subroutine attribute_write @ %def attribute_write @ This is a genuine constructor. The value is optional. <>= public :: xml_attribute <>= module function xml_attribute (name, value) result (attribute) type(string_t), intent(in) :: name type(string_t), intent(in), optional :: value type(attribute_t) :: attribute end function xml_attribute <>= module function xml_attribute (name, value) result (attribute) type(string_t), intent(in) :: name type(string_t), intent(in), optional :: value type(attribute_t) :: attribute attribute%name = name if (present (value)) then attribute%value = value attribute%known = .true. else attribute%known = .false. end if end function xml_attribute @ %def xml_attribute @ Set a value explicitly. <>= procedure :: set_value => attribute_set_value <>= module subroutine attribute_set_value (attribute, value) class(attribute_t), intent(inout) :: attribute type(string_t), intent(in) :: value end subroutine attribute_set_value <>= module subroutine attribute_set_value (attribute, value) class(attribute_t), intent(inout) :: attribute type(string_t), intent(in) :: value attribute%value = value attribute%known = .true. end subroutine attribute_set_value @ %def attribute_set_value @ Extract a value. If unset, return [["?"]] <>= procedure :: get_value => attribute_get_value <>= module function attribute_get_value (attribute) result (value) class(attribute_t), intent(in) :: attribute type(string_t) :: value end function attribute_get_value <>= module function attribute_get_value (attribute) result (value) class(attribute_t), intent(in) :: attribute type(string_t) :: value if (attribute%known) then value = attribute%value else value = "?" end if end function attribute_get_value @ %def attribute_get_value @ \subsection{The Tag Type} The basic entity is the internal representation of an XML tag. The tag has a name, a well-defined set of attributes which may be mandatory or optional, and a flag that determines whether there is content or not. The content itself is not stored in the data structure. <>= public :: xml_tag_t <>= type :: xml_tag_t type(string_t) :: name type(attribute_t), dimension(:), allocatable :: attribute logical :: has_content = .false. contains <> end type xml_tag_t @ %def xml_tag_t @ Initialization. There are different versions, depending on content. <>= generic :: init => init_no_attributes procedure :: init_no_attributes => xml_tag_init_no_attributes <>= module subroutine xml_tag_init_no_attributes (tag, name, has_content) class(xml_tag_t), intent(out) :: tag type(string_t), intent(in) :: name logical, intent(in), optional :: has_content end subroutine xml_tag_init_no_attributes <>= module subroutine xml_tag_init_no_attributes (tag, name, has_content) class(xml_tag_t), intent(out) :: tag type(string_t), intent(in) :: name logical, intent(in), optional :: has_content tag%name = name allocate (tag%attribute (0)) if (present (has_content)) tag%has_content = has_content end subroutine xml_tag_init_no_attributes @ %def xml_tag_init_no_attributes @ This version sets attributes. <>= generic :: init => init_with_attributes procedure :: init_with_attributes => xml_tag_init_with_attributes <>= module subroutine xml_tag_init_with_attributes (tag, name, attribute, has_content) class(xml_tag_t), intent(out) :: tag type(string_t), intent(in) :: name type(attribute_t), dimension(:), intent(in) :: attribute logical, intent(in), optional :: has_content end subroutine xml_tag_init_with_attributes <>= module subroutine xml_tag_init_with_attributes (tag, name, attribute, has_content) class(xml_tag_t), intent(out) :: tag type(string_t), intent(in) :: name type(attribute_t), dimension(:), intent(in) :: attribute logical, intent(in), optional :: has_content tag%name = name allocate (tag%attribute (size (attribute))) tag%attribute = attribute if (present (has_content)) tag%has_content = has_content end subroutine xml_tag_init_with_attributes @ %def xml_tag_init_with_attributes @ Set an attribute value explicitly. <>= procedure :: set_attribute => xml_tag_set_attribute <>= module subroutine xml_tag_set_attribute (tag, i, value) class(xml_tag_t), intent(inout) :: tag integer, intent(in) :: i type(string_t), intent(in) :: value end subroutine xml_tag_set_attribute <>= module subroutine xml_tag_set_attribute (tag, i, value) class(xml_tag_t), intent(inout) :: tag integer, intent(in) :: i type(string_t), intent(in) :: value call tag%attribute(i)%set_value (value) end subroutine xml_tag_set_attribute @ %def xml_tag_set_attribute @ Get an attribute value. <>= procedure :: get_attribute => xml_tag_get_attribute <>= module function xml_tag_get_attribute (tag, i) result (value) class(xml_tag_t), intent(in) :: tag integer, intent(in) :: i type(string_t) :: value end function xml_tag_get_attribute <>= module function xml_tag_get_attribute (tag, i) result (value) class(xml_tag_t), intent(in) :: tag integer, intent(in) :: i type(string_t) :: value value = tag%attribute(i)%get_value () end function xml_tag_get_attribute @ %def xml_tag_set_attribute @ Output to an I/O unit, default STDOUT. We use non-advancing output. <>= generic :: write => write_without_content procedure :: write_without_content => xml_tag_write <>= module subroutine xml_tag_write (tag, unit) class(xml_tag_t), intent(in) :: tag integer, intent(in), optional :: unit end subroutine xml_tag_write <>= module subroutine xml_tag_write (tag, unit) class(xml_tag_t), intent(in) :: tag integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "('<',A)", advance = "no") char (tag%name) do i = 1, size (tag%attribute) write (u, "(1x)", advance = "no") call tag%attribute(i)%write (u) end do if (tag%has_content) then write (u, "('>')", advance = "no") else write (u, "(' />')", advance = "no") end if end subroutine xml_tag_write @ %def xml_tag_write @ If there is content, we should write the context next (arbitrary format), the write the corresponding closing tag. Again, non-advancing. <>= procedure :: close => xml_tag_close <>= module subroutine xml_tag_close (tag, unit) class(xml_tag_t), intent(in) :: tag integer, intent(in), optional :: unit end subroutine xml_tag_close <>= module subroutine xml_tag_close (tag, unit) class(xml_tag_t), intent(in) :: tag integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "('')", advance = "no") char (tag%name) end subroutine xml_tag_close @ %def xml_tag_close @ Given content as a single string, we can write tag, content, and closing at once <>= generic :: write => write_with_content procedure :: write_with_content => xml_tag_write_with_content <>= module subroutine xml_tag_write_with_content (tag, content, unit) class(xml_tag_t), intent(in) :: tag type(string_t), intent(in) :: content integer, intent(in), optional :: unit end subroutine xml_tag_write_with_content <>= module subroutine xml_tag_write_with_content (tag, content, unit) class(xml_tag_t), intent(in) :: tag type(string_t), intent(in) :: content integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call tag%write (u) write (u, "(A)", advance = "no") char (content) call tag%close (u) end subroutine xml_tag_write_with_content @ %def xml_tag_write_with_content @ Input from stream. We know what we are looking for, so we check if the name matches, then fill attributes. We report an error if (a) an I/O error occurs, (b) we reach EOF before encountering the tag, (c) if the tag is incomplete. Trailing text after reading a tag is put back to the input stream. We assume that the tag is not broken across records, and that there is only one tag within the record. This is more restricted than standard XML. <>= procedure :: read => xml_tag_read <>= module subroutine xml_tag_read (tag, cstream, success) class(xml_tag_t), intent(inout) :: tag type(cstream_t), intent(inout) :: cstream logical, intent(out) :: success end subroutine xml_tag_read <>= module subroutine xml_tag_read (tag, cstream, success) class(xml_tag_t), intent(inout) :: tag type(cstream_t), intent(inout) :: cstream logical, intent(out) :: success type(string_t) :: string integer :: iostat, p1, p2 character(2), parameter :: WS = BLANK // TAB logical :: done ! Skip comments and blank lines FIND_NON_COMMENT: do FIND_NONEMPTY_RECORD: do call cstream%get_record (string, iostat) if (iostat /= 0) call err_io () p1 = verify (string, WS) if (p1 > 0) exit FIND_NONEMPTY_RECORD end do FIND_NONEMPTY_RECORD ! Look for comment beginning p2 = p1 + 3 if (extract (string, p1, p2) /= "") then ! Return trailing text to the stream string = extract (string, p2 + 1) if (string /= "") call cstream%revert_record (string) exit FIND_COMMENT_END end if end do call cstream%get_record (string, iostat) if (iostat /= 0) call err_io () end do FIND_COMMENT_END end do FIND_NON_COMMENT ! Look for opening < p2 = p1 if (extract (string, p1, p2) /= "<") then call cstream%revert_record (string) success = .false.; return else ! Look for tag name string = extract (string, p2 + 1) p1 = verify (string, WS); if (p1 == 0) call err_incomplete () p2 = p1 + len (tag%name) - 1 if (extract (string, p1, p2) /= tag%name) then call cstream%revert_record ("<" // string) success = .false.; return else ! Look for attributes string = extract (string, p2 + 1) READ_ATTRIBUTES: do call tag%read_attribute (string, done) if (done) exit READ_ATTRIBUTES end do READ_ATTRIBUTES ! Look for closing > p1 = verify (string, WS); if (p1 == 0) call err_incomplete () p2 = p1 if (extract (string, p1, p1) == ">") then tag%has_content = .true. else ! Look for closing /> p2 = p1 + 1 if (extract (string, p1, p2) /= "/>") call err_incomplete () end if ! Return trailing text to the stream string = extract (string, p2 + 1) if (string /= "") call cstream%revert_record (string) success = .true. end if end if contains subroutine err_io () select case (iostat) case (:-1) call msg_fatal ("XML: Error reading tag '" // char (tag%name) & // "': end of file") case (1:) call msg_fatal ("XML: Error reading tag '" // char (tag%name) & // "': I/O error") end select success = .false. end subroutine err_io subroutine err_incomplete () call msg_fatal ("XML: Error reading tag '" // char (tag%name) & // "': tag incomplete") success = .false. end subroutine err_incomplete end subroutine xml_tag_read @ %def xml_tag_read @ Read a single attribute. If the attribute is valid, assign the value. Setting a value twice should be an error, but is not detected. If the attribute is unknown, ignore it. If we reach the closing sign, report this. <>= procedure :: read_attribute => xml_tag_read_attribute <>= module subroutine xml_tag_read_attribute (tag, string, done) class(xml_tag_t), intent(inout) :: tag type(string_t), intent(inout) :: string logical, intent(out) :: done end subroutine xml_tag_read_attribute <>= module subroutine xml_tag_read_attribute (tag, string, done) class(xml_tag_t), intent(inout) :: tag type(string_t), intent(inout) :: string logical, intent(out) :: done character(2), parameter :: WS = BLANK // TAB type(string_t) :: name, value integer :: p1, p2, i p1 = verify (string, WS); if (p1 == 0) call err () p2 = p1 ! Look for first terminating '>' or '/>' if (extract (string, p1, p2) == ">") then done = .true. else p2 = p1 + 1 if (extract (string, p1, p2) == "/>") then done = .true. else ! Look for '=' p2 = scan (string, '=') if (p2 == 0) call err () name = trim (extract (string, p1, p2 - 1)) ! Look for '"' string = extract (string, p2 + 1) p1 = verify (string, WS); if (p1 == 0) call err () p2 = p1 if (extract (string, p1, p2) /= '"') call err () ! Look for matching '"' and get value string = extract (string, p2 + 1) p1 = 1 p2 = scan (string, '"') if (p2 == 0) call err () value = extract (string, p1, p2 - 1) SCAN_KNOWN_ATTRIBUTES: do i = 1, size (tag%attribute) if (name == tag%attribute(i)%name) then call tag%attribute(i)%set_value (value) exit SCAN_KNOWN_ATTRIBUTES end if end do SCAN_KNOWN_ATTRIBUTES string = extract (string, p2 + 1) done = .false. end if end if contains subroutine err () call msg_fatal ("XML: Error reading attributes of '" // char (tag%name) & // "': syntax error") end subroutine err end subroutine xml_tag_read_attribute @ %def xml_tag_read_attribute @ Read the content string of a tag. We check for the appropriate closing tag and report it. If a closing tag does not match in name, ignore it. Note: this assumes that no tag with the same name is embedded in the current content. Also, we do not check for XML validity inside the content. <>= procedure :: read_content => xml_tag_read_content <>= module subroutine xml_tag_read_content (tag, cstream, content, closing) class(xml_tag_t), intent(in) :: tag type(cstream_t), intent(inout) :: cstream type(string_t), intent(out) :: content logical, intent(out) :: closing end subroutine xml_tag_read_content <>= module subroutine xml_tag_read_content (tag, cstream, content, closing) class(xml_tag_t), intent(in) :: tag type(cstream_t), intent(inout) :: cstream type(string_t), intent(out) :: content type(string_t) :: string logical, intent(out) :: closing integer :: iostat integer :: p0, p1, p2 character(2), parameter :: WS = BLANK // TAB call cstream%get_record (content, iostat) if (iostat /= 0) call err_io () closing = .false. FIND_CLOSING: do p0 = 1, len (content) - 1 ! Look for terminating string = extract (string, p2 + 1) p1 = verify (string, WS); if (p1 == 0) call err_incomplete () p2 = p1 if (extract (string, p1, p2) /= ">") call err_incomplete () ! Return trailing text to the stream string = extract (string, p2 + 1) if (string /= "") call cstream%revert_record (string) content = extract (content, 1, p0 -1) closing = .true. exit FIND_CLOSING end if end if end do FIND_CLOSING contains subroutine err_io () select case (iostat) case (:-1) call msg_fatal ("XML: Error reading content of '" // char (tag%name) & // "': end of file") case (1:) call msg_fatal ("XML: Error reading content of '" // char (tag%name) & // "': I/O error") end select closing = .false. end subroutine err_io subroutine err_incomplete () call msg_fatal ("XML: Error reading content '" // char (tag%name) & // "': closing tag incomplete") closing = .false. end subroutine err_incomplete end subroutine xml_tag_read_content @ %def xml_tag_read_content @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[xml_ut.f90]]>>= <> module xml_ut use unit_tests use xml_uti <> <> contains <> end module xml_ut @ %def xml_ut @ <<[[xml_uti.f90]]>>= <> module xml_uti <> use io_units use xml <> <> contains <> <> end module xml_uti @ %def xml_ut @ API: driver for the unit tests below. <>= public :: xml_test <>= subroutine xml_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine xml_test @ %def xml_test @ \subsection{Auxiliary Routines} Show the contents of a temporary file, i.e., open unit. <>= subroutine show (u_tmp, u) integer, intent(in) :: u_tmp, u character (80) :: buffer integer :: iostat write (u, "(A)") "File content:" rewind (u_tmp) do read (u_tmp, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do rewind (u_tmp) end subroutine show @ %def show @ \subsection{Basic Tag I/O} Write a tag and read it again, using a temporary file. <>= call test (xml_1, "xml_1", & "basic I/O", & u, results) <>= public :: xml_1 <>= subroutine xml_1 (u) integer, intent(in) :: u type(xml_tag_t), allocatable :: tag integer :: u_tmp type(cstream_t) :: cstream logical :: success write (u, "(A)") "* Test output: xml_1" write (u, "(A)") "* Purpose: write and read tag" write (u, "(A)") write (u, "(A)") "* Empty tag" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("tagname")) call tag%write (u_tmp) write (u_tmp, *) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname")) call tag%read (cstream, success) call tag%write (u) write (u, *) write (u, "(A,L1)") "success = ", success deallocate (tag) close (u_tmp) call cstream%final () write (u, *) write (u, "(A)") "* Tag with preceding blank lines" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("tagname")) write (u_tmp, *) write (u_tmp, "(A)") " " write (u_tmp, "(2x)", advance = "no") call tag%write (u_tmp) write (u_tmp, *) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname")) call tag%read (cstream, success) call tag%write (u) write (u, *) write (u, "(A,L1)") "success = ", success deallocate (tag) close (u_tmp) call cstream%final () write (u, *) write (u, "(A)") "* Tag with preceding comments" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("tagname")) write (u_tmp, "(A)") "" write (u_tmp, *) write (u_tmp, "(A)") "" call tag%write (u_tmp) write (u_tmp, *) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname")) call tag%read (cstream, success) call tag%write (u) write (u, *) write (u, "(A,L1)") "success = ", success close (u_tmp) deallocate (tag) call cstream%final () write (u, *) write (u, "(A)") "* Tag with name mismatch" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("wrongname")) call tag%write (u_tmp) write (u_tmp, *) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname")) call tag%read (cstream, success) call tag%write (u) write (u, *) write (u, "(A,L1)") "success = ", success deallocate (tag) close (u_tmp) call cstream%final () write (u, "(A)") write (u, "(A)") "* Test output end: xml_1" end subroutine xml_1 @ %def xml_1 @ \subsection{Optional Tag} Write and read two tags, one of them optional. <>= call test (xml_2, "xml_2", & "optional tag", & u, results) <>= public :: xml_2 <>= subroutine xml_2 (u) integer, intent(in) :: u type(xml_tag_t), allocatable :: tag1, tag2 integer :: u_tmp type(cstream_t) :: cstream logical :: success write (u, "(A)") "* Test output: xml_2" write (u, "(A)") "* Purpose: handle optional tag" write (u, "(A)") write (u, "(A)") "* Optional tag present" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag1) call tag1%init (var_str ("option")) call tag1%write (u_tmp) write (u_tmp, *) allocate (tag2) call tag2%init (var_str ("tagname")) call tag2%write (u_tmp) write (u_tmp, *) deallocate (tag1, tag2) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag1) call tag1%init (var_str ("option")) call tag1%read (cstream, success) call tag1%write (u) write (u, *) write (u, "(A,L1)") "success = ", success write (u, *) allocate (tag2) call tag2%init (var_str ("tagname")) call tag2%read (cstream, success) call tag2%write (u) write (u, *) write (u, "(A,L1)") "success = ", success deallocate (tag1, tag2) close (u_tmp) call cstream%final () write (u, *) write (u, "(A)") "* Optional tag absent" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag2) call tag2%init (var_str ("tagname")) call tag2%write (u_tmp) write (u_tmp, *) deallocate (tag2) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag1) call tag1%init (var_str ("option")) call tag1%read (cstream, success) call tag1%write (u) write (u, *) write (u, "(A,L1)") "success = ", success write (u, *) allocate (tag2) call tag2%init (var_str ("tagname")) call tag2%read (cstream, success) call tag2%write (u) write (u, *) write (u, "(A,L1)") "success = ", success deallocate (tag1, tag2) close (u_tmp) call cstream%final () write (u, "(A)") write (u, "(A)") "* Test output end: xml_2" end subroutine xml_2 @ %def xml_2 @ \subsection{Optional Tag} Write and read a tag with single-line content. <>= call test (xml_3, "xml_3", & "content", & u, results) <>= public :: xml_3 <>= subroutine xml_3 (u) integer, intent(in) :: u type(xml_tag_t), allocatable :: tag integer :: u_tmp type(cstream_t) :: cstream logical :: success, closing type(string_t) :: content write (u, "(A)") "* Test output: xml_3" write (u, "(A)") "* Purpose: handle tag with content" write (u, "(A)") write (u, "(A)") "* Tag without content" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("tagname")) call tag%write (u_tmp) write (u_tmp, *) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname")) call tag%read (cstream, success) call tag%write (u) write (u, *) write (u, "(A,L1)") "success = ", success write (u, "(A,L1)") "content = ", tag%has_content write (u, *) deallocate (tag) close (u_tmp) call cstream%final () write (u, "(A)") "* Tag with content" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("tagname"), has_content = .true.) call tag%write (var_str ("Content text"), u_tmp) write (u_tmp, *) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname")) call tag%read (cstream, success) call tag%read_content (cstream, content, closing) call tag%write (u) write (u, "(A)", advance = "no") char (content) call tag%close (u) write (u, *) write (u, "(A,L1)") "success = ", success write (u, "(A,L1)") "content = ", tag%has_content write (u, "(A,L1)") "closing = ", closing deallocate (tag) close (u_tmp) call cstream%final () write (u, *) write (u, "(A)") "* Tag with multiline content" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("tagname"), has_content = .true.) call tag%write (u_tmp) write (u_tmp, *) write (u_tmp, "(A)") "Line 1" write (u_tmp, "(A)") "Line 2" call tag%close (u_tmp) write (u_tmp, *) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname")) call tag%read (cstream, success) call tag%write (u) write (u, *) do call tag%read_content (cstream, content, closing) if (closing) exit write (u, "(A)") char (content) end do call tag%close (u) write (u, *) write (u, "(A,L1)") "success = ", success write (u, "(A,L1)") "content = ", tag%has_content deallocate (tag) close (u_tmp) call cstream%final () write (u, "(A)") write (u, "(A)") "* Test output end: xml_3" end subroutine xml_3 @ %def xml_3 @ \subsection{Basic Tag I/O} Write a tag and read it again, using a temporary file. <>= call test (xml_4, "xml_4", & "attributes", & u, results) <>= public :: xml_4 <>= subroutine xml_4 (u) integer, intent(in) :: u type(xml_tag_t), allocatable :: tag integer :: u_tmp type(cstream_t) :: cstream logical :: success write (u, "(A)") "* Test output: xml_4" write (u, "(A)") "* Purpose: handle tag with attributes" write (u, "(A)") write (u, "(A)") "* Tag with one mandatory and one optional attribute," write (u, "(A)") "* unknown attribute ignored" write (u, *) u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") allocate (tag) call tag%init (var_str ("tagname"), & [xml_attribute (var_str ("a1"), var_str ("foo")), & xml_attribute (var_str ("a3"), var_str ("gee"))]) call tag%write (u_tmp) deallocate (tag) call show (u_tmp, u) write (u, *) write (u, "(A)") "Result from read:" call cstream%init (u_tmp) allocate (tag) call tag%init (var_str ("tagname"), & [xml_attribute (var_str ("a1")), & xml_attribute (var_str ("a2"), var_str ("bar"))]) call tag%read (cstream, success) call tag%write (u) write (u, *) deallocate (tag) close (u_tmp) call cstream%final () write (u, "(A)") write (u, "(A)") "* Test output end: xml_4" end subroutine xml_4 @ %def xml_4 Index: trunk/src/system/system.nw =================================================================== --- trunk/src/system/system.nw (revision 8828) +++ trunk/src/system/system.nw (revision 8829) @@ -1,4831 +1,4831 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: system interfaces \chapter{System: Interfaces and Handlers} \includemodulegraph{system} Here, we collect modules that deal with the ``system'': operating-system interfaces, error handlers and diagnostics. \begin{description} \item[system\_defs] Constants relevant for the modules in this set. \item[diagnostics] Error and diagnostic message handling. Any messages and errors issued by WHIZARD functions are handled by the subroutines in this module, if possible. \item[os\_interface] Execute system calls, build and link external object files and libraries. \item[cputime] Timer data type and methods, for measuring performance. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Constants} The parameters here are used in various parts of the program, starting from the modules in the current chapter. Some of them may be modified if the need arises. <<[[system_defs.f90]]>>= <> module system_defs use, intrinsic :: iso_fortran_env, only: iostat_end, iostat_eor !NODEP! <> <> end module system_defs @ %def system_defs @ \subsection{Version} The version string is used for checking files. Note that the string length MUST NOT be changed, because reading binary files relies on it. <>= integer, parameter, public :: VERSION_STRLEN = 255 character(len=VERSION_STRLEN), parameter, public :: & & VERSION_STRING = "WHIZARD version <> (<>)" @ %def VERSION_STRLEN VERSION_STRING @ \subsection{Text Buffer} There is a hard limit on the line length which we should export. This buffer size is used both by the message handler, the lexer, and some further modules. <>= integer, parameter, public :: BUFFER_SIZE = 1000 @ %def BUFFER_SIZE @ \subsection{IOSTAT Codes} Defined in [[iso_fortran_env]], but we would like to use shorthands. <>= integer, parameter, public :: EOF = iostat_end, EOR = iostat_eor @ %def EOF EOR @ \subsection{Character Codes} Single-character constants. <>= character, parameter, public :: BLANK = ' ' character, parameter, public :: TAB = achar(9) character, parameter, public :: CR = achar(13) character, parameter, public :: LF = achar(10) character, parameter, public :: BACKSLASH = achar(92) @ %def BLANK TAB CR NL @ Character strings that indicate character classes. <>= character(*), parameter, public :: WHITESPACE_CHARS = BLANK// TAB // CR // LF character(*), parameter, public :: LCLETTERS = "abcdefghijklmnopqrstuvwxyz" character(*), parameter, public :: UCLETTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - character(*), parameter, public :: DIGITS = "0123456789" + character(*), parameter, public :: DIGIT_CHARS = "0123456789" -@ %def WHITESPACE_CHARS LCLETTERS UCLETTERS DIGITS +@ %def WHITESPACE_CHARS LCLETTERS UCLETTERS DIGIT_CHARS @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for sigaction} This implements calls to [[sigaction]] and the appropriate signal handlers in C. The functionality is needed for the [[diagnostics]] module. <<[[signal_interface.c]]>>= /* <> */ #include #include extern int wo_sigint; extern int wo_sigterm; extern int wo_sigxcpu; extern int wo_sigxfsz; static void wo_handler_sigint (int sig) { wo_sigint = sig; } static void wo_handler_sigterm (int sig) { wo_sigterm = sig; } static void wo_handler_sigxcpu (int sig) { wo_sigxcpu = sig; } static void wo_handler_sigxfsz (int sig) { wo_sigxfsz = sig; } int wo_mask_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigint; return sigaction(SIGINT, &sa, NULL); } int wo_mask_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigterm; return sigaction(SIGTERM, &sa, NULL); } int wo_mask_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxcpu; return sigaction(SIGXCPU, &sa, NULL); } int wo_mask_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxfsz; return sigaction(SIGXFSZ, &sa, NULL); } int wo_release_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGINT, &sa, NULL); } int wo_release_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGTERM, &sa, NULL); } int wo_release_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXCPU, &sa, NULL); } int wo_release_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXFSZ, &sa, NULL); } @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for printf} The [[printf]] family of functions is implemented in C with an undefined number of arguments. This is not supported by the [[bind(C)]] interface. We therefore write wrappers for the versions of [[sprintf]] that we will actually use. This is used by the [[formats]] module. <<[[sprintf_interface.c]]>>= /* <> */ #include int sprintf_none(char* str, const char* format) { return sprintf(str, format); } int sprintf_int(char* str, const char* format, int val) { return sprintf(str, format, val); } int sprintf_double(char* str, const char* format, double val) { return sprintf(str, format, val); } int sprintf_str(char* str, const char* format, const char* val) { return sprintf(str, format, val); } <>= interface function sprintf_none (str, fmt) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt end function sprintf_none end interface interface function sprintf_int (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt integer(c_int), value :: val end function sprintf_int end interface interface function sprintf_double (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt real(c_double), value :: val end function sprintf_double end interface interface function sprintf_str(str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt character(c_char), dimension(*), intent(in) :: val end function sprintf_str end interface @ %def sprintf_int sprintf_double sprintf_str @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Error, Message and Signal Handling} We are not so ambitious as to do proper exception handling in [[WHIZARD]], but at least it may be useful to have a common interface for diagnostics: Results, messages, warnings, and such. As module variables we keep a buffer where the current message may be written to and a level indicator which tells which messages should be written on screen and which ones should be skipped. Alternatively, a string may be directly supplied to the message routine: this overrides the buffer, avoiding the necessety of formatted I/O in trivial cases. <<[[diagnostics.f90]]>>= <> module diagnostics use, intrinsic :: iso_c_binding !NODEP! <> <> use system_defs, only: BUFFER_SIZE, MAX_ERRORS <> <> <> <> <> <> interface <> end interface end module diagnostics <> @ %def diagnostics @ <<[[diagnostics_sub.f90]]>>= <> submodule (diagnostics) diagnostics_s use, intrinsic :: iso_fortran_env, only: output_unit !NODEP! use system_dependencies <> use string_utils, only: str use io_units implicit none contains <> end submodule diagnostics_s @ %def diagnostics_s @ Diagnostics levels: <>= public :: RESULT, DEBUG, DEBUG2 <>= integer, parameter :: TERMINATE=-2, BUG=-1, FATAL=1, & ERROR=2, WARNING=3, MESSAGE=4, RESULT=5, & DEBUG=6, DEBUG2=7 @ %def FATAL ERROR WARNING MESSAGE RESULT DEBUG DEBUG2 Diagnostics areas: <>= public :: d_area <>= interface d_area module procedure d_area_of_string module procedure d_area_to_string end interface <>= module function d_area_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string end function d_area_of_string elemental module function d_area_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i end function d_area_to_string <>= module function d_area_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char (string)) case ("particles") i = D_PARTICLES case ("events") i = D_EVENTS case ("shower") i = D_SHOWER case ("model_features") i = D_MODEL_F case ("matching") i = D_MATCHING case ("transforms") i = D_TRANSFORMS case ("subtraction") i = D_SUBTRACTION case ("virtual") i = D_VIRTUAL case ("threshold") i = D_THRESHOLD case ("phasespace") i = D_PHASESPACE case ("mismatch") i = D_MISMATCH case ("me_methods") i = D_ME_METHODS case ("process_integration") i = D_PROCESS_INTEGRATION case ("tauola") i = D_TAUOLA case ("core") i = D_CORE case ("vamp2") i = D_VAMP2 case ("mpi") i = D_MPI case ("qft") i = D_QFT case ("beams") i = D_BEAMS case ("real") i = D_REAL case ("flavor") i = D_FLAVOR case ("all") i = D_ALL case default print "(A)", "Possible values for --debug are:" do i = 0, D_LAST print "(A)", char (' ' // d_area_to_string(i)) end do call msg_fatal ("Please use one of the listed areas") end select end function d_area_of_string elemental module function d_area_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (D_PARTICLES) string = "particles" case (D_EVENTS) string = "events" case (D_SHOWER) string = "shower" case (D_MODEL_F) string = "model_features" case (D_MATCHING) string = "matching" case (D_TRANSFORMS) string = "transforms" case (D_SUBTRACTION) string = "subtraction" case (D_VIRTUAL) string = "virtual" case (D_THRESHOLD) string = "threshold" case (D_PHASESPACE) string = "phasespace" case (D_MISMATCH) string = "mismatch" case (D_ME_METHODS) string = "me_methods" case (D_PROCESS_INTEGRATION) string = "process_integration" case (D_TAUOLA) string = "tauola" case (D_CORE) string = "core" case (D_VAMP2) string = "vamp2" case (D_MPI) string = "mpi" case (D_QFT) string = "qft" case (D_BEAMS) string = "beams" case (D_REAL) string = "real" case (D_FLAVOR) string = "flavor" case (D_ALL) string = "all" case default string = "undefined" end select end function d_area_to_string @ %def d_area @ <>= public :: D_PARTICLES, D_EVENTS, D_SHOWER, D_MODEL_F, & D_MATCHING, D_TRANSFORMS, D_SUBTRACTION, D_VIRTUAL, D_THRESHOLD, & D_PHASESPACE, D_MISMATCH, D_ME_METHODS, D_PROCESS_INTEGRATION, & D_TAUOLA, D_CORE, D_VAMP2, D_MPI, D_QFT, D_BEAMS, D_REAL, D_FLAVOR <>= integer, parameter :: D_ALL=0, D_PARTICLES=1, D_EVENTS=2, & D_SHOWER=3, D_MODEL_F=4, & D_MATCHING=5, D_TRANSFORMS=6, & D_SUBTRACTION=7, D_VIRTUAL=8, D_THRESHOLD=9, D_PHASESPACE=10, & D_MISMATCH=11, D_ME_METHODS=12, D_PROCESS_INTEGRATION=13, & D_TAUOLA=14, D_CORE=15, D_VAMP2 = 16, D_MPI = 17, D_QFT = 18, & D_BEAMS=19, D_REAL=20, D_FLAVOR=21, D_LAST=21 @ %def D_ALL D_PARTICLES D_EVENTS @ %def D_SHOWER D_MODEL_F D_MATCHING D_TRANSFORMS @ %def D_SUBTRACTION D_VIRTUAL D_THRESHOLD D_PHASESPACE @ %def D_MISMATCH D_ME_METHODS D_PROCESS_INTEGRATION @ %def D_TAUOLA D_CORE D_VAMP2 D_MPI D_QFT @ <>= public :: msg_level <>= integer, save, dimension(D_ALL:D_LAST) :: msg_level = RESULT @ %def msg_level @ <>= integer, parameter, public :: COL_UNDEFINED = -1 integer, parameter, public :: COL_GREY = 90, COL_PEACH = 91, COL_LIGHT_GREEN = 92, & COL_LIGHT_YELLOW = 93, COL_LIGHT_BLUE = 94, COL_PINK = 95, & COL_LIGHT_AQUA = 96, COL_PEARL_WHITE = 97, COL_BLACK = 30, & COL_RED = 31, COL_GREEN = 32, COL_YELLOW = 33, COL_BLUE = 34, & COL_PURPLE = 35, COL_AQUA = 36 @ %def COLORS @ <>= public :: set_debug_levels <>= module subroutine set_debug_levels (area_str) type(string_t), intent(in) :: area_str end subroutine set_debug_levels <>= module subroutine set_debug_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG else msg_level(area) = DEBUG end if end subroutine set_debug_levels @ %def set_debug_levels @ <>= public :: set_debug2_levels <>= module subroutine set_debug2_levels (area_str) type(string_t), intent(in) :: area_str end subroutine set_debug2_levels <>= module subroutine set_debug2_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG2 else msg_level(area) = DEBUG2 end if end subroutine set_debug2_levels @ %def set_debug2_levels @ <>= type :: terminal_color_t integer :: color = COL_UNDEFINED contains <> end type terminal_color_t @ %def terminal_color_t @ <>= public :: term_col <>= interface term_col module procedure term_col_int module procedure term_col_char end interface term_col @ %def term_col @ <>= module function term_col_int (col_int) result (color) type(terminal_color_t) :: color integer, intent(in) :: col_int end function term_col_int module function term_col_char (col_char) result (color) type(terminal_color_t) :: color character(len=*), intent(in) :: col_char end function term_col_char <>= module function term_col_int (col_int) result (color) type(terminal_color_t) :: color integer, intent(in) :: col_int color%color = col_int end function term_col_int module function term_col_char (col_char) result (color) type(terminal_color_t) :: color character(len=*), intent(in) :: col_char type(string_t) :: buf select case (col_char) case ('Grey') color%color = COL_GREY case ('Peach') color%color = COL_PEACH case ('Light Green') color%color = COL_LIGHT_GREEN case ('Light Yellow') color%color = COL_LIGHT_YELLOW case ('Light Blue') color%color = COL_LIGHT_BLUE case ('Pink') color%color = COL_PINK case ('Light Aqua') color%color = COL_LIGHT_AQUA case ('Pearl White') color%color = COL_PEARL_WHITE case ('Black') color%color = COL_BLACK case ('Red') color%color = COL_RED case ('Green') color%color = COL_GREEN case ('Yellow') color%color = COL_YELLOW case ('Blue') color%color = COL_BLUE case ('Purple') color%color = COL_PURPLE case ('Aqua') color%color = COL_AQUA case default buf = var_str ('Color ') // var_str (col_char) // var_str (' is not defined') call msg_warning (char (buf)) color%color = COL_UNDEFINED end select end function term_col_char @ %def term_col_int term_col_char @ Mask fatal errors so that are treated as normal errors. Useful for interactive mode. <>= public :: mask_fatal_errors <>= logical, save :: mask_fatal_errors = .false. @ %def mask_fatal_errors @ How to handle bugs and unmasked fatal errors. Either execute a normal stop statement, or call the C [[exit()]] function, or try to cause a program crash by dereferencing a null pointer. These procedures are appended to the [[diagnostics]] source code, but not as module procedures but as external procedures. This avoids a circular module dependency across source directories. <>= integer, parameter, public :: TERM_STOP = 0, TERM_EXIT = 1, TERM_CRASH = 2 @ %def TERM_STOP TERM_EXIT TERM_CRASH <>= public :: handle_fatal_errors <>= integer, save :: handle_fatal_errors = TERM_EXIT <>= subroutine fatal_force_crash () use diagnostics, only: handle_fatal_errors, TERM_CRASH !NODEP! implicit none handle_fatal_errors = TERM_CRASH end subroutine fatal_force_crash subroutine fatal_force_exit () use diagnostics, only: handle_fatal_errors, TERM_EXIT !NODEP! implicit none handle_fatal_errors = TERM_EXIT end subroutine fatal_force_exit subroutine fatal_force_stop () use diagnostics, only: handle_fatal_errors, TERM_STOP !NODEP! implicit none handle_fatal_errors = TERM_STOP end subroutine fatal_force_stop @ %def fatal_force_crash @ %def fatal_force_exit @ %def fatal_force_stop @ Keep track of errors. This might be used for exception handling, later. The counter is incremented only for screen messages, to avoid double counting. <>= public :: msg_count <>= integer, dimension(TERMINATE:WARNING), save :: msg_count = 0 @ %def msg_count @ Keep a list of all errors and warnings. Since we do not know the number of entries beforehand, we use a linked list. <>= type :: string_list character(len=BUFFER_SIZE) :: string type(string_list), pointer :: next end type string_list type :: string_list_pointer type(string_list), pointer :: first, last end type string_list_pointer @ %def string_list string_list_pointer <>= type(string_list_pointer), dimension(TERMINATE:WARNING), save :: & & msg_list = string_list_pointer (null(), null()) @ %def msg_list @ Create a format string indicating color @ Add the current message buffer contents to the internal list. <>= subroutine msg_add (level) integer, intent(in) :: level type(string_list), pointer :: message select case (level) case (TERMINATE:WARNING) allocate (message) message%string = msg_buffer nullify (message%next) if (.not.associated (msg_list(level)%first)) & & msg_list(level)%first => message if (associated (msg_list(level)%last)) & & msg_list(level)%last%next => message msg_list(level)%last => message msg_count(level) = msg_count(level) + 1 end select end subroutine msg_add @ %def msg_add @ Initialization: <>= public :: msg_list_clear <>= module subroutine msg_list_clear end subroutine msg_list_clear <>= module subroutine msg_list_clear integer :: level type(string_list), pointer :: message do level = TERMINATE, WARNING do while (associated (msg_list(level)%first)) message => msg_list(level)%first msg_list(level)%first => message%next deallocate (message) end do nullify (msg_list(level)%last) end do msg_count = 0 end subroutine msg_list_clear @ %def msg_list_clear @ Display the summary of errors and warnings (no need to count fatals\ldots) <>= public :: msg_summary <>= module subroutine msg_summary (unit) integer, intent(in), optional :: unit end subroutine msg_summary <>= module subroutine msg_summary (unit) integer, intent(in), optional :: unit call expect_summary (unit) 1 format (A,1x,I2,1x,A,I2,1x,A) if (msg_count(ERROR) > 0 .and. msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) else if (msg_count(ERROR) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and no warnings." call msg_message (unit=unit) else if (msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were no errors and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) end if end subroutine msg_summary @ %def msg_summary @ Print the list of all messages of a given level. <>= public :: msg_listing <>= module subroutine msg_listing (level, unit, prefix) integer, intent(in) :: level integer, intent(in), optional :: unit character(len=*), intent(in), optional :: prefix end subroutine msg_listing <>= module subroutine msg_listing (level, unit, prefix) integer, intent(in) :: level integer, intent(in), optional :: unit character(len=*), intent(in), optional :: prefix type(string_list), pointer :: message integer :: u u = given_output_unit (unit); if (u < 0) return if (present (unit)) u = unit message => msg_list(level)%first do while (associated (message)) if (present (prefix)) then write (u, "(A)") prefix // trim (message%string) else write (u, "(A)") trim (message%string) end if message => message%next end do flush (u) end subroutine msg_listing @ %def msg_listing @ The message buffer: <>= public :: msg_buffer <>= character(len=BUFFER_SIZE), save :: msg_buffer = " " @ %def msg_buffer @ After a message is issued, the buffer should be cleared: <>= subroutine buffer_clear msg_buffer = " " end subroutine buffer_clear @ %def buffer_clear <>= public :: create_col_string <>= module function create_col_string (color) result (col_string) type(string_t) :: col_string integer, intent(in) :: color end function create_col_string <>= module function create_col_string (color) result (col_string) type(string_t) :: col_string integer, intent(in) :: color character(2) :: buf write (buf, '(I2)') color col_string = var_str ("[") // var_str (buf) // var_str ("m") end function create_col_string @ %def create_col_string @ The generic handler for messages. If the unit is omitted (or $=6$), the message is written to standard output if the precedence if sufficiently high (as determined by the value of [[msg_level]]). If the string is omitted, the buffer is used. In any case, the buffer is cleared after printing. In accordance with FORTRAN custom, the first column in the output is left blank. For messages and warnings, an additional exclamation mark and a blank is prepended. Furthermore, each message is appended to the internal message list (without prepending anything). <>= subroutine message_print (level, string, str_arr, unit, logfile, area, color) integer, intent(in) :: level character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: str_arr integer, intent(in), optional :: unit logical, intent(in), optional :: logfile integer, intent(in), optional :: area integer, intent(in), optional :: color type(string_t) :: col_string, prep_string, aux_string, head_footer, app_string integer :: lu, i, ar logical :: severe, is_error ar = D_ALL; if (present (area)) ar = area severe = .false. head_footer = "******************************************************************************" aux_string = "" is_error = .false. app_string = "" select case (level) case (TERMINATE) prep_string = "" case (BUG) prep_string = "*** WHIZARD BUG: " aux_string = "*** " severe = .true. is_error = .true. case (FATAL) prep_string = "*** FATAL ERROR: " aux_string = "*** " severe = .true. is_error = .true. case (ERROR) prep_string = "*** ERROR: " aux_string = "*** " is_error = .true. case (WARNING) prep_string = "Warning: " case (MESSAGE) prep_string = "| " case (DEBUG, DEBUG2) prep_string = "D: " case default prep_string = "" end select if (present (color)) then if (color > COL_UNDEFINED) then col_string = create_col_string (color) prep_string = achar(27) // col_string // prep_string app_string = app_string // achar(27) // "[0m" end if end if if (present(string)) msg_buffer = string lu = log_unit if (present(unit)) then if (unit /= output_unit) then if (severe) write (unit, "(A)") char(head_footer) if (is_error) write (unit, "(A)") char(head_footer) write (unit, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (unit, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (unit, "(A)") char(head_footer) if (severe) write (unit, "(A)") char(head_footer) flush (unit) lu = -1 else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) if (unit == log_unit) lu = -1 end if else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) end if if (present (logfile)) then if (.not. logfile) lu = -1 end if if (logging .and. lu >= 0) then if (severe) write (lu, "(A)") char(head_footer) if (is_error) write (lu, "(A)") char(head_footer) write (lu, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (lu, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (lu, "(A)") char(head_footer) if (severe) write (lu, "(A)") char(head_footer) flush (lu) end if call msg_add (level) call buffer_clear end subroutine message_print @ %def message_print @ The number of non-fatal errors that we allow before stopping the program. We might trade this later for an adjustable number. <>= integer, parameter, public :: MAX_ERRORS = 10 @ %def MAX_ERRORS @ The specific handlers. In the case of fatal errors, bugs (failed assertions) and normal termination execution is stopped. For non-fatal errors a message is printed to standard output if no unit is given. Only if the number of [[MAX_ERRORS]] errors is reached, we abort the program. There are no further actions in the other cases, but this may change. <>= public :: msg_terminate public :: msg_bug, msg_fatal, msg_error, msg_warning public :: msg_message, msg_result <>= module subroutine msg_terminate (string, unit, quit_code) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string integer, intent(in), optional :: quit_code end subroutine msg_terminate module subroutine msg_bug (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_bug recursive module subroutine msg_fatal (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_fatal module subroutine msg_error (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_error module subroutine msg_warning (string, arr, unit, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr type(terminal_color_t), intent(in), optional :: color end subroutine msg_warning module subroutine msg_message (string, unit, arr, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color end subroutine msg_message module subroutine msg_result (string, arr, unit, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color end subroutine msg_result <>= module subroutine msg_terminate (string, unit, quit_code) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string integer, intent(in), optional :: quit_code integer(c_int) :: return_code call release_term_signals () if (present (quit_code)) then return_code = quit_code else return_code = 0 end if if (present (string)) & call message_print (MESSAGE, string, unit=unit) call msg_summary (unit) if (return_code == 0 .and. expect_failures /= 0) then return_code = 5 call message_print (MESSAGE, & "WHIZARD run finished with 'expect' failure(s).", unit=unit) else if (return_code == 7) then call message_print (MESSAGE, & "WHIZARD run finished with failed self-test.", unit=unit) else call message_print (MESSAGE, "WHIZARD run finished.", unit=unit) end if call message_print (0, & "|=============================================================================|", unit=unit) call logfile_final () call msg_list_clear () if (return_code /= 0) then call exit (return_code) else !!! Should implement WHIZARD exit code (currently only via C) call exit (0) end if end subroutine msg_terminate module subroutine msg_bug (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr call message_print (BUG, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (-1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end subroutine msg_bug recursive module subroutine msg_fatal (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr if (mask_fatal_errors) then call msg_error (string, arr, unit) else call message_print (FATAL, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end if end subroutine msg_fatal module subroutine msg_error (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr call message_print (ERROR, string, arr, unit) if (msg_count(ERROR) >= MAX_ERRORS) then mask_fatal_errors = .false. call msg_fatal (" Too many errors encountered.") else if (.not.present(unit) .and. .not.mask_fatal_errors) then call message_print (MESSAGE, " (WHIZARD run continues)") end if end subroutine msg_error module subroutine msg_warning (string, arr, unit, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = WARNING, string = string, & str_arr = arr, unit = unit, color = cl) end subroutine msg_warning module subroutine msg_message (string, unit, arr, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = MESSAGE, & string = string, str_arr = arr, unit = unit, & logfile = logfile, color = cl) end subroutine msg_message module subroutine msg_result (string, arr, unit, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = RESULT, string = string, & str_arr = arr, unit = unit, logfile = logfile, color = cl) end subroutine msg_result @ %def msg_warning msg_message msg_result @ Debugging aids. Print messages or values of various kinds. All versions ultimately call [[msg_debug_none]], which in turn uses [[message_print]]. Safeguard: force crash if a routine (i.e., a debugging routine below) is called while the master switch [[debug_on]] is unset. Such calls should always be hidden behind [[if (debug_on)]], since they can significantly slow down the program. <>= if (.not. debug_on) call msg_bug ("msg_debug called with debug_on=.false.") @ The [[debug_on]] flag is provided by the [[debug_master]] module, and we can assume that it is a compile-time parameter. <>= public :: msg_debug <>= interface msg_debug module procedure msg_debug_none module procedure msg_debug_logical module procedure msg_debug_integer module procedure msg_debug_real module procedure msg_debug_complex module procedure msg_debug_string end interface <>= module subroutine msg_debug_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_none module subroutine msg_debug_logical (area, string, value, color) logical, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_logical module subroutine msg_debug_integer (area, string, value, color) integer, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_integer module subroutine msg_debug_real (area, string, value, color) real(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_real module subroutine msg_debug_complex (area, string, value, color) complex(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_complex module subroutine msg_debug_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_string <>= module subroutine msg_debug_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug_none module subroutine msg_debug_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug_logical module subroutine msg_debug_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug_integer module subroutine msg_debug_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug_real module subroutine msg_debug_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug_complex module subroutine msg_debug_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug_active (area)) then call msg_debug_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug_string @ %def msg_debug <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug_active (area)) then write (buffer, *) value call msg_debug_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: msg_print_color <>= interface msg_print_color module procedure msg_print_color_none module procedure msg_print_color_logical module procedure msg_print_color_integer module procedure msg_print_color_real end interface <>= module subroutine msg_print_color_none (string, color) character(len=*), intent(in) :: string !!!type(terminal_color_t), intent(in) :: color integer, intent(in) :: color end subroutine msg_print_color_none module subroutine msg_print_color_logical (string, value, color) character(len=*), intent(in) :: string logical, intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_logical module subroutine msg_print_color_integer (string, value, color) character(len=*), intent(in) :: string integer, intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_integer module subroutine msg_print_color_real (string, value, color) character(len=*), intent(in) :: string real(default), intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_real <>= module subroutine msg_print_color_none (string, color) character(len=*), intent(in) :: string !!!type(terminal_color_t), intent(in) :: color integer, intent(in) :: color call message_print (0, string, color = color) end subroutine msg_print_color_none module subroutine msg_print_color_logical (string, value, color) character(len=*), intent(in) :: string logical, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_logical module subroutine msg_print_color_integer (string, value, color) character(len=*), intent(in) :: string integer, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_integer module subroutine msg_print_color_real (string, value, color) character(len=*), intent(in) :: string real(default), intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_real @ %def msg_print_color_none, msg_print_color_logical @ %def msg_print_color_integer, msg_print_color_real @ Secondary debugging aids which implement more fine-grained debugging. Again, there is a safeguard against calling anything while [[debug_on=.false.]]. <>= if (.not. debug_on) call msg_bug ("msg_debug2 called with debug_on=.false.") <>= public :: msg_debug2 <>= interface msg_debug2 module procedure msg_debug2_none module procedure msg_debug2_logical module procedure msg_debug2_integer module procedure msg_debug2_real module procedure msg_debug2_complex module procedure msg_debug2_string end interface <>= module subroutine msg_debug2_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_none module subroutine msg_debug2_logical (area, string, value, color) logical, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_logical module subroutine msg_debug2_integer (area, string, value, color) integer, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_integer module subroutine msg_debug2_real (area, string, value, color) real(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_real module subroutine msg_debug2_complex (area, string, value, color) complex(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_complex module subroutine msg_debug2_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_string <>= module subroutine msg_debug2_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug2_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG2, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug2_none module subroutine msg_debug2_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug2_logical module subroutine msg_debug2_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug2_integer module subroutine msg_debug2_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug2_real module subroutine msg_debug2_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug2_complex module subroutine msg_debug2_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug2_active (area)) then call msg_debug2_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug2_string @ %def msg_debug2 <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug2_active (area)) then write (buffer, *) value call msg_debug2_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: debug_active <>= elemental module function debug_active (area) result (active) logical :: active integer, intent(in) :: area end function debug_active <>= elemental module function debug_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG end function debug_active @ %def debug_active @ <>= public :: debug2_active <>= elemental module function debug2_active (area) result (active) logical :: active integer, intent(in) :: area end function debug2_active <>= elemental module function debug2_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG2 end function debug2_active @ %def debug2_active @ Show the progress of a loop in steps of 10 \%. Could be generalized to other step sizes with an optional argument. <>= public :: msg_show_progress <>= module subroutine msg_show_progress (i_call, n_calls) integer, intent(in) :: i_call, n_calls end subroutine msg_show_progress <>= module subroutine msg_show_progress (i_call, n_calls) integer, intent(in) :: i_call, n_calls real(default) :: progress integer, save :: next_check if (i_call == 1) next_check = 10 progress = (i_call * 100._default) / n_calls if (progress >= next_check) then write (msg_buffer, "(F5.1,A)") progress, "%" call msg_message () next_check = next_check + 10 end if end subroutine msg_show_progress @ %def msg_show_progress @ Interface to the standard clib exit function <>= public :: exit <>= interface subroutine exit (status) bind (C) use iso_c_binding !NODEP! integer(c_int), value :: status end subroutine exit end interface @ %def exit @ Print the WHIZARD banner: <>= public :: msg_banner <>= module subroutine msg_banner (unit) integer, intent(in), optional :: unit end subroutine msg_banner <>= module subroutine msg_banner (unit) integer, intent(in), optional :: unit call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WWWWW WWWW |", unit=unit) call message_print (0, "| WW WW WW WW WW WW WW WWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WWWWWWW WW WW WW WW WWWWW WW WW |", unit=unit) call message_print (0, "| WWWW WWWW WW WW WW WW WWWWWWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WW WW WW WWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| W |", unit=unit) call message_print (0, "| sW |", unit=unit) call message_print (0, "| WW |", unit=unit) call message_print (0, "| sWW |", unit=unit) call message_print (0, "| WWW |", unit=unit) call message_print (0, "| wWWW |", unit=unit) call message_print (0, "| wWWWW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wwwwww WW WW |", unit=unit) call message_print (0, "| WWWWWww WW WW |", unit=unit) call message_print (0, "| WWWWWwwwww WW WW |", unit=unit) call message_print (0, "| wWWWwwwwwWW WW |", unit=unit) call message_print (0, "| wWWWWWWWWWWwWWW WW |", unit=unit) call message_print (0, "| wWWWWW wW WWWWWWW |", unit=unit) call message_print (0, "| WWWW wW WW wWWWWWWWwww |", unit=unit) call message_print (0, "| WWWW wWWWWWWWwwww |", unit=unit) call message_print (0, "| WWWW WWWW WWw |", unit=unit) call message_print (0, "| WWWWww WWWW |", unit=unit) call message_print (0, "| WWWwwww WWWW |", unit=unit) call message_print (0, "| wWWWWwww wWWWWW |", unit=unit) call message_print (0, "| WwwwwwwwwWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| by: Wolfgang Kilian, Thorsten Ohl, Juergen Reuter |", unit=unit) call message_print (0, "| with contributions from Christian Speckner |", unit=unit) call message_print (0, "| Contact: |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| if you use WHIZARD please cite: |", unit=unit) call message_print (0, "| W. Kilian, T. Ohl, J. Reuter, Eur.Phys.J.C71 (2011) 1742 |", unit=unit) call message_print (0, "| [arXiv: 0708.4233 [hep-ph]] |", unit=unit) call message_print (0, "| M. Moretti, T. Ohl, J. Reuter, arXiv: hep-ph/0102195 |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| WHIZARD " // WHIZARD_VERSION, unit=unit) call message_print (0, "|=============================================================================|", unit=unit) end subroutine msg_banner @ %def msg_banner @ \subsection{Logfile} All screen output should be duplicated in the logfile, unless requested otherwise. <>= public :: logging <>= integer, save :: log_unit = -1 logical, target, save :: logging = .false. <>= public :: logfile_init <>= module subroutine logfile_init (filename) type(string_t), intent(in) :: filename end subroutine logfile_init <>= module subroutine logfile_init (filename) type(string_t), intent(in) :: filename call msg_message ("Writing log to '" // char (filename) // "'") if (.not. logging) call msg_message ("(Logging turned off.)") log_unit = free_unit () open (file = char (filename), unit = log_unit, & action = "write", status = "replace") end subroutine logfile_init @ %def logfile_init <>= public :: logfile_final <>= module subroutine logfile_final () end subroutine logfile_final <>= module subroutine logfile_final () if (log_unit >= 0) then close (log_unit) log_unit = -1 end if end subroutine logfile_final @ %def logfile_final @ This returns the valid logfile unit only if the default is write to screen, and if [[logfile]] is not set false. <>= public :: logfile_unit <>= module function logfile_unit (unit, logfile) integer :: logfile_unit integer, intent(in), optional :: unit logical, intent(in), optional :: logfile end function logfile_unit <>= module function logfile_unit (unit, logfile) integer :: logfile_unit integer, intent(in), optional :: unit logical, intent(in), optional :: logfile if (logging) then if (present (unit)) then if (unit == output_unit) then logfile_unit = log_unit else logfile_unit = -1 end if else if (present (logfile)) then if (logfile) then logfile_unit = log_unit else logfile_unit = -1 end if else logfile_unit = log_unit end if else logfile_unit = -1 end if end function logfile_unit @ %def logfile_unit @ \subsection{Checking values} The [[expect]] function does not just check a value for correctness (actually, it checks if a logical expression is true); it records its result here. If failures are present when the program terminates, the exit code is nonzero. <>= integer, save :: expect_total = 0 integer, save :: expect_failures = 0 @ %def expect_total expect_failures <>= public :: expect_record <>= module subroutine expect_record (success) logical, intent(in) :: success end subroutine expect_record <>= module subroutine expect_record (success) logical, intent(in) :: success expect_total = expect_total + 1 if (.not. success) expect_failures = expect_failures + 1 end subroutine expect_record @ %def expect_record <>= public :: expect_clear <>= module subroutine expect_clear () end subroutine expect_clear <>= module subroutine expect_clear () expect_total = 0 expect_failures = 0 end subroutine expect_clear @ %def expect_clear <>= public :: expect_summary <>= module subroutine expect_summary (unit, force) integer, intent(in), optional :: unit logical, intent(in), optional :: force end subroutine expect_summary <>= module subroutine expect_summary (unit, force) integer, intent(in), optional :: unit logical, intent(in), optional :: force logical :: force_output force_output = .false.; if (present (force)) force_output = force if (expect_total /= 0 .or. force_output) then call msg_message ("Summary of value checks:", unit) write (msg_buffer, "(2x,A,1x,I0,1x,A,1x,A,1x,I0)") & "Failures:", expect_failures, "/", "Total:", expect_total call msg_message (unit=unit) end if end subroutine expect_summary @ %def expect_summary @ Helpers for converting integers into strings with minimal length. <>= public :: int2string public :: int2char public :: int2fixed <>= pure module function int2fixed (i) result (c) integer, intent(in) :: i character(200) :: c end function int2fixed pure module function int2string (i) result (s) integer, intent(in) :: i type (string_t) :: s end function int2string pure module function int2char (i) result (c) integer, intent(in) :: i character(len (trim (int2fixed (i)))) :: c end function int2char <>= pure module function int2fixed (i) result (c) integer, intent(in) :: i character(200) :: c c = "" write (c, *) i c = adjustl (c) end function int2fixed pure module function int2string (i) result (s) integer, intent(in) :: i type (string_t) :: s s = trim (int2fixed (i)) end function int2string pure module function int2char (i) result (c) integer, intent(in) :: i character(len (trim (int2fixed (i)))) :: c c = int2fixed (i) end function int2char @ %def int2fixed int2string int2char @ Dito for reals. <>= public :: real2string public :: real2char public :: real2fixed <>= interface real2string module procedure real2string_list, real2string_fmt end interface interface real2char module procedure real2char_list, real2char_fmt end interface <>= pure module function real2fixed (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in), optional :: fmt character(200) :: c end function real2fixed pure module function real2fixed_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(200) :: c end function real2fixed_fmt pure module function real2string_list (x) result (s) real(default), intent(in) :: x type(string_t) :: s end function real2string_list pure module function real2string_fmt (x, fmt) result (s) real(default), intent(in) :: x character(*), intent(in) :: fmt type(string_t) :: s end function real2string_fmt pure module function real2char_list (x) result (c) real(default), intent(in) :: x character(len_trim (real2fixed (x))) :: c end function real2char_list pure module function real2char_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(len_trim (real2fixed_fmt (x, fmt))) :: c end function real2char_fmt <>= pure module function real2fixed (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in), optional :: fmt character(200) :: c c = "" write (c, *) x c = adjustl (c) end function real2fixed pure module function real2fixed_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(200) :: c c = "" write (c, fmt) x c = adjustl (c) end function real2fixed_fmt pure module function real2string_list (x) result (s) real(default), intent(in) :: x type(string_t) :: s s = trim (real2fixed (x)) end function real2string_list pure module function real2string_fmt (x, fmt) result (s) real(default), intent(in) :: x character(*), intent(in) :: fmt type(string_t) :: s s = trim (real2fixed_fmt (x, fmt)) end function real2string_fmt pure module function real2char_list (x) result (c) real(default), intent(in) :: x character(len_trim (real2fixed (x))) :: c c = real2fixed (x) end function real2char_list pure module function real2char_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(len_trim (real2fixed_fmt (x, fmt))) :: c c = real2fixed_fmt (x, fmt) end function real2char_fmt @ %def real2fixed real2string real2char @ Dito for complex values; we do not use the slightly ugly FORTRAN output form here but instead introduce our own. Ifort and Portland seem to have problems with this, therefore temporarily disable it. % <>= public :: cmplx2string public :: cmplx2char <>= pure function cmplx2string (x) result (s) complex(default), intent(in) :: x type(string_t) :: s s = real2string (real (x, default)) if (aimag (x) /= 0) s = s // " + " // real2string (aimag (x)) // " I" end function cmplx2string pure function cmplx2char (x) result (c) complex(default), intent(in) :: x character(len (char (cmplx2string (x)))) :: c c = char (cmplx2string (x)) end function cmplx2char @ %def cmplx2string cmplx2char @ \subsection{Signal handling} Killing the program by external signals may leave the files written by it in an undefined state. This can be avoided by catching signals and deferring program termination. Instead of masking only critical sections, we choose to mask signals globally (done in the main program) and terminate the program at predefined checkpoints only. Checkpoints are after each command, within the sampling function (so the program can be terminated after each event), and after each iteration in the phase-space generation algorithm. Signal handling is done via a C interface to the [[sigaction]] system call. When a signal is raised that has been masked by the handler, the corresponding variable is set to the value of the signal. The variables are visible from the C signal handler. The signal SIGINT is for keyboard interrupt (ctrl-C), SIGTERM is for system interrupt, e.g., at shutdown. The SIGXCPU and SIGXFSZ signals may be issued by batch systems. <>= public :: wo_sigint public :: wo_sigterm public :: wo_sigxcpu public :: wo_sigxfsz <>= integer(c_int), bind(C), volatile :: wo_sigint = 0 integer(c_int), bind(C), volatile :: wo_sigterm = 0 integer(c_int), bind(C), volatile :: wo_sigxcpu = 0 integer(c_int), bind(C), volatile :: wo_sigxfsz = 0 @ %def wo_sigint wo_sigterm wo_sigxcpu wo_sigxfsz @ Here are the interfaces to the C functions. The routine [[mask_term_signals]] forces termination signals to be delayed. [[release_term_signals]] restores normal behavior. However, the program can be terminated anytime by calling [[terminate_now_if_signal]] which inspects the signals and terminates the program if requested.. <>= public :: mask_term_signals <>= module subroutine mask_term_signals () end subroutine mask_term_signals <>= module subroutine mask_term_signals () logical :: ok wo_sigint = 0 ok = wo_mask_sigint () == 0 if (.not. ok) call msg_error ("Masking SIGINT failed") wo_sigterm = 0 ok = wo_mask_sigterm () == 0 if (.not. ok) call msg_error ("Masking SIGTERM failed") wo_sigxcpu = 0 ok = wo_mask_sigxcpu () == 0 if (.not. ok) call msg_error ("Masking SIGXCPU failed") wo_sigxfsz = 0 ok = wo_mask_sigxfsz () == 0 if (.not. ok) call msg_error ("Masking SIGXFSZ failed") end subroutine mask_term_signals @ %def mask_term_signals <>= interface integer(c_int) function wo_mask_sigint () bind(C) import end function wo_mask_sigint end interface interface integer(c_int) function wo_mask_sigterm () bind(C) import end function wo_mask_sigterm end interface interface integer(c_int) function wo_mask_sigxcpu () bind(C) import end function wo_mask_sigxcpu end interface interface integer(c_int) function wo_mask_sigxfsz () bind(C) import end function wo_mask_sigxfsz end interface @ %def wo_mask_sigint wo_mask_sigterm wo_mask_sigxcpu wo_mask_sigxfsz <>= public :: release_term_signals <>= module subroutine release_term_signals () end subroutine release_term_signals <>= module subroutine release_term_signals () logical :: ok ok = wo_release_sigint () == 0 if (.not. ok) call msg_error ("Releasing SIGINT failed") ok = wo_release_sigterm () == 0 if (.not. ok) call msg_error ("Releasing SIGTERM failed") ok = wo_release_sigxcpu () == 0 if (.not. ok) call msg_error ("Releasing SIGXCPU failed") ok = wo_release_sigxfsz () == 0 if (.not. ok) call msg_error ("Releasing SIGXFSZ failed") end subroutine release_term_signals @ %def release_term_signals <>= interface integer(c_int) function wo_release_sigint () bind(C) import end function wo_release_sigint end interface interface integer(c_int) function wo_release_sigterm () bind(C) import end function wo_release_sigterm end interface interface integer(c_int) function wo_release_sigxcpu () bind(C) import end function wo_release_sigxcpu end interface interface integer(c_int) function wo_release_sigxfsz () bind(C) import end function wo_release_sigxfsz end interface @ %def wo_release_sigint wo_release_sigterm @ %def wo_release_sigxcpu wo_release_sigxfsz <>= public :: signal_is_pending <>= module function signal_is_pending () result (flag) logical :: flag end function signal_is_pending <>= module function signal_is_pending () result (flag) logical :: flag flag = & wo_sigint /= 0 .or. & wo_sigterm /= 0 .or. & wo_sigxcpu /= 0 .or. & wo_sigxfsz /= 0 end function signal_is_pending @ %def signal_is_pending <>= public :: terminate_now_if_signal <>= module subroutine terminate_now_if_signal () end subroutine terminate_now_if_signal <>= module subroutine terminate_now_if_signal () if (wo_sigint /= 0) then call msg_terminate ("Signal SIGINT (keyboard interrupt) received.", & quit_code=int (wo_sigint)) else if (wo_sigterm /= 0) then call msg_terminate ("Signal SIGTERM (termination signal) received.", & quit_code=int (wo_sigterm)) else if (wo_sigxcpu /= 0) then call msg_terminate ("Signal SIGXCPU (CPU time limit exceeded) received.", & quit_code=int (wo_sigxcpu)) else if (wo_sigxfsz /= 0) then call msg_terminate ("Signal SIGXFSZ (file size limit exceeded) received.", & quit_code=int (wo_sigxfsz)) end if end subroutine terminate_now_if_signal @ %def terminate_now_if_signal @ <>= public :: single_event <>= logical :: single_event = .false. @ <>= public :: terminate_now_if_single_event <>= module subroutine terminate_now_if_single_event () end subroutine terminate_now_if_single_event <>= module subroutine terminate_now_if_single_event () integer, save :: n_calls = 0 n_calls = n_calls + 1 if (single_event .and. n_calls > 1) then call msg_terminate ("Stopping after one event", quit_code=0) end if end subroutine terminate_now_if_single_event @ %def terminate_now_if_single_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Operating-system interface} For specific purposes, we need direct access to the OS (system calls). This is, of course, system dependent. The current version is valid for GNU/Linux; we expect to use a preprocessor for this module if different OSs are to be supported. The current implementation lacks error handling. <<[[os_interface.f90]]>>= <> module os_interface use, intrinsic :: iso_c_binding !NODEP! <> <> <> <> <> interface <> end interface end module os_interface @ %def os_interface @ <<[[os_interface_sub.f90]]>>= <> submodule (os_interface) os_interface_s use system_defs, only: DLERROR_LEN, ENVVAR_LEN use io_units use diagnostics use system_dependencies <> implicit none contains <> end submodule os_interface_s @ %def os_interface_s @ \subsection{Path variables} This is a transparent container for storing user-defined path variables. <>= public :: paths_t <>= type :: paths_t type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: localprefix type(string_t) :: libtool type(string_t) :: lhapdfdir end type paths_t @ %def paths_t <>= public :: paths_init <>= module subroutine paths_init (paths) type(paths_t), intent(out) :: paths end subroutine paths_init <>= module subroutine paths_init (paths) type(paths_t), intent(out) :: paths paths%prefix = "" paths%exec_prefix = "" paths%bindir = "" paths%libdir = "" paths%includedir = "" paths%datarootdir = "" paths%localprefix = "" paths%libtool = "" paths%lhapdfdir = "" end subroutine paths_init @ %def paths_init @ \subsection{System dependencies} We store all potentially system- and user/run-dependent data in a transparent container. This includes compiler/linker names and flags, file extensions, etc. There are actually two different possibilities for extensions of shared libraries, depending on whether the Fortran compiler or the system linker (usually the C compiler) has been used for linking. The default for the Fortran compiler on most systems is [[.so]]. <>= public :: os_data_t <>= type :: os_data_t logical :: use_libtool logical :: use_testfiles type(string_t) :: fc type(string_t) :: fcflags type(string_t) :: fcflags_pic type(string_t) :: fclibs type(string_t) :: fc_src_ext type(string_t) :: cc type(string_t) :: cflags type(string_t) :: cflags_pic type(string_t) :: cxx type(string_t) :: cxxflags type(string_t) :: cxxlibs type(string_t) :: obj_ext type(string_t) :: ld type(string_t) :: ldflags type(string_t) :: ldflags_so type(string_t) :: ldflags_static type(string_t) :: ldflags_hepmc type(string_t) :: ldflags_lcio type(string_t) :: ldflags_hoppet type(string_t) :: ldflags_looptools type(string_t) :: shrlib_ext type(string_t) :: fc_shrlib_ext type(string_t) :: pack_cmd type(string_t) :: unpack_cmd type(string_t) :: pack_ext type(string_t) :: makeflags type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: whizard_omega_binpath type(string_t) :: whizard_includes type(string_t) :: whizard_ldflags type(string_t) :: whizard_libtool type(string_t) :: whizard_modelpath type(string_t) :: whizard_modelpath_ufo type(string_t) :: whizard_models_libpath type(string_t) :: whizard_susypath type(string_t) :: whizard_gmlpath type(string_t) :: whizard_cutspath type(string_t) :: whizard_texpath type(string_t) :: whizard_sharepath type(string_t) :: whizard_testdatapath type(string_t) :: whizard_modelpath_local type(string_t) :: whizard_models_libpath_local type(string_t) :: whizard_omega_binpath_local type(string_t) :: whizard_circe2path type(string_t) :: whizard_beamsimpath type(string_t) :: whizard_mulipath type(string_t) :: pdf_builtin_datapath logical :: event_analysis = .false. logical :: event_analysis_ps = .false. logical :: event_analysis_pdf = .false. type(string_t) :: latex type(string_t) :: mpost type(string_t) :: gml type(string_t) :: dvips type(string_t) :: ps2pdf type(string_t) :: gosampath type(string_t) :: golempath type(string_t) :: formpath type(string_t) :: qgrafpath type(string_t) :: ninjapath type(string_t) :: samuraipath contains <> end type os_data_t @ %def os_data_t @ Since all are allocatable strings, explicit initialization is necessary. <>= integer, parameter, public :: ENVVAR_LEN = 1000 @ %def ENVVAR_LEN <>= procedure :: init => os_data_init <>= module subroutine os_data_init (os_data, paths) class(os_data_t), intent(out) :: os_data type(paths_t), intent(in), optional :: paths end subroutine os_data_init <>= module subroutine os_data_init (os_data, paths) class(os_data_t), intent(out) :: os_data type(paths_t), intent(in), optional :: paths character(len=ENVVAR_LEN) :: home type(string_t) :: localprefix, local_includes os_data%use_libtool = .true. inquire (file = "TESTFLAG", exist = os_data%use_testfiles) call get_environment_variable ("HOME", home) if (present(paths)) then if (paths%localprefix == "") then localprefix = trim (home) // "/.whizard" else localprefix = paths%localprefix end if else localprefix = trim (home) // "/.whizard" end if local_includes = localprefix // "/lib/whizard/mod/models" os_data%whizard_modelpath_local = localprefix // "/share/whizard/models" os_data%whizard_models_libpath_local = localprefix // "/lib/whizard/models" os_data%whizard_omega_binpath_local = localprefix // "/bin" os_data%fc = DEFAULT_FC os_data%fcflags = DEFAULT_FCFLAGS os_data%fcflags_pic = DEFAULT_FCFLAGS_PIC os_data%fclibs = FCLIBS os_data%fc_src_ext = DEFAULT_FC_SRC_EXT os_data%cc = DEFAULT_CC os_data%cflags = DEFAULT_CFLAGS os_data%cflags_pic = DEFAULT_CFLAGS_PIC os_data%cxx = DEFAULT_CXX os_data%cxxflags = DEFAULT_CXXFLAGS os_data%cxxlibs = DEFAULT_CXXLIBS os_data%obj_ext = DEFAULT_OBJ_EXT os_data%ld = DEFAULT_LD os_data%ldflags = DEFAULT_LDFLAGS os_data%ldflags_so = DEFAULT_LDFLAGS_SO os_data%ldflags_static = DEFAULT_LDFLAGS_STATIC os_data%ldflags_hepmc = DEFAULT_LDFLAGS_HEPMC os_data%ldflags_lcio = DEFAULT_LDFLAGS_LCIO os_data%ldflags_hoppet = DEFAULT_LDFLAGS_HOPPET os_data%ldflags_looptools = DEFAULT_LDFLAGS_LOOPTOOLS os_data%shrlib_ext = DEFAULT_SHRLIB_EXT os_data%fc_shrlib_ext = DEFAULT_FC_SHRLIB_EXT os_data%pack_cmd = DEFAULT_PACK_CMD os_data%unpack_cmd = DEFAULT_UNPACK_CMD os_data%pack_ext = DEFAULT_PACK_EXT os_data%makeflags = DEFAULT_MAKEFLAGS os_data%prefix = PREFIX os_data%exec_prefix = EXEC_PREFIX os_data%bindir = BINDIR os_data%libdir = LIBDIR os_data%includedir = INCLUDEDIR os_data%datarootdir = DATAROOTDIR if (present (paths)) then if (paths%prefix /= "") os_data%prefix = paths%prefix if (paths%exec_prefix /= "") os_data%exec_prefix = paths%exec_prefix if (paths%bindir /= "") os_data%bindir = paths%bindir if (paths%libdir /= "") os_data%libdir = paths%libdir if (paths%includedir /= "") os_data%includedir = paths%includedir if (paths%datarootdir /= "") os_data%datarootdir = paths%datarootdir end if if (os_data%use_testfiles) then os_data%whizard_omega_binpath = WHIZARD_TEST_OMEGA_BINPATH os_data%whizard_includes = WHIZARD_TEST_INCLUDES os_data%whizard_ldflags = WHIZARD_TEST_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL_TEST os_data%whizard_modelpath = WHIZARD_TEST_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_TEST_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_TEST_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_TEST_SUSYPATH os_data%whizard_gmlpath = WHIZARD_TEST_GMLPATH os_data%whizard_cutspath = WHIZARD_TEST_CUTSPATH os_data%whizard_texpath = WHIZARD_TEST_TEXPATH os_data%whizard_sharepath = WHIZARD_TEST_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TEST_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_TEST_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_TEST_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_TEST_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_TEST_DATAPATH else if (os_dir_exist (local_includes)) then os_data%whizard_includes = "-I" // local_includes // " "// & WHIZARD_INCLUDES else os_data%whizard_includes = WHIZARD_INCLUDES end if os_data%whizard_omega_binpath = WHIZARD_OMEGA_BINPATH os_data%whizard_ldflags = WHIZARD_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL if(present(paths)) then if (paths%libtool /= "") os_data%whizard_libtool = paths%libtool end if os_data%whizard_modelpath = WHIZARD_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_SUSYPATH os_data%whizard_gmlpath = WHIZARD_GMLPATH os_data%whizard_cutspath = WHIZARD_CUTSPATH os_data%whizard_texpath = WHIZARD_TEXPATH os_data%whizard_sharepath = WHIZARD_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_DATAPATH end if os_data%event_analysis = EVENT_ANALYSIS == "yes" os_data%event_analysis_ps = EVENT_ANALYSIS_PS == "yes" os_data%event_analysis_pdf = EVENT_ANALYSIS_PDF == "yes" os_data%latex = PRG_LATEX // " " // OPT_LATEX os_data%mpost = PRG_MPOST // " " // OPT_MPOST if (os_data%use_testfiles) then os_data%gml = os_data%whizard_gmlpath // "/whizard-gml" // " " // & OPT_MPOST // " " // "--gmldir " // os_data%whizard_gmlpath else os_data%gml = os_data%bindir // "/whizard-gml" // " " // OPT_MPOST & // " " // "--gmldir " // os_data%whizard_gmlpath end if os_data%dvips = PRG_DVIPS os_data%ps2pdf = PRG_PS2PDF call os_data_expand_paths (os_data) os_data%gosampath = GOSAM_DIR os_data%golempath = GOLEM_DIR os_data%formpath = FORM_DIR os_data%qgrafpath = QGRAF_DIR os_data%ninjapath = NINJA_DIR os_data%samuraipath = SAMURAI_DIR end subroutine os_data_init @ %def os_data_init @ Replace occurences of GNU path variables (such as [[${prefix}]]) by their values. Do this for all strings that could depend on them, and do the replacement in reverse order, since the path variables may be defined in terms of each other. %% Fooling Noweb Emacs mode: $ <>= subroutine os_data_expand_paths (os_data) type(os_data_t), intent(inout) :: os_data integer, parameter :: N_VARIABLES = 6 type(string_t), dimension(N_VARIABLES) :: variable, value variable(1) = "${prefix}"; value(1) = os_data%prefix variable(2) = "${exec_prefix}"; value(2) = os_data%exec_prefix variable(3) = "${bindir}"; value(3) = os_data%bindir variable(4) = "${libdir}"; value(4) = os_data%libdir variable(5) = "${includedir}"; value(5) = os_data%includedir variable(6) = "${datarootdir}"; value(6) = os_data%datarootdir call expand_paths (os_data%whizard_omega_binpath) call expand_paths (os_data%whizard_includes) call expand_paths (os_data%whizard_ldflags) call expand_paths (os_data%whizard_libtool) call expand_paths (os_data%whizard_modelpath) call expand_paths (os_data%whizard_modelpath_ufo) call expand_paths (os_data%whizard_models_libpath) call expand_paths (os_data%whizard_susypath) call expand_paths (os_data%whizard_gmlpath) call expand_paths (os_data%whizard_cutspath) call expand_paths (os_data%whizard_texpath) call expand_paths (os_data%whizard_sharepath) call expand_paths (os_data%whizard_testdatapath) call expand_paths (os_data%whizard_circe2path) call expand_paths (os_data%whizard_beamsimpath) call expand_paths (os_data%whizard_mulipath) call expand_paths (os_data%whizard_models_libpath_local) call expand_paths (os_data%whizard_modelpath_local) call expand_paths (os_data%whizard_omega_binpath_local) call expand_paths (os_data%pdf_builtin_datapath) call expand_paths (os_data%latex) call expand_paths (os_data%mpost) call expand_paths (os_data%gml) call expand_paths (os_data%dvips) call expand_paths (os_data%ps2pdf) contains subroutine expand_paths (string) type(string_t), intent(inout) :: string integer :: i do i = N_VARIABLES, 1, -1 string = replace (string, variable(i), value(i), every=.true.) end do end subroutine expand_paths end subroutine os_data_expand_paths @ %def os_data_update_paths @ Write contents <>= procedure :: write => os_data_write <>= module subroutine os_data_write (os_data, unit) class(os_data_t), intent(in) :: os_data integer, intent(in), optional :: unit end subroutine os_data_write <>= module subroutine os_data_write (os_data, unit) class(os_data_t), intent(in) :: os_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "OS data:" write (u, *) "use_libtool = ", os_data%use_libtool write (u, *) "use_testfiles = ", os_data%use_testfiles write (u, *) "fc = ", char (os_data%fc) write (u, *) "fcflags = ", char (os_data%fcflags) write (u, *) "fcflags_pic = ", char (os_data%fcflags_pic) write (u, *) "fclibs = ", char (os_data%fclibs) write (u, *) "fc_src_ext = ", char (os_data%fc_src_ext) write (u, *) "cc = ", char (os_data%cc) write (u, *) "cflags = ", char (os_data%cflags) write (u, *) "cflags_pic = ", char (os_data%cflags_pic) write (u, *) "cxx = ", char (os_data%cxx) write (u, *) "cxxflags = ", char (os_data%cxxflags) write (u, *) "cxxlibs = ", char (os_data%cxxlibs) write (u, *) "obj_ext = ", char (os_data%obj_ext) write (u, *) "ld = ", char (os_data%ld) write (u, *) "ldflags = ", char (os_data%ldflags) write (u, *) "ldflags_so = ", char (os_data%ldflags_so) write (u, *) "ldflags_static = ", char (os_data%ldflags_static) write (u, *) "ldflags_hepmc = ", char (os_data%ldflags_hepmc) write (u, *) "ldflags_lcio = ", char (os_data%ldflags_lcio) write (u, *) "ldflags_hoppet = ", char (os_data%ldflags_hoppet) write (u, *) "ldflags_looptools = ", char (os_data%ldflags_looptools) write (u, *) "shrlib_ext = ", char (os_data%shrlib_ext) write (u, *) "fc_shrlib_ext = ", char (os_data%fc_shrlib_ext) write (u, *) "makeflags = ", char (os_data%makeflags) write (u, *) "prefix = ", char (os_data%prefix) write (u, *) "exec_prefix = ", char (os_data%exec_prefix) write (u, *) "bindir = ", char (os_data%bindir) write (u, *) "libdir = ", char (os_data%libdir) write (u, *) "includedir = ", char (os_data%includedir) write (u, *) "datarootdir = ", char (os_data%datarootdir) write (u, *) "whizard_omega_binpath = ", & char (os_data%whizard_omega_binpath) write (u, *) "whizard_includes = ", char (os_data%whizard_includes) write (u, *) "whizard_ldflags = ", char (os_data%whizard_ldflags) write (u, *) "whizard_libtool = ", char (os_data%whizard_libtool) write (u, *) "whizard_modelpath = ", & char (os_data%whizard_modelpath) write (u, *) "whizard_modelpath_ufo = ", & char (os_data%whizard_modelpath_ufo) write (u, *) "whizard_models_libpath = ", & char (os_data%whizard_models_libpath) write (u, *) "whizard_susypath = ", char (os_data%whizard_susypath) write (u, *) "whizard_gmlpath = ", char (os_data%whizard_gmlpath) write (u, *) "whizard_cutspath = ", char (os_data%whizard_cutspath) write (u, *) "whizard_texpath = ", char (os_data%whizard_texpath) write (u, *) "whizard_circe2path = ", char (os_data%whizard_circe2path) write (u, *) "whizard_beamsimpath = ", char (os_data%whizard_beamsimpath) write (u, *) "whizard_mulipath = ", char (os_data%whizard_mulipath) write (u, *) "whizard_sharepath = ", & char (os_data%whizard_sharepath) write (u, *) "whizard_testdatapath = ", & char (os_data%whizard_testdatapath) write (u, *) "whizard_modelpath_local = ", & char (os_data%whizard_modelpath_local) write (u, *) "whizard_models_libpath_local = ", & char (os_data%whizard_models_libpath_local) write (u, *) "whizard_omega_binpath_local = ", & char (os_data%whizard_omega_binpath_local) write (u, *) "event_analysis = ", os_data%event_analysis write (u, *) "event_analysis_ps = ", os_data%event_analysis_ps write (u, *) "event_analysis_pdf = ", os_data%event_analysis_pdf write (u, *) "latex = ", char (os_data%latex) write (u, *) "mpost = ", char (os_data%mpost) write (u, *) "gml = ", char (os_data%gml) write (u, *) "dvips = ", char (os_data%dvips) write (u, *) "ps2pdf = ", char (os_data%ps2pdf) if (os_data%gosampath /= "") then write (u, *) "gosam = ", char (os_data%gosampath) write (u, *) "golem = ", char (os_data%golempath) write (u, *) "form = ", char (os_data%formpath) write (u, *) "qgraf = ", char (os_data%qgrafpath) write (u, *) "ninja = ", char (os_data%ninjapath) write (u, *) "samurai = ", char (os_data%samuraipath) end if end subroutine os_data_write @ %def os_data_write @ <>= procedure :: build_latex_file => os_data_build_latex_file <>= module subroutine os_data_build_latex_file (os_data, filename, stat_out) class(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: filename integer, intent(out), optional :: stat_out end subroutine os_data_build_latex_file <>= module subroutine os_data_build_latex_file (os_data, filename, stat_out) class(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: filename integer, intent(out), optional :: stat_out type(string_t) :: setenv_tex, pipe, pipe_dvi integer :: unit_dev, status status = -1 if (os_data%event_analysis_ps) then !!! Check if our OS has a /dev/null unit_dev = free_unit () open (file = "/dev/null", unit = unit_dev, & action = "write", iostat = status) close (unit_dev) if (status /= 0) then pipe = "" pipe_dvi = "" else pipe = " > /dev/null" pipe_dvi = " 2>/dev/null 1>/dev/null" end if if (os_data%whizard_texpath /= "") then setenv_tex = "TEXINPUTS=" // & os_data%whizard_texpath // ":$TEXINPUTS " else setenv_tex = "" end if call os_system_call (setenv_tex // & os_data%latex // " " // filename // ".tex " // pipe, & verbose = .true., status = status) call os_system_call (os_data%dvips // " -o " // filename // & ".ps " // filename // ".dvi" // pipe_dvi, verbose = .true., & status = status) call os_system_call (os_data%ps2pdf // " " // filename // ".ps", & verbose = .true., status = status) end if if (present (stat_out)) stat_out = status end subroutine os_data_build_latex_file @ %def os_data_build_latex_file @ \subsection{Dynamic linking} We define a type that holds the filehandle for a dynamically linked library (shared object), together with functions to open and close the library, and to access functions in this library. <>= public :: dlaccess_t <>= type :: dlaccess_t private type(string_t) :: filename type(c_ptr) :: handle = c_null_ptr logical :: is_open = .false. logical :: has_error = .false. type(string_t) :: error contains <> end type dlaccess_t @ %def dlaccess_t @ Output. This is called by the output routine for the process library. <>= procedure :: write => dlaccess_write <>= module subroutine dlaccess_write (object, unit) class(dlaccess_t), intent(in) :: object integer, intent(in) :: unit end subroutine dlaccess_write <>= module subroutine dlaccess_write (object, unit) class(dlaccess_t), intent(in) :: object integer, intent(in) :: unit write (unit, "(1x,A)") "DL access info:" write (unit, "(3x,A,L1)") "is open = ", object%is_open if (object%has_error) then write (unit, "(3x,A,A,A)") "error = '", char (object%error), "'" else write (unit, "(3x,A)") "error = [none]" end if end subroutine dlaccess_write @ %def dlaccess_write @ The interface to the library functions: <>= interface function dlopen (filename, flag) result (handle) bind(C) import character(c_char), dimension(*) :: filename integer(c_int), value :: flag type(c_ptr) :: handle end function dlopen end interface interface function dlclose (handle) result (status) bind(C) import type(c_ptr), value :: handle integer(c_int) :: status end function dlclose end interface interface function dlerror () result (str) bind(C) import type(c_ptr) :: str end function dlerror end interface interface function dlsym (handle, symbol) result (fptr) bind(C) import type(c_ptr), value :: handle character(c_char), dimension(*) :: symbol type(c_funptr) :: fptr end function dlsym end interface @ %def dlopen dlclose dlsym @ This reads an error string and transforms it into a [[string_t]] object, if an error has occured. If not, set the error flag to false and return an empty string. <>= integer, parameter, public :: DLERROR_LEN = 160 <>= subroutine read_dlerror (has_error, error) logical, intent(out) :: has_error type(string_t), intent(out) :: error type(c_ptr) :: err_cptr character(len=DLERROR_LEN, kind=c_char), pointer :: err_fptr integer :: str_end err_cptr = dlerror () if (c_associated (err_cptr)) then call c_f_pointer (err_cptr, err_fptr) has_error = .true. str_end = scan (err_fptr, c_null_char) if (str_end > 0) then error = err_fptr(1:str_end-1) else error = err_fptr end if else has_error = .false. error = "" end if end subroutine read_dlerror @ %def read_dlerror @ This is the Fortran API. Init/final open and close the file, i.e., load and unload the library. Note that a library can be opened more than once, and that for an ultimate close as many [[dlclose]] calls as [[dlopen]] calls are necessary. However, we assume that it is opened and closed only once. <>= public :: dlaccess_init public :: dlaccess_final <>= procedure :: init => dlaccess_init procedure :: final => dlaccess_final <>= module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) class(dlaccess_t), intent(out) :: dlaccess type(string_t), intent(in) :: prefix, libname type(os_data_t), intent(in), optional :: os_data end subroutine dlaccess_init module subroutine dlaccess_final (dlaccess) class(dlaccess_t), intent(inout) :: dlaccess end subroutine dlaccess_final <>= module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) class(dlaccess_t), intent(out) :: dlaccess type(string_t), intent(in) :: prefix, libname type(os_data_t), intent(in), optional :: os_data type(string_t) :: filename logical :: exist dlaccess%filename = libname filename = prefix // "/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then filename = prefix // "/.libs/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then dlaccess%has_error = .true. dlaccess%error = "Library '" // filename // "' not found" return end if end if dlaccess%handle = dlopen (char (filename) // c_null_char, ior ( & RTLD_LAZY, RTLD_LOCAL)) dlaccess%is_open = c_associated (dlaccess%handle) call read_dlerror (dlaccess%has_error, dlaccess%error) end subroutine dlaccess_init module subroutine dlaccess_final (dlaccess) class(dlaccess_t), intent(inout) :: dlaccess integer(c_int) :: status if (dlaccess%is_open) then status = dlclose (dlaccess%handle) dlaccess%is_open = .false. call read_dlerror (dlaccess%has_error, dlaccess%error) end if end subroutine dlaccess_final @ %def dlaccess_init dlaccess_final @ Return true if an error has occured. <>= public :: dlaccess_has_error <>= module function dlaccess_has_error (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_has_error <>= module function dlaccess_has_error (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%has_error end function dlaccess_has_error @ %def dlaccess_has_error @ Return the error string currently stored in the [[dlaccess]] object. <>= public :: dlaccess_get_error <>= module function dlaccess_get_error (dlaccess) result (error) type(string_t) :: error type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_get_error <>= module function dlaccess_get_error (dlaccess) result (error) type(string_t) :: error type(dlaccess_t), intent(in) :: dlaccess error = dlaccess%error end function dlaccess_get_error @ %def dlaccess_get_error @ The symbol handler returns the C address of the function with the given string name. (It is a good idea to use [[bind(C)]] for all functions accessed by this, such that the name string is well-defined.) Call [[c_f_procpointer]] to cast this into a Fortran procedure pointer with an appropriate interface. <>= public :: dlaccess_get_c_funptr <>= module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) type(c_funptr) :: fptr type(dlaccess_t), intent(inout) :: dlaccess type(string_t), intent(in) :: fname end function dlaccess_get_c_funptr <>= module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) type(c_funptr) :: fptr type(dlaccess_t), intent(inout) :: dlaccess type(string_t), intent(in) :: fname fptr = dlsym (dlaccess%handle, char (fname) // c_null_char) call read_dlerror (dlaccess%has_error, dlaccess%error) end function dlaccess_get_c_funptr @ %def dlaccess_get_c_funptr @ \subsection{Predicates} Return true if the library is loaded. In particular, this is false if loading was unsuccessful. <>= public :: dlaccess_is_open <>= module function dlaccess_is_open (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_is_open <>= module function dlaccess_is_open (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%is_open end function dlaccess_is_open @ %def dlaccess_is_open @ \subsection{Shell access} This is the standard system call for executing a shell command, such as invoking a compiler. In F2008 there will be the equivalent built-in command [[execute_command_line]]. <>= public :: os_system_call <>= module subroutine os_system_call (command_string, status, verbose) type(string_t), intent(in) :: command_string integer, intent(out), optional :: status logical, intent(in), optional :: verbose end subroutine os_system_call <>= module subroutine os_system_call (command_string, status, verbose) type(string_t), intent(in) :: command_string integer, intent(out), optional :: status logical, intent(in), optional :: verbose logical :: verb integer :: stat verb = .false.; if (present (verbose)) verb = verbose if (verb) & call msg_message ("command: " // char (command_string)) stat = system (char (command_string) // c_null_char) if (present (status)) then status = stat else if (stat /= 0) then if (.not. verb) & call msg_message ("command: " // char (command_string)) write (msg_buffer, "(A,I0)") "Return code = ", stat call msg_message () call msg_fatal ("System command returned with nonzero status code") end if end subroutine os_system_call @ %def os_system_call <>= interface function system (command) result (status) bind(C) import integer(c_int) :: status character(c_char), dimension(*) :: command end function system end interface @ %def system @ \subsection{Querying for a directory} This queries for the existence of a directory. There is no standard way to achieve this in FORTRAN, and if we were to call into [[libc]], we would need access to C macros for evaluating the result, so we resort to calling [[test]] as a system call. <>= public :: os_dir_exist <>= module function os_dir_exist (name) result (res) type(string_t), intent(in) :: name logical :: res end function os_dir_exist <>= module function os_dir_exist (name) result (res) type(string_t), intent(in) :: name logical :: res integer :: status call os_system_call ('test -d "' // name // '"', status=status) res = status == 0 end function os_dir_exist @ %def os_dir_exist @ <>= public :: os_file_exist <>= module function os_file_exist (name) result (exist) type(string_t), intent(in) :: name logical :: exist end function os_file_exist <>= module function os_file_exist (name) result (exist) type(string_t), intent(in) :: name logical :: exist inquire (file = char (name), exist=exist) end function os_file_exist @ %def os_file_exist @ \subsection{Pack/unpack} The argument to [[pack]] may be a file or a directory. The name of the packed file will get the [[pack_ext]] extension appended. The argument to [[unpack]] must be a file, with the extension already included in the file name. <>= public :: os_pack_file public :: os_unpack_file <>= module subroutine os_pack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_pack_file module subroutine os_unpack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_unpack_file <>= module subroutine os_pack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%pack_cmd // " " & // file // os_data%pack_ext // " " // file call os_system_call (command_string, status) end subroutine os_pack_file module subroutine os_unpack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%unpack_cmd // " " // file call os_system_call (command_string, status) end subroutine os_unpack_file @ %def os_pack_file @ %def os_unpack_file @ \subsection{Fortran compiler and linker} Compile a single module for use in a shared library, but without linking. <>= public :: os_compile_shared <>= module subroutine os_compile_shared (src, os_data, status) type(string_t), intent(in) :: src type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_compile_shared <>= module subroutine os_compile_shared (src, os_data, status) type(string_t), intent(in) :: src type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=compile " // & os_data%fc // " " // & "-c " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" else command_string = & os_data%fc // " " // & "-c " // & os_data%fcflags_pic // " " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" end if call os_system_call (command_string, status) end subroutine os_compile_shared @ %def os_compile_shared @ Link an array of object files to build a shared object library. In the libtool case, we have to specify a [[-rpath]], otherwise only a static library can be built. However, since the library is never installed, this rpath is irrelevant. <>= public :: os_link_shared <>= module subroutine os_link_shared (objlist, lib, os_data, status) type(string_t), intent(in) :: objlist, lib type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_link_shared <>= module subroutine os_link_shared (objlist, lib, os_data, status) type(string_t), intent(in) :: objlist, lib type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-module " // & "-rpath /usr/local/lib" // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // ".la' " // & objlist else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // "." // os_data%fc_shrlib_ext // "' " // & objlist end if call os_system_call (command_string, status) end subroutine os_link_shared @ %def os_link_shared @ Link an array of object files / libraries to build a static executable. <>= public :: os_link_static <>= module subroutine os_link_static (objlist, exec_name, os_data, status) type(string_t), intent(in) :: objlist, exec_name type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_link_static <>= module subroutine os_link_static (objlist, exec_name, os_data, status) type(string_t), intent(in) :: objlist, exec_name type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-static " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools end if call os_system_call (command_string, status) end subroutine os_link_static @ %def os_link_static @ Determine the name of the shared library to link. If libtool is used, this is encoded in the [[.la]] file which resides in place of the library itself. <>= public :: os_get_dlname <>= module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) type(string_t) :: dlname type(string_t), intent(in) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: ignore, silent end function os_get_dlname <>= module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) type(string_t) :: dlname type(string_t), intent(in) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: ignore, silent type(string_t) :: filename type(string_t) :: buffer logical :: exist, required, quiet integer :: u u = free_unit () if (present (ignore)) then required = .not. ignore else required = .true. end if if (present (silent)) then quiet = silent else quiet = .false. end if if (os_data%use_libtool) then filename = lib // ".la" inquire (file=char(filename), exist=exist) if (exist) then open (unit=u, file=char(filename), action="read", status="old") SCAN_LTFILE: do call get (u, buffer) if (extract (buffer, 1, 7) == "dlname=") then dlname = extract (buffer, 9) dlname = remove (dlname, len (dlname)) exit SCAN_LTFILE end if end do SCAN_LTFILE close (u) else if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "': libtool archive not found") dlname = "" else if (.not. quiet) call msg_message ("[No compiled library '" & // char (lib) // "']") dlname = "" end if else dlname = lib // "." // os_data%fc_shrlib_ext inquire (file=char(dlname), exist=exist) if (.not. exist) then if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "' not found") else if (.not. quiet) call msg_message & ("[No compiled process library '" // char (lib) // "']") dlname = "" end if end if end if end function os_get_dlname @ %def os_get_dlname @ \subsection{Controlling OpenMP} OpenMP is handled automatically by the library for the most part. Here is a convenience routine for setting the number of threads, with some diagnostics. <>= public :: openmp_set_num_threads_verbose <>= module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) integer, intent(in) :: num_threads logical, intent(in), optional :: openmp_logging end subroutine openmp_set_num_threads_verbose <>= module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) integer, intent(in) :: num_threads integer :: n_threads logical, intent(in), optional :: openmp_logging logical :: logging if (present (openmp_logging)) then logging = openmp_logging else logging = .true. end if n_threads = num_threads if (openmp_is_active ()) then if (num_threads == 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " thread" call msg_message end if n_threads = num_threads else if (num_threads > 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " threads" call msg_message end if n_threads = num_threads else if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: " & // "Illegal value of openmp_num_threads (", num_threads, & ") ignored" call msg_error end if n_threads = openmp_get_default_max_threads () if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", & n_threads, " threads" call msg_message end if end if if (n_threads > openmp_get_default_max_threads ()) then if (logging) then write (msg_buffer, "(A,I0)") "OpenMP: " & // "Number of threads is greater than library default of ", & openmp_get_default_max_threads () call msg_warning end if end if call openmp_set_num_threads (n_threads) else if (num_threads /= 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "openmp_num_threads set to ", & num_threads, ", but OpenMP is not active: ignored" call msg_warning end if end if end subroutine openmp_set_num_threads_verbose @ %def openmp_set_num_threads_verbose @ \subsection{Controlling MPI} The overall MPI handling has to be defined in a context specific way, but we can simplify things like logging or receiving [[n_size]] or [[rank]]. <>= public :: mpi_set_logging <>= module subroutine mpi_set_logging (mpi_logging) logical, intent(in) :: mpi_logging end subroutine mpi_set_logging <>= module subroutine mpi_set_logging (mpi_logging) logical, intent(in) :: mpi_logging integer :: n_size, rank call mpi_get_comm_id (n_size, rank) if (mpi_logging .and. n_size > 1) then write (msg_buffer, "(A,I0,A)") "MPI: Using ", n_size, " processes." call msg_message () if (rank == 0) then call msg_message ("MPI: master worker") else write (msg_buffer, "(A,I0)") "MPI: slave worker #", rank call msg_message () end if end if end subroutine mpi_set_logging @ %def mpi_set_logging @ Receive communicator size and rank inside communicator. The subroutine is a stub, if not compiled with [[MPI]]. <>= public :: mpi_get_comm_id <>= module subroutine mpi_get_comm_id (n_size, rank) integer, intent(out) :: n_size integer, intent(out) :: rank end subroutine mpi_get_comm_id <>= module subroutine mpi_get_comm_id (n_size, rank) integer, intent(out) :: n_size integer, intent(out) :: rank n_size = 1 rank = 0 <> end subroutine mpi_get_comm_id @ %def mpi_get_comm_id <>= @ <>= call MPI_Comm_size (MPI_COMM_WORLD, n_size) call MPI_Comm_rank (MPI_COMM_WORLD, rank) @ <>= public :: mpi_is_comm_master <>= module function mpi_is_comm_master () result (flag) logical :: flag end function mpi_is_comm_master <>= module function mpi_is_comm_master () result (flag) integer :: n_size, rank logical :: flag call mpi_get_comm_id (n_size, rank) flag = (rank == 0) end function mpi_is_comm_master @ %def mpi_is_comm_master @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[os_interface_ut.f90]]>>= <> module os_interface_ut use unit_tests use os_interface_uti <> <> contains <> end module os_interface_ut @ %def os_interface_ut @ <<[[os_interface_uti.f90]]>>= <> module os_interface_uti use, intrinsic :: iso_c_binding !NODEP! <> use io_units use os_interface <> <> contains <> end module os_interface_uti @ %def os_interface_ut @ API: driver for the unit tests below. <>= public :: os_interface_test <>= subroutine os_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine os_interface_test @ %def os_interface_test @ Write a Fortran source file, compile it to a shared library, load it, and execute the contained function. <>= call test (os_interface_1, "os_interface_1", & "check OS interface routines", & u, results) <>= public :: os_interface_1 <>= subroutine os_interface_1 (u) integer, intent(in) :: u type(dlaccess_t) :: dlaccess type(string_t) :: fname, libname, ext type(os_data_t) :: os_data type(string_t) :: filename_src, filename_obj abstract interface function so_test_proc (i) result (j) bind(C) import c_int integer(c_int), intent(in) :: i integer(c_int) :: j end function so_test_proc end interface procedure(so_test_proc), pointer :: so_test => null () type(c_funptr) :: c_fptr integer :: unit integer(c_int) :: i call os_data%init () fname = "so_test" filename_src = fname // os_data%fc_src_ext if (os_data%use_libtool) then ext = ".lo" else ext = os_data%obj_ext end if filename_obj = fname // ext libname = fname // '.' // os_data%fc_shrlib_ext write (u, "(A)") "* Test output: OS interface" write (u, "(A)") "* Purpose: check os_interface routines" write (u, "(A)") write (u, "(A)") "* write source file 'so_test.f90'" write (u, "(A)") unit = free_unit () open (unit=unit, file=char(filename_src), action="write") write (unit, "(A)") "function so_test (i) result (j) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " integer(c_int) :: j" write (unit, "(A)") " j = 2 * i" write (unit, "(A)") "end function so_test" close (unit) write (u, "(A)") "* compile and link as 'so_test.so/dylib'" write (u, "(A)") call os_compile_shared (fname, os_data) call os_link_shared (filename_obj, fname, os_data) write (u, "(A)") "* load library 'so_test.so/dylib'" write (u, "(A)") call dlaccess_init (dlaccess, var_str ("."), libname, os_data) if (dlaccess_is_open (dlaccess)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if write (u, "(A)") "* load symbol 'so_test'" write (u, "(A)") c_fptr = dlaccess_get_c_funptr (dlaccess, fname) if (c_associated (c_fptr)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if call c_f_procpointer (c_fptr, so_test) write (u, "(A)") "* Execute function from 'so_test.so/dylib'" i = 7 write (u, "(A,1x,I1)") " input = ", i write (u, "(A,1x,I1)") " result = ", so_test(i) if (so_test(i) / i .ne. 2) then write (u, "(A)") "* Compiling and linking ISO C functions failed." else write (u, "(A)") "* Successful." end if write (u, "(A)") write (u, "(A)") "* Cleanup" call dlaccess_final (dlaccess) end subroutine os_interface_1 @ %def os_interface_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interface for formatted I/O} For access to formatted printing (possibly input), we interface the C [[printf]] family of functions. There are two important issues here: \begin{enumerate} \item [[printf]] takes an arbitrary number of arguments, relying on the C stack. This is not interoperable. We interface it with C wrappers that output a single integer, real or string and restrict the allowed formats accordingly. \item Restricting format strings is essential also for preventing format string attacks. Allowing arbitrary format string would create a real security hole in a Fortran program. \item The string returned by [[sprintf]] must be allocated to the right size. \end{enumerate} <<[[formats.f90]]>>= <> module formats use, intrinsic :: iso_c_binding <> <> <> <> <> <> <> interface <> end interface end module formats @ %def formats @ <<[[formats_sub.f90]]>>= <> submodule (formats) formats_s use io_units use diagnostics implicit none contains <> end submodule formats_s @ %def formats_s @ \subsection{Parsing a C format string} The C format string contains characters and format conversion specifications. The latter are initiated by a [[%]] sign. If the next letter is also a [[%]], a percent sign is printed and no conversion is done. Otherwise, a conversion is done and applied to the next argument in the argument list. First comes an optional flag ([[#]], [[0]], [[-]], [[+]], or space), an optional field width (decimal digits starting not with zero), an optional precision (period, then another decimal digit string), a length modifier (irrelevant for us, therefore not supported), and a conversion specifier: [[d]] or [[i]] for integer; [[e]], [[f]], [[g]] (also upper case) for double-precision real, [[s]] for a string. We explicitly exclude all other conversion specifiers, and we check the specifiers against the actual arguments. \subsubsection{A type for passing arguments} This is a polymorphic type that can hold integer, real (double), and string arguments. <>= integer, parameter, public :: ARGTYPE_NONE = 0 integer, parameter, public :: ARGTYPE_LOG = 1 integer, parameter, public :: ARGTYPE_INT = 2 integer, parameter, public :: ARGTYPE_REAL = 3 integer, parameter, public :: ARGTYPE_STR = 4 @ %def ARGTYPE_NONE ARGTYPE_LOG ARGTYPE_INT ARGTYPE_REAL ARGTYPE_STRING @ The integer and real entries are actually scalars, but we avoid relying on the allocatable-scalar feature and make them one-entry arrays. The character entry is a real array which is a copy of the string. Logical values are mapped to strings (true or false), so this type parameter value is mostly unused. <>= public :: sprintf_arg_t <>= type :: sprintf_arg_t private integer :: type = ARGTYPE_NONE integer(c_int), dimension(:), allocatable :: ival real(c_double), dimension(:), allocatable :: rval character(c_char), dimension(:), allocatable :: sval end type sprintf_arg_t @ %def sprintf_arg_t <>= public :: sprintf_arg_init <>= interface sprintf_arg_init module procedure sprintf_arg_init_log module procedure sprintf_arg_init_int module procedure sprintf_arg_init_real module procedure sprintf_arg_init_str end interface <>= module subroutine sprintf_arg_init_log (arg, lval) type(sprintf_arg_t), intent(out) :: arg logical, intent(in) :: lval end subroutine sprintf_arg_init_log module subroutine sprintf_arg_init_int (arg, ival) type(sprintf_arg_t), intent(out) :: arg integer, intent(in) :: ival end subroutine sprintf_arg_init_int module subroutine sprintf_arg_init_real (arg, rval) type(sprintf_arg_t), intent(out) :: arg real(default), intent(in) :: rval end subroutine sprintf_arg_init_real module subroutine sprintf_arg_init_str (arg, sval) type(sprintf_arg_t), intent(out) :: arg type(string_t), intent(in) :: sval end subroutine sprintf_arg_init_str <>= module subroutine sprintf_arg_init_log (arg, lval) type(sprintf_arg_t), intent(out) :: arg logical, intent(in) :: lval arg%type = ARGTYPE_STR if (lval) then allocate (arg%sval (5)) arg%sval = ['t', 'r', 'u', 'e', c_null_char] else allocate (arg%sval (6)) arg%sval = ['f', 'a', 'l', 's', 'e', c_null_char] end if end subroutine sprintf_arg_init_log module subroutine sprintf_arg_init_int (arg, ival) type(sprintf_arg_t), intent(out) :: arg integer, intent(in) :: ival arg%type = ARGTYPE_INT allocate (arg%ival (1)) arg%ival = ival end subroutine sprintf_arg_init_int module subroutine sprintf_arg_init_real (arg, rval) type(sprintf_arg_t), intent(out) :: arg real(default), intent(in) :: rval arg%type = ARGTYPE_REAL allocate (arg%rval (1)) arg%rval = rval end subroutine sprintf_arg_init_real module subroutine sprintf_arg_init_str (arg, sval) type(sprintf_arg_t), intent(out) :: arg type(string_t), intent(in) :: sval integer :: i arg%type = ARGTYPE_STR allocate (arg%sval (len (sval) + 1)) do i = 1, len (sval) arg%sval(i) = extract (sval, i, i) end do arg%sval(len (sval) + 1) = c_null_char end subroutine sprintf_arg_init_str @ %def sprintf_arg_init <>= subroutine sprintf_arg_write (arg, unit) type(sprintf_arg_t), intent(in) :: arg integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) select case (arg%type) case (ARGTYPE_NONE) write (u, *) "[none]" case (ARGTYPE_INT) write (u, "(1x,A,1x)", advance = "no") "[int]" write (u, *) arg%ival case (ARGTYPE_REAL) write (u, "(1x,A,1x)", advance = "no") "[real]" write (u, *) arg%rval case (ARGTYPE_STR) write (u, "(1x,A,1x,A)", advance = "no") "[string]", '"' write (u, *) arg%rval, '"' end select end subroutine sprintf_arg_write @ %def sprintf_arg_write @ Return an upper bound for the length of the printed version; in case of strings the result is exact. <>= elemental function sprintf_arg_get_length (arg) result (length) integer :: length type(sprintf_arg_t), intent(in) :: arg select case (arg%type) case (ARGTYPE_INT) length = log10 (real (huge (arg%ival(1)))) + 2 case (ARGTYPE_REAL) length = log10 (real (radix (arg%rval(1))) ** digits (arg%rval(1))) + 8 case (ARGTYPE_STR) length = size (arg%sval) case default length = 0 end select end function sprintf_arg_get_length @ %def sprintf_arg_get_length <>= subroutine sprintf_arg_apply_sprintf (arg, fmt, result, actual_length) type(sprintf_arg_t), intent(in) :: arg character(c_char), dimension(:), intent(in) :: fmt character(c_char), dimension(:), intent(inout) :: result integer, intent(out) :: actual_length integer(c_int) :: ival real(c_double) :: rval select case (arg%type) case (ARGTYPE_NONE) actual_length = sprintf_none (result, fmt) case (ARGTYPE_INT) ival = arg%ival(1) actual_length = sprintf_int (result, fmt, ival) case (ARGTYPE_REAL) rval = arg%rval(1) actual_length = sprintf_double (result, fmt, rval) case (ARGTYPE_STR) actual_length = sprintf_str (result, fmt, arg%sval) case default call msg_bug ("sprintf_arg_apply_sprintf called with illegal type") end select if (actual_length < 0) then write (msg_buffer, *) "Format: '", fmt, "'" call msg_message () write (msg_buffer, *) "Output: '", result, "'" call msg_message () call msg_error ("I/O error in sprintf call") actual_length = 0 end if end subroutine sprintf_arg_apply_sprintf @ %def sprintf_arg_apply_sprintf @ \subsubsection{Container type for the output} There is a procedure which chops the format string into pieces that contain at most one conversion specifier. Pairing this with a [[sprintf_arg]] object, we get the actual input to the [[sprintf]] interface. The type below holds this input and can allocate the output string. <>= type :: sprintf_interface_t private character(c_char), dimension(:), allocatable :: input_fmt type(sprintf_arg_t) :: arg character(c_char), dimension(:), allocatable :: output_str integer :: output_str_len = 0 end type sprintf_interface_t @ %def sprintf_fmt_t <>= subroutine sprintf_interface_init (intf, fmt, arg) type(sprintf_interface_t), intent(out) :: intf type(string_t), intent(in) :: fmt type(sprintf_arg_t), intent(in) :: arg integer :: fmt_len, i fmt_len = len (fmt) allocate (intf%input_fmt (fmt_len + 1)) do i = 1, fmt_len intf%input_fmt(i) = extract (fmt, i, i) end do intf%input_fmt(fmt_len+1) = c_null_char intf%arg = arg allocate (intf%output_str (len (fmt) + sprintf_arg_get_length (arg) + 1)) end subroutine sprintf_interface_init @ %def sprintf_interface_init <>= subroutine sprintf_interface_write (intf, unit) type(sprintf_interface_t), intent(in) :: intf integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, *) "Format string = ", '"', intf%input_fmt, '"' write (u, "(1x,A,1x)", advance = "no") "Argument = " call sprintf_arg_write (intf%arg, unit) if (intf%output_str_len > 0) then write (u, *) "Result string = ", & '"', intf%output_str (1:intf%output_str_len), '"' end if end subroutine sprintf_interface_write @ %def sprintf_interface_write @ Return the output string: <>= function sprintf_interface_get_result (intf) result (string) type(string_t) :: string type(sprintf_interface_t), intent(in) :: intf character(kind = c_char, len = max (intf%output_str_len, 0)) :: buffer integer :: i if (intf%output_str_len > 0) then do i = 1, intf%output_str_len buffer(i:i) = intf%output_str(i) end do string = buffer(1:intf%output_str_len) else string = "" end if end function sprintf_interface_get_result @ %def sprintf_interface_get_result <>= subroutine sprintf_interface_apply_sprintf (intf) type(sprintf_interface_t), intent(inout) :: intf call sprintf_arg_apply_sprintf & (intf%arg, intf%input_fmt, intf%output_str, intf%output_str_len) end subroutine sprintf_interface_apply_sprintf @ %def sprintf_interface_apply_sprintf @ Import the interfaces defined in the previous section: <>= <> @ \subsubsection{Scan the format string} Chop it into pieces that contain one conversion specifier each. The zero-th piece contains the part before the first specifier. Check the specifiers and allow only the subset that we support. Also check for an exact match between conversion specifiers and input arguments. The result is an allocated array of [[sprintf_interface]] object; each one contains a piece of the format string and the corresponding argument. <>= subroutine chop_and_check_format_string (fmt, arg, intf) type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), intent(out), allocatable :: intf integer :: n_args, i type(string_t), dimension(:), allocatable :: split_fmt type(string_t) :: word, buffer, separator integer :: pos, length, l logical :: ok type(sprintf_arg_t) :: arg_null ok = .true. length = 0 n_args = size (arg) allocate (split_fmt (0:n_args)) split_fmt = "" buffer = fmt SCAN_ARGS: do i = 1, n_args FIND_CONVERSION: do call split (buffer, word, "%", separator=separator) if (separator == "") then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too few conversion specifiers in format string") ok = .false.; exit SCAN_ARGS end if split_fmt(i-1) = split_fmt(i-1) // word if (extract (buffer, 1, 1) /= "%") then split_fmt(i) = "%" exit FIND_CONVERSION else split_fmt(i-1) = split_fmt(i-1) // "%" end if end do FIND_CONVERSION pos = verify (buffer, "#0-+ ") ! Flag characters (zero or more) split_fmt(i) = split_fmt(i) // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) pos = verify (buffer, "123456890") ! Field width word = extract (buffer, 1, pos-1) if (len (word) /= 0) then call read_int_from_string (word, len (word), l) length = length + l end if split_fmt(i) = split_fmt(i) // word buffer = remove (buffer, 1, pos-1) if (extract (buffer, 1, 1) == ".") then buffer = remove (buffer, 1, 1) pos = verify (buffer, "1234567890") ! Precision split_fmt(i) = split_fmt(i) // "." // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) end if ! Length modifier would come here, but is not allowed select case (char (extract (buffer, 1, 1))) ! conversion specifier case ("d", "i") if (arg(i)%type /= ARGTYPE_INT) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: integer value expected") ok = .false.; exit SCAN_ARGS end if case ("e", "E", "f", "F", "g", "G") if (arg(i)%type /= ARGTYPE_REAL) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: real value expected") ok = .false.; exit SCAN_ARGS end if case ("s") if (arg(i)%type /= ARGTYPE_STR) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: logical or string value expected") ok = .false.; exit SCAN_ARGS end if case default call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "illegal or incomprehensible conversion specifier") ok = .false.; exit SCAN_ARGS end select split_fmt(i) = split_fmt(i) // extract (buffer, 1, 1) buffer = remove (buffer, 1, 1) end do SCAN_ARGS if (ok) then FIND_EXTRA_CONVERSION: do call split (buffer, word, "%", separator=separator) split_fmt(n_args) = split_fmt(n_args) // word // separator if (separator == "") exit FIND_EXTRA_CONVERSION if (extract (buffer, 1, 1) == "%") then split_fmt(n_args) = split_fmt(n_args) // "%" buffer = remove (buffer, 1, 1) else call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too many conversion specifiers in format string") ok = .false.; exit FIND_EXTRA_CONVERSION end if end do FIND_EXTRA_CONVERSION split_fmt(n_args) = split_fmt(n_args) // buffer allocate (intf (0:n_args)) call sprintf_interface_init (intf(0), split_fmt(0), arg_null) do i = 1, n_args call sprintf_interface_init (intf(i), split_fmt(i), arg(i)) end do else allocate (intf (0)) end if contains subroutine read_int_from_string (word, length, l) type(string_t), intent(in) :: word integer, intent(in) :: length integer, intent(out) :: l character(len=length) :: buffer buffer = word read (buffer, *) l end subroutine read_int_from_string end subroutine chop_and_check_format_string @ %def chop_and_check_format_string @ \subsection{API} <>= public :: sprintf <>= module function sprintf (fmt, arg) result (string) type(string_t) :: string type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg end function sprintf <>= module function sprintf (fmt, arg) result (string) type(string_t) :: string type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), allocatable :: intf integer :: i string = "" call chop_and_check_format_string (fmt, arg, intf) if (size (intf) > 0) then do i = 0, ubound (intf, 1) call sprintf_interface_apply_sprintf (intf(i)) string = string // sprintf_interface_get_result (intf(i)) end do end if end function sprintf @ %def sprintf @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[formats_ut.f90]]>>= <> module formats_ut use unit_tests use formats_uti <> <> contains <> end module formats_ut @ %def formats_ut @ <<[[formats_uti.f90]]>>= <> module formats_uti <> <> use formats <> <> <> contains <> end module formats_uti @ %def formats_ut @ API: driver for the unit tests below. <>= public :: format_test <>= subroutine format_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine format_test @ %def format_test <>= call test (format_1, "format_1", & "check formatting routines", & u, results) <>= public :: format_1 <>= subroutine format_1 (u) integer, intent(in) :: u write (u, "(A)") "*** Test 1: a string ***" write (u, "(A)") call test_run (var_str("%s"), 1, [4], ['abcdefghij'], u) write (u, "(A)") "*** Test 2: two integers ***" write (u, "(A)") call test_run (var_str("%d,%d"), 2, [2, 2], ['42', '13'], u) write (u, "(A)") "*** Test 3: floating point number ***" write (u, "(A)") call test_run (var_str("%8.4f"), 1, [3], ['42567.12345'], u) write (u, "(A)") "*** Test 4: general expression ***" call test_run (var_str("%g"), 1, [3], ['3.1415'], u) contains subroutine test_run (fmt, n_args, type, buffer, unit) type(string_t), intent(in) :: fmt integer, intent(in) :: n_args, unit logical :: lval integer :: ival real(default) :: rval integer :: i type(string_t) :: string type(sprintf_arg_t), dimension(:), allocatable :: arg integer, dimension(n_args), intent(in) :: type character(*), dimension(n_args), intent(in) :: buffer write (unit, "(A,A)") "Format string :", char(fmt) write (unit, "(A,I1)") "Number of args:", n_args allocate (arg (n_args)) do i = 1, n_args write (unit, "(A,I1)") "Argument (type ) = ", type(i) select case (type(i)) case (ARGTYPE_LOG) read (buffer(i), *) lval call sprintf_arg_init (arg(i), lval) case (ARGTYPE_INT) read (buffer(i), *) ival call sprintf_arg_init (arg(i), ival) case (ARGTYPE_REAL) read (buffer(i), *) rval call sprintf_arg_init (arg(i), rval) case (ARGTYPE_STR) call sprintf_arg_init (arg(i), var_str (trim (buffer(i)))) end select end do string = sprintf (fmt, arg) write (unit, "(A,A,A)") "Result: '", char (string), "'" deallocate (arg) end subroutine test_run end subroutine format_1 @ %def format_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{CPU timing} The time is stored in a simple derived type which just holds a floating-point number. <<[[cputime.f90]]>>= <> module cputime <> <> <> <> <> <> interface <> end interface end module cputime @ %def cputime <<[[cputime_sub.f90]]>>= <> submodule (cputime) cputime_s use io_units use diagnostics implicit none contains <> end submodule cputime_s @ %def cputime_s @ @ The CPU time is a floating-point number with an arbitrary reference time. It is single precision (default real, not [[real(default)]]). It is measured in seconds. <>= public :: time_t <>= type :: time_t private logical :: known = .false. real :: value = 0 contains <> end type time_t @ %def time_t <>= procedure :: write => time_write <>= module subroutine time_write (object, unit) class(time_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine time_write <>= module subroutine time_write (object, unit) class(time_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Time in seconds =" if (object%known) then write (u, "(1x,ES10.3)") object%value else write (u, "(1x,A)") "[unknown]" end if end subroutine time_write @ %def time_write @ Set the current time <>= procedure :: set_current => time_set_current <>= module subroutine time_set_current (time) class(time_t), intent(out) :: time end subroutine time_set_current <>= module subroutine time_set_current (time) class(time_t), intent(out) :: time integer :: msecs call system_clock (msecs) time%value = real (msecs) / 1000. time%known = time%value > 0 end subroutine time_set_current @ %def time_set_current @ Assign to a [[real(default]] value. If the time is undefined, return zero. <>= public :: assignment(=) <>= interface assignment(=) module procedure real_assign_time module procedure real_default_assign_time end interface <>= pure module subroutine real_assign_time (r, time) real, intent(out) :: r class(time_t), intent(in) :: time end subroutine real_assign_time pure module subroutine real_default_assign_time (r, time) real(default), intent(out) :: r class(time_t), intent(in) :: time end subroutine real_default_assign_time <>= pure module subroutine real_assign_time (r, time) real, intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_assign_time pure module subroutine real_default_assign_time (r, time) real(default), intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_default_assign_time @ %def real_assign_time @ Assign an integer or (single precision) real value to the time object. <>= generic :: assignment(=) => time_assign_from_integer, time_assign_from_real procedure, private :: time_assign_from_integer procedure, private :: time_assign_from_real <>= module subroutine time_assign_from_integer (time, ival) class(time_t), intent(out) :: time integer, intent(in) :: ival end subroutine time_assign_from_integer module subroutine time_assign_from_real (time, rval) class(time_t), intent(out) :: time real, intent(in) :: rval end subroutine time_assign_from_real <>= module subroutine time_assign_from_integer (time, ival) class(time_t), intent(out) :: time integer, intent(in) :: ival time%value = ival time%known = .true. end subroutine time_assign_from_integer module subroutine time_assign_from_real (time, rval) class(time_t), intent(out) :: time real, intent(in) :: rval time%value = rval time%known = .true. end subroutine time_assign_from_real @ %def time_assign_from_real @ Add times and compute time differences. If any input value is undefined, the result is undefined. <>= generic :: operator(-) => subtract_times generic :: operator(+) => add_times procedure, private :: subtract_times procedure, private :: add_times <>= pure module function subtract_times (t_end, t_begin) result (time) type(time_t) :: time class(time_t), intent(in) :: t_end, t_begin end function subtract_times pure module function add_times (t1, t2) result (time) type(time_t) :: time class(time_t), intent(in) :: t1, t2 end function add_times <>= pure module function subtract_times (t_end, t_begin) result (time) type(time_t) :: time class(time_t), intent(in) :: t_end, t_begin if (t_end%known .and. t_begin%known) then time%known = .true. time%value = t_end%value - t_begin%value end if end function subtract_times pure module function add_times (t1, t2) result (time) type(time_t) :: time class(time_t), intent(in) :: t1, t2 if (t1%known .and. t2%known) then time%known = .true. time%value = t1%value + t2%value end if end function add_times @ %def subtract_times @ %def add_times @ Check if a time is known, so we can use it: <>= procedure :: is_known => time_is_known <>= module function time_is_known (time) result (flag) class(time_t), intent(in) :: time logical :: flag end function time_is_known <>= module function time_is_known (time) result (flag) class(time_t), intent(in) :: time logical :: flag flag = time%known end function time_is_known @ %def time_is_known @ We define functions for converting the time into ss / mm:ss / hh:mm:ss / dd:mm:hh:ss. <>= generic :: expand => time_expand_s, time_expand_ms, & time_expand_hms, time_expand_dhms procedure, private :: time_expand_s procedure, private :: time_expand_ms procedure, private :: time_expand_hms procedure, private :: time_expand_dhms <>= module subroutine time_expand_s (time, sec) class(time_t), intent(in) :: time integer, intent(out) :: sec end subroutine time_expand_s module subroutine time_expand_ms (time, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: min, sec end subroutine time_expand_ms module subroutine time_expand_hms (time, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: hour, min, sec end subroutine time_expand_hms module subroutine time_expand_dhms (time, day, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: day, hour, min, sec end subroutine time_expand_dhms <>= module subroutine time_expand_s (time, sec) class(time_t), intent(in) :: time integer, intent(out) :: sec if (time%known) then sec = time%value else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_s module subroutine time_expand_ms (time, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: min, sec if (time%known) then if (time%value >= 0) then sec = mod (int (time%value), 60) else sec = - mod (int (- time%value), 60) end if min = time%value / 60 else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_ms module subroutine time_expand_hms (time, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: hour, min, sec call time%expand (min, sec) hour = min / 60 if (min >= 0) then min = mod (min, 60) else min = - mod (-min, 60) end if end subroutine time_expand_hms module subroutine time_expand_dhms (time, day, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: day, hour, min, sec call time%expand (hour, min, sec) day = hour / 24 if (hour >= 0) then hour = mod (hour, 24) else hour = - mod (- hour, 24) end if end subroutine time_expand_dhms @ %def time_expand @ Use the above expansions to generate a time string. <>= procedure :: to_string_s => time_to_string_s procedure :: to_string_ms => time_to_string_ms procedure :: to_string_hms => time_to_string_hms procedure :: to_string_dhms => time_to_string_dhms <>= module function time_to_string_s (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_s module function time_to_string_ms (time, blank) result (str) class(time_t), intent(in) :: time logical, intent(in), optional :: blank type(string_t) :: str end function time_to_string_ms module function time_to_string_hms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_hms module function time_to_string_dhms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_dhms <>= module function time_to_string_s (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s call time%expand (s) write (buffer, "(I0,'s')") s str = trim (buffer) end function time_to_string_s module function time_to_string_ms (time, blank) result (str) class(time_t), intent(in) :: time logical, intent(in), optional :: blank type(string_t) :: str character(256) :: buffer integer :: s, m logical :: x_out x_out = .false. if (present (blank)) x_out = blank call time%expand (m, s) write (buffer, "(I0,'m:',I2.2,'s')") m, abs (s) str = trim (buffer) if (x_out) then str = replace (str, len(str)-1, "X") end if end function time_to_string_ms module function time_to_string_hms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h call time%expand (h, m, s) write (buffer, "(I0,'h:',I2.2,'m:',I2.2,'s')") h, abs (m), abs (s) str = trim (buffer) end function time_to_string_hms module function time_to_string_dhms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h, d call time%expand (d, h, m, s) write (buffer, "(I0,'d:',I2.2,'h:',I2.2,'m:',I2.2,'s')") & d, abs (h), abs (m), abs (s) str = trim (buffer) end function time_to_string_dhms @ %def time_to_string @ \subsection{Timer} A timer can measure real (wallclock) time differences. The base type corresponds to the result, i.e., time difference. The object contains two further times for start and stop time. <>= public :: timer_t <>= type, extends (time_t) :: timer_t private logical :: running = .false. type(time_t) :: t1, t2 contains <> end type timer_t @ %def timer_t @ Output. If the timer is running, we indicate this, otherwise write just the result. <>= procedure :: write => timer_write <>= module subroutine timer_write (object, unit) class(timer_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine timer_write <>= module subroutine timer_write (object, unit) class(timer_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%running) then write (u, "(1x,A)") "Time in seconds = [running]" else call object%time_t%write (u) end if end subroutine timer_write @ %def timer_write @ Start the timer: store the current time in the first entry and adapt the status. We forget any previous values. <>= procedure :: start => timer_start <>= module subroutine timer_start (timer) class(timer_t), intent(out) :: timer end subroutine timer_start <>= module subroutine timer_start (timer) class(timer_t), intent(out) :: timer call timer%t1%set_current () timer%running = .true. end subroutine timer_start @ %def timer_start @ Restart the timer: simply adapt the status, keeping the start time. <>= procedure :: restart => timer_restart <>= module subroutine timer_restart (timer) class(timer_t), intent(inout) :: timer end subroutine timer_restart <>= module subroutine timer_restart (timer) class(timer_t), intent(inout) :: timer if (timer%t1%known .and. .not. timer%running) then timer%running = .true. else call msg_bug ("Timer: restart attempt from wrong status") end if end subroutine timer_restart @ %def timer_start @ Stop the timer: store the current time in the second entry, adapt the status, and compute the elapsed time. <>= procedure :: stop => timer_stop <>= module subroutine timer_stop (timer) class(timer_t), intent(inout) :: timer end subroutine timer_stop <>= module subroutine timer_stop (timer) class(timer_t), intent(inout) :: timer call timer%t2%set_current () timer%running = .false. call timer%evaluate () end subroutine timer_stop @ %def timer_stop @ Manually set the time (for unit test) <>= procedure :: set_test_time1 => timer_set_test_time1 procedure :: set_test_time2 => timer_set_test_time2 <>= module subroutine timer_set_test_time1 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t end subroutine timer_set_test_time1 module subroutine timer_set_test_time2 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t end subroutine timer_set_test_time2 <>= module subroutine timer_set_test_time1 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t1 = t end subroutine timer_set_test_time1 module subroutine timer_set_test_time2 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t2 = t end subroutine timer_set_test_time2 @ %def timer_set_test_time1 @ %def timer_set_test_time2 @ This is separate, available for the unit test. <>= procedure :: evaluate => timer_evaluate <>= module subroutine timer_evaluate (timer) class(timer_t), intent(inout) :: timer end subroutine timer_evaluate <>= module subroutine timer_evaluate (timer) class(timer_t), intent(inout) :: timer timer%time_t = timer%t2 - timer%t1 end subroutine timer_evaluate @ %def timer_evaluate @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[cputime_ut.f90]]>>= <> module cputime_ut use unit_tests use cputime_uti <> <> contains <> end module cputime_ut @ %def cputime_ut @ <<[[cputime_uti.f90]]>>= <> module cputime_uti <> use cputime <> <> contains <> end module cputime_uti @ %def cputime_ut @ API: driver for the unit tests below. <>= public :: cputime_test <>= subroutine cputime_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cputime_test @ %def cputime_test @ \subsubsection{Basic tests} Check basic functions of the time object. The part which we can't check is getting the actual time from the system clock, since the output will not be reproducible. However, we can check time formats and operations. <>= call test (cputime_1, "cputime_1", & "time operations", & u, results) <>= public :: cputime_1 <>= subroutine cputime_1 (u) integer, intent(in) :: u type(time_t) :: time, time1, time2 real :: t integer :: d, h, m, s write (u, "(A)") "* Test output: cputime_1" write (u, "(A)") "* Purpose: check time operations" write (u, "(A)") write (u, "(A)") "* Undefined time" write (u, *) call time%write (u) write (u, *) write (u, "(A)") "* Set time to zero" write (u, *) time = 0 call time%write (u) write (u, *) write (u, "(A)") "* Set time to 1.234 s" write (u, *) time = 1.234 call time%write (u) t = time write (u, "(1x,A,F6.3)") "Time as real =", t write (u, *) write (u, "(A)") "* Compute time difference" write (u, *) time1 = 5.33 time2 = 7.55 time = time2 - time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Compute time sum" write (u, *) time = time2 + time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Expand time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s write (u, *) write (u, "(A)") "* Expand negative time" write (u, *) time1 = - (((24 + 1) * 60 + 1) * 60 + 1) time2 = - (((3 * 24 + 23) * 60 + 59) * 60 + 59) call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s 1 format (1x,A,1x,4(I0,:,':')) write (u, *) write (u, "(A)") "* String from time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Blanking out the last second entry" write (u, "(A)") write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_ms (.true.)) write (u, *) write (u, "(A)") "* String from negative time" write (u, *) time1 = -(((24 + 1) * 60 + 1) * 60 + 1) time2 = -(((3 * 24 + 23) * 60 + 59) * 60 + 59) write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Test output end: cputime_1" end subroutine cputime_1 @ %def cputime_1 @ \subsubsection{Timer tests} Check a timer object. <>= call test (cputime_2, "cputime_2", & "timer", & u, results) <>= public :: cputime_2 <>= subroutine cputime_2 (u) integer, intent(in) :: u type(timer_t) :: timer write (u, "(A)") "* Test output: cputime_2" write (u, "(A)") "* Purpose: check timer" write (u, "(A)") write (u, "(A)") "* Undefined timer" write (u, *) call timer%write (u) write (u, *) write (u, "(A)") "* Start timer" write (u, *) call timer%start () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer (injecting fake timings)" write (u, *) call timer%stop () call timer%set_test_time1 (2) call timer%set_test_time2 (5) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Restart timer" write (u, *) call timer%restart () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer again (injecting fake timing)" write (u, *) call timer%stop () call timer%set_test_time2 (10) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Test output end: cputime_2" end subroutine cputime_2 @ %def cputime_2