Small Fortran tools

[Beliavsky]

Here is a short Python function to separate a line of Fortran code into its non-comment and comment (if any) parts. Possible applications are to

1. Convert non-comment code to lower case while leaving the comments unchanged.
2. Convert comments from one natural language to another.
3. Strip comments from a code, so that two comment-free versions of a code can be compared.

def split_fortran_line(line):
    """
    Splits a Fortran line into code and comment parts, ignoring '!' inside quotes.
    
    Args:
        line (str): A line of Fortran code.
        
    Returns:
        tuple: A 2-element tuple (code, comment), where 'comment' is None if there is no comment.
    """
    in_single_quote = False
    in_double_quote = False
    comment_pos = None
    # Loop through each character to identify unquoted '!'
    for i, char in enumerate(line):
        if char == "'" and not in_double_quote:
            in_single_quote = not in_single_quote
        elif char == '"' and not in_single_quote:
            in_double_quote = not in_double_quote
        elif char == '!' and not in_single_quote and not in_double_quote:
            comment_pos = i
            break
    # Split code and comment based on identified position of '!'
    if comment_pos is not None:
        code = line[:comment_pos].rstrip()
        comment = line[comment_pos:].lstrip()
    else:
        code = line
        comment = None
    if code == "":
        code = None
    return code, comment

src = "hello.f90"
lines = open(src, "r").readlines()
stripped_source_file = "temp.f90" # if not None, file to which comment-free code is written
outp = open(stripped_source_file, "w")
for line in lines:
    line = line.rstrip()
    code, comment = split_fortran_line(line)
    print("\nline: " + line)
    if code is not None:
        print("code: " + code)
        if stripped_source_file:
            print(code.rstrip(), file=outp)
    if comment is not None:
        print("comment: " + comment)

For hello.f90 containing

program main
real :: pi
print*,"hi" ! prints hi
! comment line
pi = 3.14 ! sets pi
print*,"bye!" ! says bye
end program main

the output is

line: program main
code: program main

line: real :: pi
code: real :: pi

line: print*,"hi" ! prints hi
code: print*,"hi"
comment: ! prints hi

line: ! comment line
comment: ! comment line

line: pi = 3.14 ! sets pi
code: pi = 3.14
comment: ! sets pi

line: print*,"bye!" ! says bye
code: print*,"bye!"
comment: ! says bye

I also tested the function on a 10K line Fortran source file with inline comments, on which it worked correctly, but I’d like to know of cases where the function fails.

I invite people to submit their small tools. Another Python script extracts subroutine and function definitions from a list of lines of Fortran code.

[certik]

Btw, LFortran can do many such transformations via lfortran fmt as well. I am interested in supporting all such use cases and implementing missing features, so that we have eventually have a robust and maintained tool that the community can use and rely on. Go ahead and open up any feature requests at Issues · lfortran/lfortran · GitHub.

[urbanjost]

I use a Fortran program with similar functionality and often use it to change code case. It generates a simple measure of the percentage of code that is comments per a user request that I do not use much myself but is a required measurement for at least one organization.

In addition to LFortran, spag and fpt can update comments from F77 fixed-format style to free-format style and select options like camel-case for procedure and/or variable names, uppercase “reserved” words, …

I started a collection of Fortran example programs and small utilities. flower(1) is
among those at

apps/flower at main · urbanjost/apps

Most are not tools for use with Fortran, just written in Fortran. fpm(1) is assumed to be available.

prep is a preprocessor for Fortran.

playground converts fortran code to HTML that includes a click-and-play insertion into the playground. I would like to have that work with Compiler Explorer as the playground has stagnated; but LFortran should provide a nice solution for including code in a www page or journal page as live code so I was less motivated to get that working. I saw a github page where someone did that with Compiler Explorer but have not been able to relocate it.

fman/fpm-man displays intrinsic descriptions and there are several fpm plugins in there somewhere.
,
For LFortran converting a source code to HTML with the color formatting that is set up to run from the webpage would be nice, or creating a basic playbook. I have not been setup to use the fmt option recently but it already did highlight coloring so that might all exist already (?)

Regarding use cases for being able to differentiate between comments and strings and code, a few non-obvious ones might be:

If you heavily comment the code removing the code makes it easier to run the comments through other CLI tools like spell-checkers or to create documentation programmatically. See doxygen and ford for more powerful automatic documentation generation.

Should not be a problem post-f2023 but removing the comments makes it easier to look for lines that exceed 132 columns, but most compilers detect that now (?)

Some commercial source code is distributed with comments removed. Some of the reasons are based on lawyer-reasoning which some consider to be an oxymoron, but it is what it is.

mars/bootstrap at main · lockstockandbarrel/mars

has flower, prep, fpm-license, and fpm-man as single-file releases. I think there all fit the description of simple Fortran-centric utilities.

There are a couple of utilties that generate gmake and cmake build files that would fit the bill around.

f90split and fsplit are probably not as commonly used as in the past but would be good additions to a collection, I think.

coco is a fortran-based fortran pre-processor that might fit the bill.

If the fpm repository gets fired up it would be nice if it supported packages like this so a fpm option or plugin would allow you to just enter something like

fpm --install-package  flower prep fpm-man

and it would get the designated packages not as dependencies but as projects to build and install, basically like

(
cd /tmp
git clone /http://repository/flower
cd flower
fpm install
rm -rfv /tmp/flower

[certik]

@urbanjost

For LFortran converting a source code to HTML with the color formatting that is set up to run from the webpage would be nice, or creating a basic playbook. I have not been setup to use the fmt option recently but it already did highlight coloring so that might all exist already (?)

Thanks, I created an issue for this: Allow `lfortran fmt` to output a webpage · Issue #5240 · lfortran/lfortran · GitHub.

[urbanjost]

RE: little tools

If I have a plain text license file or a program banner text it is
convenient to have a command to turn the text info Fortran code. This
program is extracted from a larger program and so could be simplified
considerably but is now a simple filter. So

   txt2f90 _flower  <flower.txt >txt2f90_flower.f90

will convert stdin from a text file to a Fortran subroutine that
prints a copy of the input file.

Not that hard to do the equivalent with an editor, but can be particularly
handy if you need to do this repeatedly.

text file input:

                      _(_)_                          wWWWw   _
          @@@@       (_)@(_)   vVVVv     _     @@@@  (___) _(_)_
         @@()@@ wWWWw  (_)\    (___)   _(_)_  @@()@@   Y  (_)@(_)
          @@@@  (___)     `|/    Y    (_)@(_)  @@@@   \|/   (_)\
           /      Y       \|    \|/    /(_)    \|      |/      |
        \ |     \ |/       | / \ | /  \|/       |/    \|      \|/
       jgs|//   \\|///  \\\|//\\\|/// \|///  \\\|//  \\|//  \\\|//
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

becomes

subroutine txt2f90_flower()
integer :: i
character(len=:),allocatable :: txt2f90_text(:)
txt2f90_text=[ CHARACTER(LEN=68) :: &
'                                                                    ',&
'                      _(_)_                          wWWWw   _      ',&
'          @@@@       (_)@(_)   vVVVv     _     @@@@  (___) _(_)_    ',&
'         @@()@@ wWWWw  (_)\    (___)   _(_)_  @@()@@   Y  (_)@(_)   ',&
'          @@@@  (___)     `|/    Y    (_)@(_)  @@@@   \|/   (_)\    ',&
'           /      Y       \|    \|/    /(_)    \|      |/      |    ',&
'        \ |     \ |/       | / \ | /  \|/       |/    \|      \|/   ',&
'       jgs|//   \\|///  \\\|//\\\|/// \|///  \\\|//  \\|//  \\\|//  ',&
'       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^',&
'']
write(*,'(a)') (trim(txt2f90_text(i)), i=1, size(txt2f90_text))
end subroutine txt2f90_flower

txt2f90.f90 source

module m_
use, intrinsic :: iso_fortran_env, only: stderr=>error_unit, stdout=>output_unit, stdin=>input_unit
implicit none
contains

subroutine fileread(filename,pageout)
class(*),intent(in)                      :: filename   
character(len=:),allocatable,intent(out) :: pageout(:) 
character(len=1),allocatable             :: text(:)    
   call filebyte(filename,text) 
   if(.not.allocated(text))then
      select type(filename)
       type is (character(len=*)); write(*,*)'*fileread* failed to load file '//filename
       type is (integer);          write(*,'(a,i0)')'*fileread* failed to load file unit ',filename
      end select
   else  
      pageout=page(text)
      deallocate(text)     
   endif

contains

function page(array)  result (table)
character(len=1),intent(in)  :: array(:)
character(len=:),allocatable :: table(:)
integer                      :: i
integer                      :: linelength
integer                      :: length
integer                      :: lines
integer                      :: linecount
integer                      :: position
integer                      :: sz
character(len=1),parameter   :: nl = char(10)
character(len=1),parameter   :: cr = char(13)
   lines = 0
   linelength = 0
   length = 0
   sz=size(array)
   do i = 1,sz
      if( array(i) == nl )then
         linelength = max(linelength,length)
         lines = lines + 1
         length = 0
      else
         length = length + 1
      endif
   enddo
   if( sz > 0 )then
      if( array(sz) /= nl )then
         lines = lines+1
      endif
   endif
   if(allocated(table))deallocate(table)
   allocate(character(len=linelength) :: table(lines))
   table(:) = ' '
   linecount = 1
   position = 1
   do i = 1,sz
      if( array(i) == nl )then
         linecount=linecount+1
         position=1
      elseif( array(i) == cr )then
      elseif( linelength /= 0 )then
         table(linecount)(position:position) = array(i)
         position = position+1
      endif
   enddo
end function page
end subroutine fileread

subroutine filebyte(filename,text,length,lines)
implicit none
class(*),intent(in)                      :: filename    
character(len=1),allocatable,intent(out) :: text(:)     
integer,intent(out),optional             :: length      
integer,intent(out),optional             :: lines       
integer :: nchars=0             
integer :: igetunit             
integer :: ios=0                
integer :: length_local
integer :: lines_local
integer :: i
integer :: icount
character(len=256)  :: message
character(len=4096) :: label
character(len=:),allocatable :: line
   length_local=0
   lines_local=0
   message=''
   select type(filename)
    type is (character(len=*))
       if(filename /= '-') then
          open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,&
           &form="unformatted", access="stream",status='old',iostat=ios)
          label=filename
       else 
          call copystdin()
       endif
    type is (integer)
       if(filename /= stdin) then
          rewind(unit=filename,iostat=ios,iomsg=message)
          igetunit=filename
       else 
          call copystdin()
       endif
       write(label,'("unit ",i0)')filename
   end select
   if(ios == 0)then  
      inquire(unit=igetunit, size=nchars)
      if(nchars <= 0)then
         write(stderr,'(a)') '*filebyte* empty file '//trim(label)
         return
      endif

      if(allocated(text))deallocate(text) 
      allocate ( text(nchars) )           
      read(igetunit,iostat=ios,iomsg=message) text      
      if(ios /= 0)then
         write(stderr,'(a)') '*filebyte* bad read of '//trim(label)//':'//trim(message)
      endif
   else
      write(stderr,'(a)') '*filebyte* '//message
      allocate ( text(0) )           
   endif
   close(iostat=ios,unit=igetunit)            
   if(present(lines).or.present(length))then  
      icount=0
      do i=1,nchars
         if(text(i) == new_line('A'))then
            lines_local=lines_local+1
            length_local=max(length_local,icount)
            icount=0
         endif
         icount=icount+1
      enddo
      if(nchars /= 0)then
         if(text(nchars) /= new_line('A'))then
            lines_local=lines_local+1
            length_local=max(length_local,icount)
         endif
      endif
      if(present(lines))lines=lines_local
      if(present(length))length=length_local
   endif

contains

subroutine copystdin()
integer :: iostat
   open(newunit=igetunit, iomsg=message,&
   &form="unformatted", access="stream",status='scratch',iostat=iostat)
   open(unit=stdin,pad='yes')
   infinite: do while (getline(line,iostat=iostat)==0)
      write(igetunit)line//new_line('a')
   enddo infinite
   rewind(igetunit,iostat=iostat,iomsg=message)
end subroutine copystdin

end subroutine filebyte

function stretch(line,length) result(strout)
character(len=*),intent(in)                  :: line
integer,intent(in)                           :: length
character(len=:),allocatable                 :: strout
   strout=pad(line,length)
end function stretch

function replace(targetline,old,new,ierr) result (newline)
character(len=*),intent(in)            :: targetline   
character(len=*),intent(in)            :: old          
character(len=*),intent(in)            :: new          
integer,intent(out),optional           :: ierr         
character(len=:),allocatable  :: newline               
character(len=:),allocatable  :: new_local, old_local, old_local_for_comparison
integer                       :: icount,ichange,ier2
integer                       :: original_input_length
integer                       :: len_old, len_new
integer                       :: ladd
integer                       :: right_margin
integer                       :: ind
integer                       :: ic
integer                       :: ichr
integer                       :: range_local(2)
character(len=:),allocatable  :: targetline_for_comparison   
character(len=:),allocatable  :: targetline_local   
   original_input_length=len_trim(targetline)          
   old_local=old
   new_local=new
   range_local(1)=1
   range_local(2)=original_input_length
   targetline_for_comparison=targetline
   old_local_for_comparison=old_local
   targetline_local=targetline
   icount=0                                            
   ichange=0                                           
   len_old=len(old_local)                              
   len_new=len(new_local)                              
   right_margin=len(targetline)                        
   newline=''                                          

   if(len_old == 0)then                                
      ichr=len_new + original_input_length
      if(len_new > 0)then
         newline=new_local(:len_new)//targetline_local(1:original_input_length)
      else
         newline=targetline_local(1:original_input_length)
      endif
      ichange=1                                        
      if(present(ierr))ierr=ichange
      return
   endif
   ichr=1                                    
   ic=1
   loop: do
      ind=index(targetline_for_comparison(ic:),old_local_for_comparison(:len_old))+ic-1
      if(ind == ic-1.or.ind > right_margin)then       
         exit loop                                     
      endif
      icount=icount+1                                  
      if(ind > ic)then                                
         ladd=ind-ic                                   
         newline=newline(:ichr-1)//targetline_local(ic:ind-1)
         ichr=ichr+ladd
      endif
      if(icount >= range_local(1).and.icount <= range_local(2))then    
         ichange=ichange+1
         if(len_new /= 0)then                                          
            newline=newline(:ichr-1)//new_local(:len_new)
            ichr=ichr+len_new
         endif
      else
         if(len_old /= 0)then                                          
            newline=newline(:ichr-1)//old_local(:len_old)
            ichr=ichr+len_old
         endif
      endif
      ic=ind+len_old
   enddo loop
   select case (ichange)
   case (0)                                            
      newline=targetline_local                         
   case default
      if(ic <= len(targetline))then                    
         newline=newline(:ichr-1)//targetline_local(ic:max(ic,original_input_length))
      endif
   end select
   if(present(ierr))ierr=ichange
end function replace

function pad(line,length) result(strout)
character(len=*),intent(in)          :: line
integer,intent(in)                   :: length
character(len=:),allocatable         :: strout
   allocate(character(len=max(length,len(line))) :: strout)
   strout(:)=line
end function pad

function getline(line,lun,iostat) result(ier)
implicit none
character(len=:),allocatable,intent(out) :: line
integer,intent(in),optional              :: lun
integer,intent(out),optional             :: iostat
integer                                  :: ier
character(len=4096)                      :: message
integer,parameter                        :: buflen=1024
character(len=:),allocatable             :: line_local
character(len=buflen)                    :: buffer
integer                                  :: isize
integer                                  :: lun_local
   line_local=''
   ier=0
   if(present(lun))then
      lun_local=lun
   else
      lun_local=stdin
   endif
   infinite: do                                                   
      read(lun_local,pad='yes',iostat=ier,fmt='(a)',advance='no', &
      & size=isize,iomsg=message) buffer                          
      if(isize > 0)line_local=line_local//buffer(:isize)          
      if(is_iostat_eor(ier))then                                  
         ier=0                                                    
         exit infinite                                            
     elseif(ier /= 0)then                                         
        line=trim(message)
        exit infinite
     endif
   enddo infinite
   line=line_local                                                
   if(present(iostat))iostat=ier
end function getline

end module m_

program txt2f90
use, intrinsic :: iso_fortran_env, only: stderr=>error_unit, stdout=>output_unit, stdin=>input_unit
use m_
implicit none
integer :: argument_length, istat
character(len=:), allocatable   :: textblock(:)
character(len=:),allocatable :: subname
   call get_command_argument(number=1,length=argument_length)
   if(allocated(subname))deallocate(subname)
   allocate(character(len=argument_length) :: subname)
   call get_command_argument(1,subname,status=istat)
   if(istat.ne.0.or.len(subname).eq.0) subname='_text'
   call fileread(stdin,textblock)
   if (size(textblock) > 0)then
      call codeit()
   endif

contains

subroutine codeit()
integer :: width
integer :: i
integer :: ilength
character(len=:), allocatable :: buff
   width = 0
   do i = min(1, size(textblock)), size(textblock)
      width = max(width, len_trim(textblock(i)))
   end do
   write (stdout, '(a)') 'subroutine txt2f90'//subname//'()'
   write (stdout, '(a)') 'integer :: i'
   write (stdout, '(a)') 'character(len=:),allocatable :: txt2f90_text(:)'
   write (stdout, '(a,i0,a)') 'txt2f90_text'//'=[ CHARACTER(LEN=', width, ') :: &'
   do i = min(1, size(textblock)), size(textblock)
      buff = trim(textblock(i))
      buff = replace(buff,"'","''")         
      write (stdout, '("''",a,"'',&")') stretch(buff, width)
   end do
   write (stdout, '(a)') "'']"
   write (stdout, '(a)') "write(*,'(a)') (trim(txt2f90_text(i)), i=1, size(txt2f90_text))"
   write (stdout, '(a)') "end subroutine txt2f90"//subname
end subroutine codeit

end program txt2f90

[certik]

@urbanjost this is great. Reminds me of similar tools to embed binary data into programs.

[urbanjost]

There is a version that uses uuencode and uudecode-like conversions that is probably like what you reference.

The playground program converts a Fortran program into an HTML file that puts the code into the fortran-lang playground that is similar to this.

This one is most often used with creating test frameworks where the input and output of a procedure generate a namelist file and the namelist file is then embedded into a little regression test program that calls the procedure with the input value(s) and compares the output values to the captured namelist data. It keeps it all in one file, instead of depending on keeping the expected output in a separate file. History has shown us that works better for us.

Either the NAG compiler or spag or fpt had an option to run a program and record the input and input values into a regression test automatically that was far more generic.

I assume LFortran is more concerned with getting an Alpha version going at this point, but on my wish-list would be something like that where data could be automatically captured that could be used to identify where any result changes occur between program compilations some day. It would be ideal to me if it generated self-contained programs placing the data in the programs somewhat like this filter does.

Regarding this much simpler tool, an example plugin called fpm-license uses something like it.
The script that builds fpm-license uses a script that reads licenses from individual files in a directory and runs them through a variant of the filter to make the plug-in. The plug-in can also
convert a file to a subroutine so you can generate subroutines for arbitrary licenses, not just the
built-in ones. That is, this filter is used to build fpm-license, but fpm-license has this routine built into it as a callable feature as well.

The prep processor lets you convert blocks of free-format text into a character array as well,
so you can include flat text files but they become a variable definition (or comments)

And hidden away on the build side of the fman program that describes intrinsic functions the build script uses this like it does with fpm-license to place the descriptions into the program.

So I was going to say this filter is useful but I do not use it all that much but thinking about it
I am realizing I use something like it all the time in automated processes; especially when maintaining help text for programs.

At some point it would be nice if the fpm repo had a place for little utility programs like this.

[Arjen]

This might be a nice exercise for generative AI programs: create an equivalent Fortran program.

[urbanjost]

An example of encoding bytes to RFC-4648. It should produce the same
output file as the GNU base64 command. The I/O in particular requires
optimization to approach the performance of the base64 command, but
otherwise the output should be identical.

The transfer() function can convert data of any type to bytes, so
the example works with an array of bytes.

demo_base64.f90

program demo_base64
! base64-encode/decode data to RFC-4648 and print to standard output
! usage: base64 inputfile > outputfile
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, real32, stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
implicit none
integer(kind=int32)          :: i, j, column, sz, pad, iostat
character(len=1),allocatable :: text(:) ! array to hold file in memory
character(len=:),allocatable :: infile
character(len=4)             :: chunk
integer,parameter            :: rfc4648_linelength=76
character(len=1),parameter   :: rfc4648_padding='='
   infile=get_arg(1)
   call slurp(infile,text) ! allocate character array and copy file into it and pad with two characters at end
   sz=size(text)-2
   pad=3-mod(sz,3)
   column=0
   ! place three bytes and zero into 32bit integer
   ! take sets of 6 bits from integer and place into every 8 bits
   do i=1,sz,3
      chunk=three2four(text(i:i+2))
      if(i.gt.sz-3)then
         if(pad.gt.0.and.pad.lt.3)then
            chunk(4-pad+1:)=repeat(rfc4648_padding,pad)
         endif
      endif
      if(column.ge.rfc4648_linelength)then
         write(stdout,'(a)')
         flush(unit=stdout,iostat=iostat)
         column=0
      endif
      write(stdout,'(a)',advance='no')chunk
      column=column+4
   enddo
   if(column.ne.0)write(stdout,'(a)')
contains

function three2four(tri) result(quad)
character(len=1),intent(in) :: tri(3)
character(len=4)            :: quad
integer(kind=int32)         :: i32, i, j, iout(4)
character(len=*),parameter  :: rfc4648_alphabet='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'
character(len=1),parameter  :: rfc4648_chars(*)=[(rfc4648_alphabet(i:i),i=1,len(rfc4648_alphabet))]
   i32 = transfer([(tri(j),j=3,1,-1),achar(0)], i32 )
   iout = 0
   ! The bits are numbered 0 to BIT_SIZE(I)-1, from right to left.
   do j=1,4
      call  mvbits(i32, (j-1)*6, 6, iout(4-j+1), 0)
      quad(4-j+1:4-j+1)=rfc4648_chars(iout(4-j+1)+1)
   enddo
end function three2four

function get_arg(iarg) result(value)
integer,intent(in)           :: iarg
character(len=:),allocatable :: value
integer                      :: argument_length, istat
   call get_command_argument(number=iarg,length=argument_length)
   if(allocated(value))deallocate(value)
   allocate(character(len=argument_length) :: value)
   value(:)=''
   call get_command_argument(iarg, value, status=istat)
end function get_arg

subroutine slurp(filename,text)
use iso_fortran_env, only : iostat_eor, iostat_end
!@(#) M_io::slurp(3f): allocate text array and read file filename into it, padding on two characters
character(len=*),intent(in)              :: filename    ! filename to slurp
character(len=1),allocatable,intent(out) :: text(:)     ! array to hold file
integer            :: nchars=0, igetunit, iostat=0, i, icount
character(len=256) :: iomsg
character(len=1)   :: byte
   text=''
   if(filename /= '') then
      open(newunit=igetunit, file=trim(filename), action="read", iomsg=iomsg,&
      &form="unformatted", access="stream",status='old',iostat=iostat)
   else ! copy stdin to a scratch file
      open(newunit=igetunit, iomsg=iomsg,&
      &form="unformatted", access="stream",status='scratch',iostat=iostat)
      open(unit=stdin,pad='yes')
      INFINITE: do
         read(stdin,'(a)',iostat=iostat,advance='no')byte
         if(is_iostat_eor(iostat)) then
            byte=new_line('a')
         elseif(is_iostat_end(iostat)) then
            exit
         elseif(iostat.ne.0)then
            exit
         endif
         write(igetunit)byte
      enddo INFINITE
      rewind(igetunit,iostat=iostat,iomsg=iomsg)
   endif
   if(iostat == 0)then  ! if file was successfully opened
      inquire(unit=igetunit, size=nchars)
      if(nchars <= 0)then
         write(stderr,'(a)')'*slurp* empty file '//trim(filename)
         return
      endif
      ! read file into text array
      if(allocated(text))deallocate(text)  ! make sure text array not allocated
      allocate( text(nchars+2) )           ! make enough storage to hold file and two padding characters
      read(igetunit,iostat=iostat,iomsg=iomsg) text(:nchars)      ! load input file -> text array
      if(iostat /= 0)then
         write(stderr,'(a)') '*slurp* bad read of '//trim(filename)//':'//trim(iomsg)
      endif
      text(size(text)-1:)=repeat(achar(0),2) ! add padding characters
   else
      write(stderr,'(a)') '*slurp* '//iomsg
   endif
   close(iostat=iostat,unit=igetunit)            ! close if opened successfully or not
end subroutine slurp

end program demo_base64

[ivanpribec]

Here is short Fortran program to strip free-form Fortran source files of comments (including trailing ones):

fstrip.f90

! Strip the program of comments and empty lines
!
! fstrip filename <left_justify>
!
!   filename ... string
!   left_justify ... logical (optional, T or F, .true. or .false)
!
program fstrip
implicit none

character(len=256) :: arg, jarg
character(len=132) :: buffer
logical :: left_justify
integer :: n, i, stat, unit

call get_command_argument(1, arg) ! filename
call get_command_argument(2,jarg) ! whether to left justify

left_justify = .false.
if (jarg /= "") read(jarg,*) left_justify

open(newunit=unit,file=trim(arg))

do 
    read(unit,'(A132)',iostat=stat) buffer
    if (is_iostat_end(stat)) exit

    ! Left justify the string
    if (left_justify) buffer = adjustl(buffer)

    ! Skip empty lines (an empty line is a "comment")
    n = len_trim(buffer)
    if (n == 0) cycle

    ! Skip comment lines
    if (is_comment_line(buffer)) cycle

    ! Strip trailing comment
    i = has_trailing_comment(buffer)
    if (i > 0) n = len_trim(buffer(1:i-1))

    print '(A)', buffer(1:n)

end do

close(unit)

contains

    ! Checks if a line is a comment line (i.e. the first character
    ! is an exclamation mark, only preceded by spaces)
    !
    ! (TODO: consider if tabs should be allowed)
    !
    logical function is_comment_line(buffer)
        character(len=*), intent(in) :: buffer 
        integer :: i 

        ! we assume programs have more statements than comments
        is_comment_line = .false.

        ! early check (comments usually start in first line, or string may
        ! have been already left-justified)
        if (buffer(1:1) == '!') then
            is_comment_line = .true.
            return
        end if

        ! search for '!' and verify preceded only by spaces
        i = scan(buffer,'!')
        if (i > 0) then
            is_comment_line = verify(buffer(1:i-1),' ') == 0
        end if

    end function

    impure integer function has_trailing_comment(line)
        character(len=*), intent(in) :: line

        character(len=1), dimension(100) :: stack
        integer :: i, top

        top = 0 ! Initialize the stack pointer

        
        do i = 1, len_trim(line) ! Loop through each character in the line
            select case (line(i:i))
                case ("'", '"')     ! Toggle in and out of strings
                    if (top > 0) then
                        if (stack(top) == line(i:i)) top = top - 1
                    else
                        ! Start of new string
                        top = top + 1
                        if (top > 100) error stop "Failed: stack overflow."
                        stack(top) = line(i:i)
                    end if
                case ("!")  ! Detect exclamation mark only if we are outside any string
                    if (top == 0) then
                        has_trailing_comment = i
                        return
                    end if
            end select
        end do
        ! If we reach here, there was no exclamation outside a string
        has_trailing_comment = 0
    end function

end program

One caveat is the program doesn’t handle continued lines. For instance:

  character(len=*), parameter :: msg = "hello!" ! okay
  character(len=:), allocatable :: test
  test = "continued& 
 & line!" ! fails

A second caveat is the line length is limited to 132 characters. There may be other corner cases that fail too.

I think such tools could form a collection perhaps named sftools or sfutils (Small Fortran Tools/Utilities). This type of software is advocated in the book Software Tools (1976) by Kernighan and Plauger. You could see it as an application of the Unix philosophy to Fortran editing. A few other tools I can imagine:

• fdetab - convert tabs to spaces
• fconvert - convert case
• fstats - code statistics
• fenum - print enumerated lines (e.g. for pasting into messages)

[urbanjost]

GitHub - urbanjost/apps: utility programs using fpm(1) and the General...

has flower, which was originally for “Fortran lowercase” . It is mentioned above. The program is very short if using fpm and dependencies, but the link in the earlier discussion is to a single-file version that has the full modules as well, so it looks large initially. But it expands tabs, can change code case while ignoring comments in free-format code and provides minimal code statistics. In the apps repository above are several other codes including fsplit and f90split,
xpand (expands tabs like the GNU expand command) and just added the txt2f90 command which might be included or inspire some initial entries.

I have been hoping the fpm repository would include a section for such utility programs but that does not appear to be near fruition that I am aware of.

nd (numeric differences) could stand an update but might fall into the small Fortran tools.
fman/fpm-man can display Fortran intrinsic descriptions in a platform-agnostic manner, although also available as HTML and man-pages where available (TDU browsers like md3, lynx, links can view the descriptions from a CLI environment that has www access).

The “funix” subdirectory is a collection of Fortran codes that approximate Unix/GNU commands
that are meant as examples of using Fortran and fpm and fpm dependencies but some of the commands might be useful on MSWindows envronments. A few have more features than the GNU versions, some have less. Even a basic command like grep- might be useful in some environments.

If anyone wants to start such a tool collection those would be some candidates I could provide to help seed it. Since they are all Fortran codes and can be built with fpm I think they would be suitable.

COCO is licensed liberally enough I think it could be included. Not sure, but I think so.
There are others on the lists from @Beliavsky too of course, although I have no idea if the owners would be interested in contributing to a consolidated site.

[Beliavsky]

I would like to have a tool that creates specialized versions of a subroutine with fewer arguments and simpler logic within the subroutines. For example, the famous dgemm.f matrix multiplication subroutine in BLAS starts with

      SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,
     +         BETA,C,LDC)
*
*  -- Reference BLAS level3 routine --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)

TRANSA and TRANSB are character arguments but ought to be logical variables. Often ALPHA will be 1 and BETA will be 0, giving a plain matrix multiplication of the transposed matrices without the original factors. It would be nice to have a tool that takes the original subroutine and creates variants such as

dgemm_transa_true_transb_true_alpha_1_beta_0

etc. that programs could call instead of the original. Ideally the tool would replace the calls to the general subroutine with calls to the specific ones, which are named by the removed arguments. The BLAS were written in Fortran 77, but even modern Fortran subroutines have optional arguments and flags that determine which calculations are done and which could be written as specialized subroutines for speed and clarity. OTOH, having many similarly named subroutines would create clutter.

[certik]

@Beliavsky good idea, I made this Add a pass to "partially specialize" some function arguments · Issue #5384 · lfortran/lfortran · GitHub. I think ASR is perfect for these kinds of code transformations.

[urbanjost]

It is not generally considered intuitively obvious how to create stdin filters using Fortran. Because of weaknesses in the system interfaces Fortran is often maligned as not having good string manipulation capabilities. So here is a little module that creates a standard character array from plain text read from stdin and a few programs illustrating how this allows for creating filters with just a few lines of code.

https://fortranwiki.org/fortran/show/M_slurp

[wspector]

@urbanjost

It is not generally considered intuitively obvious how to create stdin filters using Fortran…

If only more Fortran compilers had implemented the POSIX 1003.9-1992 Fortran bindings back in the 1990s… One could simply use PXFFDOPEN to open a file descriptor onto a Fortran unit. Then either use normal Fortran READ/WRITE, or use PXFFGETC and PXFFPUTC for character-at-a-time I/O.

Cray, and then the Cray derived compilers for SGI IRIX supported the PXF calls for many years. Intel Fortran supports the PXF calls too. (I sent them a number of bug reports back when they first started supporting PXF.) But I’m not sure who else these days.

[urbanjost]

Yes. A huge opportunity missed for bad reasons. We maintained our own standard library so the vast majority of programmers had such routines available internally. It was maintained by the HPC and math sections and is diminished but still in use today. But we made a big push to get everyone using the PXF routines on the Crays in anticipation they would become a full part of the standard, along with the varying string length standard. None of it materialized on the other platforms and (oddly) we made our own PXF look-alikes for the other platforms almost exclusively calling their existing platform-specific extensions (so doing so themselves was quite plausible).

[rwmsu]

A few months back when I was doing my forIGES project which is almost 90 percent reading files and manipulating strings, I was impressed by two things.

1. Just how much more powerful Fortran’s string processing capabilities are than most folks think they are. You just have to think a little more about how you want to use them and how some things get implemented.
2. How lacking they are in some areas and could be greatly improved with a little effort to add a few more utilities beyond the ones added in F23. I haven’t really looked at what is in F23 though. Did something like toupper and tolower to change case ever make it in?

[urbanjost]

No, although for some reason I thought they had. Good candidates for procedures most times reinvented by users.

split and tokenize made it, but toupper, tolower and sort did not.

My own collection is in GPF; mostly in the M_strings module.

As a homage to toupper and tolower I added those filters on the Wiki page as well. I was trying not to overload it too much, but on second thought how can I leave those out?

If toupper and tolower were intrinsics and using the M_swap module the filter program is basically three executable lines plus a few lines of infrastructure, so it is hard to argue Fortran cannot handle character variables well.

[rwmsu]

@urbanjost

Good candidates for procedures most times reinvented by users.

I’ve wondered (wished actually) if there is a way to search a large database of programs and identify procedures or code fragments that are “reinvented by users” and use that to build a case for including some capability into the standard. I assume there is not unless it could be done with modern AI tools. One I would like to see is adding an option to INQUIRE to report the number of records in a record delimited file instead of having to write the same albeit small loop that counts records and exits when it finds an EOF that appears in some form in the majority of Fortran codes ever written.

[urbanjost]

A real web crawl might be a bit overwhelming, but at least a github/gitlab search is feasible. github and gitlab provide APIs that can be used for a search of many active codes. Netlib would also be an easy search although probably not as useful for that specific type of info not being as active and very heavily oriented towards primarily higher-level numeric-related procedures. Just searching the packages listed as fpm packages might be interesting but perhaps not yet a big enough sample size. But I am sure a toupper, tolower, and sort would be very high on any list and those have not made it yet. I think the fortran-stdlib project approach or fpm repository packages are the most active attempt to resolve that currently. Hopefully with a better fate than the PXF and varying string projects!

Searching the projects listed by @Beliavsky would be feasible and those are quite active for the most part so that might be a good do-able data pool.