~hwkrus/f03gl/trunk

#!/usr/bin/perl -w

#  Copyright 2009 Anthony Stone and Aleksandar Donev

#  This file is part of f03gl.

#

#  f03gl is free software: you can redistribute it and/or modify

#  it under the terms of the GNU General Public License as published by

#  the Free Software Foundation, either version 3 of the License, or

#  any later version.

#

#  f03gl is distributed in the hope that it will be useful,

#  but WITHOUT ANY WARRANTY; without even the implied warranty of

#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

#  GNU General Public License for more details.

#

#  You should have received a copy of the GNU General Public License

#  along with f03gl (see file COPYING). If not, see

#  <http://www.gnu.org/licenses/>.

#  Construct a file of Fortran interfaces for the GLUT parameters and

#  procedures, using the GLUT.h header file as the starting-point.

$verbose=1;

$private=1;

$infile="OpenGLUT.h";

$module="f03gl";

$bozinit=0;

$no_dimension=0;

$command_line="$0 ".join(" ",@ARGV);

while (@ARGV) {

  $flag=shift;

  $verbose=0, next if $flag eq "-q";

  $verbose=1, next if $flag eq "-v";

  $private=1, next if $flag eq "--private";

  $infile=shift, next if $flag eq "-i";

  $bozinit=1, next if $flag eq "--bozinit";

  $no_dimension=1, next if $flag eq "--scalar";

  $module=shift, next if $flag eq "-m" or $flag eq "--module";

  &help, exit if $flag eq "--help";

  print "$flag not recognised\n";

  &help; exit;

}

#  Lookup table of Fortran equivalents to C argument types

%map = (

int        => "INTEGER(GLint)",

short      => "INTEGER(C_SHORT)",

float      => "REAL(C_FLOAT)",

double     => "REAL(C_DOUBLE)",

"unsigned int" => "INTEGER(GLuint)",

"char"   =>  "CHARACTER(C_CHAR)",

"char**"  =>  "TYPE(C_PTR), INTENT(IN)",

"unsigned char" => "INTEGER(GLbyte)",

"unsigned char*" => "CHARACTER, DIMENSION(*)",

GLint      => "INTEGER(GLint)",

GLuint     => "INTEGER(GLuint)",

GLenum     => "INTEGER(GLenum)",

GLboolean  => "INTEGER(GLboolean)",

GLbitfield => "INTEGER(GLbitfield)",

GLbyte     => "INTEGER(GLbyte)",

GLubyte    => "INTEGER(GLubyte)",

GLshort    => "INTEGER(GLshort)",

GLushort   => "INTEGER(GLushort)",

GLsizei    => "INTEGER(GLsizei)",

GLfloat    => "REAL(GLfloat)",

GLdouble   => "REAL(GLdouble)",

GLclampf   => "REAL(GLclampf)",

GLclampd   => "REAL(GLclampd)",

"void*"   => "TYPE(C_PTR)",

"void(*)" => "TYPE(C_FUNPTR)",

GLUTproc => "TYPE(C_FUNPTR)"

);

if ($private) {

  $ACCESS="PRIVATE";

  $PARAMETER="PARAMETER, PUBLIC";

  $PUBLIC=", PUBLIC";

}

else {

  $ACCESS="PUBLIC";

  $PARAMETER="PARAMETER";

  $PUBLIC="";

}

open (STDIN,$infile) or die "Can't open $infile";

open (STDOUT,">${module}_glut.f90") or die "Can't open ${module}_glut.f90 for output";

print "MODULE ${module}_glut

!  Derived from $infile using

!  $command_line

USE ${module}_kinds

IMPLICIT NONE

$ACCESS

";

$contained_wrappers="";

while (<>) {

  if ( /^#ifdef __cplusplus/ ) {

    #  Strip everything up to #endif (crude!)

    while (<>) {

      last if /^#endif/;

    }

  }

  if ( /^\s*$/) {

    #  Copy blank lines

    print "\n";

  }

  elsif ( m+^/\* *(.*) *\*/$+ ) {

    #  Copy one-line comments in Fortran form

    print "!  $1\n";

  }

  elsif ( m+^/\*+ ) {

    while (<>) {

      #  Copy multi-line comments

      last if m+\*/+;

      s/^ *\* *//;

      print "!  "; print;

    }

  }

  elsif ( /^#define +(\w+)\s+(.+)$/ ) {

    #  Parameter values

    $name=$1;

    $value=$2;

    if ( $value =~ /^0x(\w*)/ ) {

      if ( $bozinit ) {

        #  Convert to Fortran z'...' form

        $value=~s/0x(\w+)/z'$1'/;

      }

      else {

        #  Convert to decimal integer

        $value=oct($value);

      }

      print "INTEGER(GLenum), $PARAMETER :: $name = $value\n";

    }

    elsif ( $value =~ /^(\w+)$/ )  {

      print "INTEGER(GLenum), $PARAMETER :: $name = $value\n";

    }

    else {

      #  Unknown #define

      print "! ???, $PUBLIC :: $name=$value\n";

      # print "TYPE(C_PTR), BIND(C), PROTECTED$PUBLIC :: $name\n";

    }

  }

  elsif ( s/^ *extern +// || s/^\w*API +// ) {

    #  Is it a procedure definition?

    if ( /\w+APIENTRY/) {

      #  Make sure we have the whole thing

      while ( !/;$/ ) {

	chomp;

	$_.=<>;

      }

      #  Pass to subroutine with initial "extern" or "GLUTAPI" or "OGAPI"

      #  or "FGAPI" keyword now stripped

      $depth=0;

      $callback_wrapper=0; # Automatically generate the wrapper for glut callback functions

      &procdef($_);

      print "\n";

    }

  }

  else {

    #  Ignore

  }

}

print "END INTERFACE\n\n" unless $private;

# Manual handling

print "

! Font variables in GLUT_fonts.c

TYPE(C_PTR), BIND(C), PUBLIC, PROTECTED :: GLUT_STROKE_ROMAN,         &

    GLUT_STROKE_MONO_ROMAN, GLUT_BITMAP_9_BY_15, GLUT_BITMAP_8_BY_13, &

    GLUT_BITMAP_TIMES_ROMAN_10, GLUT_BITMAP_TIMES_ROMAN_24,           &

    GLUT_BITMAP_HELVETICA_10, GLUT_BITMAP_HELVETICA_12,               &

    GLUT_BITMAP_HELVETICA_18

! A special callback function for compatibility with f90gl

TYPE(C_FUNPTR), PUBLIC, SAVE :: GLUT_NULL_FUNC=C_NULL_FUNPTR

CONTAINS

SUBROUTINE glutInit_f03()

  INTEGER(C_INT) :: argcp=1

  TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR

  CHARACTER(C_CHAR), DIMENSION(1), TARGET :: empty_string=C_NULL_CHAR

  ! A hack

  INTERFACE

   SUBROUTINE SetNullFunc() BIND(C,NAME='SetNullFunc')

   END SUBROUTINE

  END INTERFACE  

  argv(1)=C_LOC(empty_string)

  CALL glutInit_gl(argcp, C_LOC(argv))

END SUBROUTINE

$contained_wrappers

";

print "

END MODULE ${module}_glut

";

sub procdef {

  #  Procedure definition

  my $c_defn=$_[0];

  %declare=();

  local %interface=();

  my $procname="";

  my $proctype="";

  my $wrapper=0; # No wrapper--direct interface

  my $my_args="";

  $depth++;

  # return if $c_defn=~/^void *\*\w+;/;

  $c_defn=~s/\w*APIENTRY *//;  #  remove OGAPIENTRY etc.

  #  $c_defn=~s+ */\*.*\*/++;

  $c_defn=~s/ *; *$//;  #  Remove trailing semicolon

  print "!  $c_defn";

  ($return,$star,$procname,$param_list)=($c_defn=~/^(\w+) *(\*?|\(\*\)) *(\w+) *\((.*)\)$/);

  print STDERR "\n$procname\($param_list\)\n" if $verbose;

  ($return_type,$proctype)=&handle_return($return,$star);

  &handle_params($param_list);

  $my_args=$args; # Save a local copy of the argument list

  print "PUBLIC $procname\n" if $depth==1;

  if ( $depth==1 ) {

     if ( $procname =~ /glut\w*Func/ && $procname !~ /glutForceJoystickFunc/ ) 

     {

       print STDERR "Generating wrapper for $procname!\n";

       $callback_wrapper=1;

       $wrapper=1;

     }

     elsif ( $procname =~ /glutInit\b/ ) {

       $wrapper=1; # We supply a manual wrapper for this one

     }

  }

  if($callback_wrapper and ($depth>1)) {

     $callback_name=$procname;

     print "TYPE(C_FUNPTR), VALUE :: $procname\n";

     $contained_wrappers.="INTERFACE\n";

     $contained_wrappers.="$proctype $procname($args) BIND(C)\nIMPORT\n";

  }  

  else

  {

     if($wrapper) {

       print "INTERFACE ${procname}\n"; # The generic wrapper

       print "MODULE PROCEDURE ${procname}_f03\n";

       print "END INTERFACE ${procname}\n";

       print "INTERFACE\n"; # The C GLUT function

       print "$proctype ${procname}_gl($args) ";    

     }

     else {

       print "INTERFACE\n";

       print "$proctype $procname($args) ";

     }

     if ( $depth==1 ) {

       print qq+BIND(C,NAME="$procname")\nIMPORT\n+;

     }

     else {

       print "BIND(C)\nIMPORT\n";

     }

  }  

  if($callback_wrapper and ($depth==1)) { $contained_wrappers.="$proctype ${procname}_f03($args)\n"; }

  if ($proctype eq "FUNCTION") {

     if (not ($callback_wrapper and ($depth>1))) {

        print "$return_type :: $procname\n" ; 

     }

     if($callback_wrapper) { $contained_wrappers.="$return_type :: $procname\n"; }

  }   

  foreach (sort keys %declare) {

    $vars=$declare{$_};

    if (/DIMENSION\(\*\)/) {

      $dummy=$_;

      if ( $no_dimension && !/^CHARACTER/ ) {

	s/, *DIMENSION\(\*\)//;

      }

      else {

	$dummy=~s/, *DIMENSION\(\*\)//;

      }

      print "! $dummy :: $vars\n";      

    }

    if (not ($callback_wrapper and ($depth>1))) { print "$_ :: $vars\n"; }

    if($callback_wrapper) { $contained_wrappers.="$_ :: $vars\n"; }

  }

  for (keys %interface) {

    # print STDERR "$interface{$_}\n" if $verbose;

    &procdef($interface{$_});

  }

  if ($callback_wrapper and ($depth>1)) {

    $contained_wrappers.="END $proctype ${procname}\n";

    $contained_wrappers.="END INTERFACE\n";

  }

  else

  {

     if($wrapper) {

       print "END $proctype ${procname}_gl\n";

     }

     else {

       print "END $proctype $procname\n";

     }

     print "END INTERFACE\n";

  }

  if($callback_wrapper and ($depth==1)) {

     $c_loc_args=$my_args;

     $c_loc_args=~s/$callback_name/C_FUNLOC($callback_name)/;

     $c_null_args=$my_args;

     $c_null_args=~s/$callback_name/C_NULL_FUNPTR/;

     $contained_wrappers.=

"OPTIONAL :: $callback_name

IF(PRESENT($callback_name)) THEN

   CALL ${procname}_gl($c_loc_args)

ELSE

   CALL ${procname}_gl($c_null_args)

END IF

END $proctype ${procname}_f03\n";

  }

  $depth--;

}

sub handle_return {

  my $s=$_[0];

  my $star=$_[1];

  $s=~s/ +$//;

  if ($s eq "void" && $star eq "") {

    $proctype="SUBROUTINE";

    $return_type="";

  }

  else {

    $proctype="FUNCTION";

    $type=$s.$star;

    if ( ! defined($map{$type}) ) {

      print STDERR "return type $type not defined\n";

      $map{$type}="*** $type";

    }

    $return_type=$map{$type};

    #  VALUE attribute not possible for function result

    $return_type=~s/, VALUE//;

  }

  ($return_type,$proctype);

}

sub handle_params {

  my $param_string=$_[0];

  my $variable="";

  my $qualifiers="";

  my $intent="";

  my $value=1;

  $args="";

  my $a=0;

  #  Cycle while $param_string non-blank

  while ( $param_string!~/^\s*$/ ) {

    $variable="";

    $qualifiers="";

    $intent="";

    $value=1;

    last if $param_string=~/^ *void *$/;  #  Subroutine with no parameters

    $type="";

    while ( 1 ) {

      #  Extract type part of parameter specification

      ($word,$param_string)=($param_string=~/(\w+)\b *(.*)/);

      if ( $word eq "const" ) {

	$intent=", INTENT(IN)";

	$value=0;

	next;

      }

      elsif ( $word eq "unsigned" ) {

	#  Append to type string and loop

	$type.="$word ";

	next;

      }

      #  Otherwise append to type string and proceed

      $type.=$word;

      last;

    }

    #  Look for * or ** or (*) or (* callback); strip off if present.

    if ( $param_string=~s/^(\*+|\(\*( callback)?\)) *//i ) {

      $tag=$1;

      if ( $tag eq "(*)" || $tag=~/\(\* *callback\)/i ) {

	#  (*) or (* callback) means an un-named procedure -- give it a name ...

	$variable="proc";

	#  Remember its name and return type

	$interface{$variable}="$type $variable";

	#  ... and attach its arguments

	$param_string=~s/(\([^\)]+\))//;

	$interface{$variable}.="$1\n";

	$type="";

	print STDERR "$interface{$variable}\n" if $verbose;

      }

      elsif ( $type eq "char" && $tag eq "**" || $type eq "unsigned char"

	      || $type eq "void" ) {

        #  Append to type string

	$value=0 unless $type eq "void";

	$type.="$1";

      }

      else {

	$qualifiers.=", DIMENSION(*)";

	$value=0;

      }

    }

    elsif ( $param_string=~s/^\(\w*(CALLBACK)? *\*(\w+)\)//i ) {

      #  Callback procedure; the word is its name

      $variable=$2;

      $interface{$variable}="$type $variable";

      #  Attach its arguments

      $param_string=~s/(\([^\)]+\))//;

      $interface{$variable}.="$1\n";

      $type="";

      print STDERR "$interface{$variable}\n" if $verbose;

    }

    #  The parameter name is the next word, unless we have already

    #  assigned a name

    if (  $variable eq "" ) {

      if ($param_string=~/^(\w+)(.*)/) {

	($variable,$param_string)=($param_string=~/^(\w+)(.*)/) if $variable eq "";

      }

      else {

	#  No parameter name provided (usually because this is an

	#  argument of a callback). Invent one.

	$a++;

	$variable="arg$a";

      }

    }

    #  If [dimen] follows, it is an array dimension

    if ( $param_string=~s/^\[(.*?)\]// ) {

      $qualifiers=", DIMENSION($1)";

      $value=0;

    }

    #  If a comma follows, this is not the last parameter. Extract

    #  the separator.

    if ( $param_string=~s/^, *// ) {

      $sep=", ";

    }

    else {

      $sep="";

    }

    if ($value) {

      $qualifiers.=", VALUE";

    }

    else {

      $qualifiers.=$intent;

    }

    #  Append the argument name and separator to the argument string

    $args.="$variable$sep";

    #  Get the Fortran declaration for this parameter type from the

    #  lookup table.

    if ( $type ) {

      if ( defined($map{$type}) ) {

	$param_type=$map{$type};

	if ( defined($declare{"$param_type$qualifiers"}) ) {

	  #  Add this variable to an existing declaration

	  $declare{"$param_type$qualifiers"}.=", $variable";

	}

	else {

	  #  New declaration

	  $declare{"$param_type$qualifiers"}="$variable";

	}

      }

      else {

	print STDERR "Parameter type $type unknown\n";

      }

    }

  }

}

sub help {

  print qq+

Usage: $0 [-v | -q] [-i inputfile] [-m module | --module module] [--bozinit] [--scalar]

Translate the inputfile (default OpenGLUT.h) into a Fortran 2003 module

file.

The -m or --module option gives the base name of the module file.

The default is f03gl, so that the full name becomes f03gl_glut.f90.

-v (verbose) gives more output, -q suppresses it.

--bozinit :

hexadecimal parameter values are left in hex

but expressed in Fortran BOZ notation, i.e. z'...' instead of 0x...

Otherwise they are converted to decimal. This is not the default, since

BOZ constants are not allowed in initialisation expressions in standard

Fortran 2003, but some compilers accept them.

--scalar:

C declarations such as "int* v" describe a pointer to an entity v

which may be a scalar or an array. In Fortran it is necessary to

specify which is required. The attribute "DIMENSION(*)" is provided

unless this flag is present. In either case the alternative form is

also provided but is commented out. Exception: char* is always

translated to "CHARACTER(C_CHAR), DIMENSION(*)".

+;

}