#!/usr/bin/env ruby
require 'optparse'
################################################################
# CONFIGURATION:
CFTypeInfo             = {
  'int'                  => {:namedConst       => 'c_int'                , :ftype => 'integer'},
  'short int'            => {:namedConst       => 'c_short'              , :ftype => 'integer'},
  'long int'             => {:namedConst       => 'c_long'               , :ftype => 'integer'},
  'long long int'        => {:namedConst       => 'c_long_long'          , :ftype => 'integer'},
  'signed char'          => {:namedConst       => 'c_signed_char'        , :ftype => 'integer'},
  'unsigned char'        => {:namedConst       => 'c_signed_char'        , :ftype => 'integer'},
  'size_t'               => {:namedConst       => 'c_size_t'             , :ftype => 'integer'},
  'int8_t'               => {:namedConst       => 'c_int8_t'             , :ftype => 'integer'},
  'int16_t'              => {:namedConst       => 'c_int16_t'            , :ftype => 'integer'},
  'int32_t'              => {:namedConst       => 'c_int32_t'            , :ftype => 'integer'},
  'int64_t'              => {:namedConst       => 'c_int64_t'            , :ftype => 'integer'},
  'int_fast8_t'          => {:namedConst       => 'c_int_fast8_t'        , :ftype => 'integer'},
  'int_fast16_t'         => {:namedConst       => 'c_int_fast16_t'       , :ftype => 'integer'},
  'int_fast32_t'         => {:namedConst       => 'c_int_fast32_t'       , :ftype => 'integer'},
  'int_fast64_t'         => {:namedConst       => 'c_int_fast64_t'       , :ftype => 'integer'},
  'int_least8_t'         => {:namedConst       => 'c_int_least8_t'       , :ftype => 'integer'},
  'int_least16_t'        => {:namedConst       => 'c_int_least16_t'      , :ftype => 'integer'},
  'int_least32_t'        => {:namedConst       => 'c_int_least32_t'      , :ftype => 'integer'},
  'int_least64_t'        => {:namedConst       => 'c_int_least64_t'      , :ftype => 'integer'},
  'intmax_t'             => {:namedConst       => 'c_intmax_t'           , :ftype => 'integer'},
  'intptr_t'             => {:namedConst       => 'c_intptr_t'           , :ftype => 'integer'},

  'float'                => {:namedConst       => 'c_float'              , :ftype => 'real'},
  'double'               => {:namedConst       => 'c_double'             , :ftype => 'real'},
  'long double'          => {:namedConst       => 'c_long_double'        , :ftype => 'real'},

  'float _Complex'       => {:namedConst       => 'c_float_complex'      , :ftype => 'complex'},
  'double _Complex'      => {:namedConst       => 'c_double_complex'     , :ftype => 'complex'},
  'long double _Complex' => {:namedConst       => 'c_long_double_complex', :ftype => 'complex'},
  '_Bool'                => {:namedConst       => 'c_bool'               , :ftype => 'logical'},
  'char'                 => {:namedConst       => 'c_char'               , :ftype => 'character'}
}
# how the module should be invoked from fortran
ModuleName    = 'mo_cdi'
# which conversion is to use generating the fortran routine names, this could
# be any ruby String method.
FNameMethod   = :noop
# FNameMethod = :downcase
# FNameMethod = :noop
# FNameMethod = :upcase
class String;def noop;self;end;end
# fortran subroutines are not allowed to have a parameters with the same name,
# so in case of a match, these parameters have to get an new name
FParamExtension = 'v'
# Naming convention from above: 
# all non scalar variables should have the postfix '_vec' in there name
Vectors = /_vec$/i
################################################################################
FortranMaxLineLength = 132
# read the c header file and grep out name, return type and paramterlist of
# each function
def getFuncInfo(filename)
  typelist = %w[char int float double void]
  funclist = IO.popen("cpp #{filename} | cpp -fpreprocessed").readlines.delete_if {|line| not line.index('#').nil?}.collect {|line| line.chomp}
  # delete everything, that do not look like a function prototype
  typeRegexp = /^.*(#{typelist.join('|')}) \**\w+\(.*\)/
  funclist.delete_if {|line|
    not typeRegexp.match(line.lstrip)
  }
  funclist.collect! {|line|
    md = /(\w+)+ +(\**)(\w+)\((.*)\)/.match(line)
    returnType, returnPointer, funcName, paramList = md[1,4]
    paramList = paramList.split(',').collect {|p| p.split(' ').each {|_p| _p.strip}}
    [funcName, returnType, returnPointer,  paramList]
  }
  funclist
end

# grep the #define C-Constants, which should be available within the fortran CDI API
def getDefines(filename)
  defines = File.open(filename,'r').readlines.grep(/^#define/).collect {|line|
    md = / +(\w+) +(-*\d+)/.match(line)
  }.select {|item| not item.nil?}.collect {|match| match[1..2]}
end

# create continuation for lines longer that 132 sign, which would create an
# error with some fortran compilers
def genContinuation(iline)
  # leave the input untouched
  line = iline
  # try to create readable line breaks, i.e. do not split name, labels or keywords
  regexp = /,[^,]*$/

  matchIndex = line[0,FortranMaxLineLength] =~ regexp

  if matchIndex.nil?
    line[FortranMaxLineLength-2] = "&\n"+line[FortranMaxLineLength-2,1]+"&"
  else
    line[matchIndex] = ",&\n" + ' '*7
  end
  line
end


# create fortran module variables
def genModVars(vars)
  vars.collect {|var, value|
    "      integer :: #{var} = #{value}"
  }.join("\n")
end

# return the fortran version of the c parameters (name, named constant within
# iso-c-bindig, fortran type)
def fortranParamsWithTypes(paramList)
  paramList.collect {|paramInfo|
    ctype, param = paramInfo[-2,2]
    ftype, nc    = CFTypeInfo[ctype][:ftype], CFTypeInfo[ctype][:namedConst]
    # fortran parameters can be configured out of the c parameters
    [param.send(FNameMethod),nc,ftype, paramInfo.include?('const')]
  }
end
def startMod(name)
  "
module #{name}
      use, intrinsic :: iso_c_binding

      implicit none

      private
  "
end
def endMod(name)
  "
end module #{name}
  "
end
def isBadFunction(returnType, returnPointer, paramList)
  return true if (
    # external return type
    (returnType != 'void' and not CFTypeInfo.keys.include?(returnType)) or
    # pointer2pointer return type
    returnPointer.length > 1
  )
  paramList.each {|paramInfo|
    next if paramInfo == ['void']
    ctype, param = paramInfo[-2,2]
    return true if (
      CFTypeInfo[ctype].nil? or                        # derived data type 
      param[0,2] == '**' or                            # pointer2pointer
      (param[0,1] == '*' and /\w\[\d*\]/.match(param)) # array of pointers
    )
  } 
  return false
end

def hasDimension(paramName, paramFType)
  return true if paramFType == 'character'
  return true if ( %w[integer real].include?(paramFType) and Vectors.match(paramName) )
  return false
end

# collect further information about the original c type of the params and
# in case of a match between param name and function name, the parameter name
# is changed
def setFortranParams(paramswithtypes,fFuncname)
  # special treatment of empty parameter list
  return [[],[]] if paramswithtypes == [[]]

  originalParameters = paramswithtypes.transpose[0]
  paramswithtypes.collect {|param, paramCType, fType, isConstant|
    # test for pointers/arrays
    isPointer, isArray, arraySize = false, false, nil
    if param[0,1] == '*'
      isPointer = true
      # remove '*' from funcnames and paramnames
      param.sub!('*','')
    end
    if ( md = /\w\[(\d*)\]/.match(param); not md.nil? )
      isArray   = true
      arraySize = md[1] == '' ? '*' : md[1]
      param.tr!("[#{md[1]}]",'')  
    end

    # change param name if it equals the funcname
    if param == fFuncname or param.downcase == fFuncname.downcase
      param += FParamExtension 
      # but maybe the result is the name of another parameter. -> play it again sam...
      param += FParamExtension while ( originalParameters.include?(param) )
    end

    [param,paramCType,fType,isPointer,isArray,arraySize,isConstant]
  }
end

# creates the actual binding within the module for the given c function
# unsupported types of function a ignored, see RESTRICTIONS (top) for details
def genInterface(cFuncname, returnType, returnPointer, paramList)

  # do not create interfaces for unsuppoerted function
  if isBadFunction( returnType, returnPointer, paramList)
    warn "parameterlist of '#{cFuncname}' is not supported -> function ignored."
    return ['',''] 
  end
  # the void argument type can be left out: if 'void' occures in the
  # parameterlist (which is only the case, if it is the only parameter
  # information), it is simply removed and a empty paramter list is left.
  paramList = [[],[]] if paramList.flatten.include?('void') or paramList.flatten.empty?

  out = ''

  # create new names for the fortran routines, see CONFIGURATION (top)
  fFuncname = cFuncname.send(FNameMethod)

  paramsWithTypes = []
  # divide between empty and non empty parameter lists
  if paramList == [[],[]]
    fParams, fParams4Import, fTypes4Import = [], [],[]
  else
    # collect information for setting the correct fortran type for each parameter
    paramsWithTypes = paramList.collect {|paramInfo|
      ctype, param = paramInfo[-2,2]
      ftype, nc    = CFTypeInfo[ctype][:ftype], CFTypeInfo[ctype][:namedConst]
      # fortran parameters can be configured out of the c parameters
      [param.send(FNameMethod),nc,ftype, paramInfo.include?('const')]
    }

    # get deeper information about parameterlists and filter out functions with
    # non supported parameters
    fParams = setFortranParams(paramsWithTypes,fFuncname)
    fParams4Import, fTypes4Import, = fParams.transpose
  end

  fReturnInfo                    = CFTypeInfo[returnType]
  if not fReturnInfo.nil?
    fReturnString = "#{fReturnInfo[:ftype]}(#{fReturnInfo[:namedConst]}) function"
    fEndString    = "end function"
    fTypes4Import << fReturnInfo[:namedConst]
  elsif returnType == 'void'
    fReturnString = "subroutine"
    fEndString    = "end subroutine"
  end

  out << "
      interface
        #{fReturnString} #{fFuncname}(#{fParams4Import.join(',')}) bind(c,name='#{cFuncname}')
  "       
  out << "        import :: #{fTypes4Import.uniq.join(',')}
  " unless fTypes4Import.empty?

  fParams.each {|param,paramType,ftype,ispointer,isarray,arraysize,isconstant|
    dimension     = isarray ? "dimension(#{arraysize})" : ( (ispointer and hasDimension(param, ftype) ) ? 'dimension(*)' : nil)
    intent, value = nil, nil
    if (ispointer or isarray) 
      if not isconstant
        intent = 'intent(out)'
      else
        intent = 'intent(in)'
      end unless paramType == 'c_char'
    else
      #intent = 'intent(in)'
      value  = 'value'
    end

    typeinfo = [value,intent,dimension].select {|s| ! s.nil?}.join(',')
    out << "        #{ftype}(#{paramType}), #{typeinfo} :: #{param}\n  "
  }

  out << 
  "     #{fEndString} #{fFuncname}
      end interface
  "
  [out, makePublic(fFuncname)]
end
def makePublic(*fFuncnameList)
  fFuncnameList.collect {|fname| 
    "      public :: #{fname.tr('*','')}"
  }.join("\n") << "\n"
end
def ctrim
  "
    subroutine ctrim(str)
    use iso_c_binding
    character(kind=c_char, len=*)  :: str
    character                      :: c
    integer                        :: i

    do i=1,len(str)
      c = str(i:i)
      if (c == c_null_char) then
        str(i:len(str)) = ' '
      end if
    end do

    end subroutine ctrim
  "
end
################################################################################
if __FILE__ == $0
require 'optparse'
require 'pp'

debug = false
OptionParser.new do |opts|
  opts.on("-d","--debug") {debug = true}
  opts.on_tail("--help","-h","-H","Display this help message.") do
    puts <<-'END'
#== Synopsis
# Create Fortran iso-c-bindings form a given c header file
# 
#== Usage
#   binGen.rb <headerFile> <fortranLibraryFile> [<modName>] [--help|--debug]  
#
# headerFile:
#   A general c header file: function prototypes and '#defines' with numerical
#   value will be taken for the fortran module construction. Furthermore there
#   are some restrictions to what is provided in fortran: Currently internal
#   datatypes and (arrays|pointers) to internal datatypes are supported, i.e.
#   no arrays of pointers, no pointer to pointers, no typedefs
#
# fortranLibraryFile:
#   file name for generated bindings
#
# modName:
#   This will be the name of the Fortran module, so it has to obey the fortran 
#   restriction for module names. default: mo_cdi
#  
#== Author
# Ralf Mueller, ralf.mueller@zmaw.de
#
#== RESTRICTIONS:
# ONLY SUPPORT FOR INTERNAL DATATYPES AND (ARRAYS|POINTERS) TO INTERNAL
# DATATYPES, I.E. NO ARRAYS OF POINTERS, NO POINTER TO POINTERS, NO TYPEDEFS
#
#=== Special: naming convention
# Pointers can have different sizes, which cannot be detetermined by parsing a
# function prototype. Therefor a convention according the parameter names can
# be used to take this decision precisely:
# * Pointers to numbers are expected to be scalars unless the name of the
#   parameter end with '_vec'
# * Pointers to char are allways referenced as vectors
#
#== LICENSE: 
# BSD License
#
#  Copyright (c) 2009-2012, Ralf Mueller (ralf.mueller@zmaw.de)
#  All rights reserved.
#  
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions are met:
#  
#      * Redistributions of source code must retain the above copyright notice,
#        this list of conditions and the following disclaimer.
#  
#      * Redistributions in binary form must reproduce the above copyright
#        notice, this list of conditions and the following disclaimer in the
#        documentation and/or other materials provided with the distribution.
#  
#      * The names of its contributors may not be used to endorse or promote
#        products derived from this software without specific prior written
#        permission.
#  
#  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
#  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
#  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
#  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
#  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
#  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
#  OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
END
  exit
  end
end.parse!

  if ARGV[1] == nil
    warn 'no outputile given'
    exit
  end

  outputString      = ''
  modname           = ARGV[2].nil? ? ModuleName : ARGV[2]

  cDefines          = getDefines(ARGV[0])
  pp cDefines if debug
  unless cDefines.empty?
    makeModVarsPublic = makePublic(*cDefines.transpose[0]) 
    moduleVariables   = genModVars(cDefines)
  end

  interfaces, makepublics, subroutines = '', '', ''

  getFuncInfo(ARGV[0]).each {| funcName, returnType, returnPointer, paramList|
    pp [funcName, returnType, returnPointer, paramList] if debug
    interface, makepublic = genInterface(funcName,returnType, returnPointer, paramList)
    interfaces  << interface
    makepublics << makepublic
  }

  # add a specialized trim for wierd c strings
  makepublics << makePublic('ctrim')
  subroutines << "contains\n"
  subroutines << ctrim

  File.open(ARGV[1],"w") {|f|
    [ startMod(modname),
      moduleVariables ||= '',
      interfaces,
      makepublics,
      makeModVarsPublic ||= '',
      subroutines,
      endMod(modname)
    ].join("\n").split("\n").each {|line| 
      # check the length of each line before writing to file
      if line.length > FortranMaxLineLength
        f << genContinuation(line) << "\n"
      else
        f << line << "\n"
      end
    }
  }

end
