#!/bin/sh
#
# f2cgen - generate Fortran interface routines from C source
#
# modification history
# --------------------
# 01c,25jul88,gae  changed strncpy() to bcopy().
# 01b,19feb88,dnw  fixed bug not terminating fortran strings with EOS.
#		   changed temp prefix from "t" to "_t_" and nbytes prefix
#		     from "n" to "_n_" to reduce possibility of conflict.
# 01a,08dec87,gae  written.
#
# SYNOPSIS
# f2cgen file.c
#
# DESCRIPTION
# The tool f2cgen extracts non-LOCAL functions and generates
# C function interface suitable for calling from Fortran.
# The C wrapper is printed on standard output.
#
# Functions which do not return the standard types are ignored,
# only char, short, int, long, float, and double are processed.
# Most parameters are converted to "int *".
# "char *" paramaters are left as is but special code is
# generated to convert non-null terminated Fortran strings to
# null terminated C strings.
#
# Unfortunately, f2cgen will process routines that are not useable
# from Fortran.  For example, bcopy (2) takes two buffers and a length;
# f2cgen will then create two new buffers copy the buffers into them
# and then call the C routine bcopy -- not exactly what the programmer
# had in mind.
#
# BUGS:
#
# 1. File formats
#
# Files must be formatted in Wind River style with a Modification
# History and a Module Description section at the beginning of the 
# file. If these are missing, f2cgen eats the rest of the file.
#
# Assemble language file routines must have routine headers which
# conform to the Wind River style also, otherwise they are eaten
# by f2cgen. The style is as follows:
#
# /*************************************************************************
# *
# * abs - absolute value of integer
# *
# * This routine returns the absolute value of i.
# *
# * SEE ALSO:
#  
# * int abs (i)
# *    FAST int i;
#  
# */
#
# Notice the two blank lines without stars ! Notice the space between the
# abs and ( ! Notice FAST int i rather than FAST i !
#
#
# 2. Beware of declarations on the same line:
#
#	char *str1, *str2;
#	int int1, int2;
#
# They don't work right !
#
#
# SEE ALSO: Fortran Application Note
#
#*/

tmp=/tmp/f2cgen$$
trap "rm -f $tmp; exit" 1 2 3 15

while (test $# -gt 1)
do
    case "$1" in
	-*)	echo "f2cgen: flag not recognized:" $1; exit 1;;
	*)	echo "usage: f2cgen file.c"; exit 1;;
	esac
    shift
done

if (test $# -ne 1) then
    echo "usage: f2cgen file.c"
    exit 1
fi

# remove path

name=`basename $1`

# remove trailing component, eg. ".c"

rootname=`expr $name : '\(.*\)\..*' '|' $name`

# create awk program found at end of this script

awk '/^#START_AWK$/,/^#STOP_AWK$/' $0 > $tmp

awk -f $tmp $1
rm -f $tmp

exit 0

#START_AWK

# f2cgen.awk - awk program to generate Fortran callable routines from C source

# the variable "s" holds the current state of the scan:
#
#   title  - get title line (initial state
#   mh0    - skip to start of modification history
#   mh     - skip to end of modification history
#   de0    - skip to start of module description
#   desc   - process module description
#   incl   - include section
#   
#   rtn    - skip to start of next routine
#   rtitle - skip to, and process, routine title line
#   rdesc  - skip to, and process, routine description
#   rsy0   - skip to start of routine synopsis, join lines
#   rsy1   - skip to start of routine synopsis
#   rsy	   - process routine synopsis


BEGIN 		{
		# initialize

		dbg = 0			# 1 = output debug stuff
		s = "title"		# initial state

		# initialize recognized function types

		i = 0
		types [++i] = "char"
		types [++i] = "short"
		types [++i] = "int"
		types [++i] = "long"
		types [++i] = "double"
		types [++i] = "float"
		}

dbg == 1	{
		print s "\n" $0
		}

# get ss = line without  leading '/* ' or '* ' and trailing '*/'
#     subhead  = subheading (all caps at beginning of line w/ optional ':')
#     subheadl = remainder of subheading line following ':'

		{
		# detab line

		nf = split ($0, words, "\t")

		if (nf == 0)
		    l = ""
		else
		    {
		    l = words[1]

		    for (i = 2; i <= nf; i++)
			l = l substr("        ", 1, 8-(length(l) % 8)) words[i]
		    }

		# strip off leading and trailing comment indicators

		if (l ~ /^\/\*/)
		    {
		    if (l ~ /^\/\* /)
			start = 4
		    else
			start = 3
		    }
		else if (l ~ /^\*/)
		    {
		    if (l ~ /^\* /)
			start = 3
		    else
			start = 2
		    }
		else
		    start = 1

		end = length (l)

		if (l ~ /\*\/$/)
		    end = end - 2

		# strip leading blanks

		while (substr (l, start, 1) == " ")
		    start++;

		ss = substr (l, start, end - start + 1)

		# check for sub heading line

		if ((ss !~ /^[A-Z][^a-z]*:/) && \
		    (ss !~ /^[A-Z][^a-z]*$/))
		    subhead = ""
		else
		    {
		    colon = index (ss, ":")

		    if (colon == 0)
			{
			subhead = ss
			subheadl = ""
			}
		    else
			{
			subhead = substr (ss, 1, colon - 1)

			subheadl = substr (ss, colon + 2)
			if (subheadl ~ /^ *$/)
			    subheadl = ""
			}
		    }
		}

# get module name and title: 1st line in file

s == "title"	{
		# first line of file should be a comment

		while ($1 !~ /^\/\*/)
		    next

		print "/* Generated by \"f2cgen\" from " FILENAME " */"
		print ""

		print "#include \"UniWorks.h\""
		print "#include \"memLib.h\""
		print "#include \"strLib.h\""
###		print "#include \"types.h\""
		print ""

		s = "mh0"
		next
		}

# skip modification history: skip, looking for 'modification history' then blank

s == "mh0"	{
		if (l ~ /modification history/)
		    s = "mh"
		next
		}

s == "mh"	{
		if (l ~ /^ *$/)
		    {
		    s = "de0"
		    xdesc = 0
		    }
		next
		}	

# get module description: ignore leading blank lines; turn capital lines
#	into subheadings; accumulate rest looking for '*/'

s == "de0"	{
		if (l !~ /^ *$/)
		    {
		    ignore = 0
		    s = "desc"
		    }
		}

s == "desc"	{
		# check for end of description section

		if (l ~ /^\*\//)
		    {
		    s = "incl"
		    next
		    }

		# check for description section missing entirely

		if (l ~ /^#include/)
		    {
		    print "ERROR: on line " NR ": module description missing."
		    exit
		    }

		next
		}

s == "incl"	{
		if (l ~ /\*\*\*\*\*\*\*\*\*\*/)
		    s = "rtn"

		if (l ~ /^#include/)
		    {
###		    if (l !~ /UniWorks.h/)
###			print l
		    next
		    }
		}	

# skip to routine start: skip looking for '**********'

s == "rtn"	{
		if (l ~ /\*\*\*\*\*\*\*\*\*\*/)
		    {
		    rtitle = ""; rname = ""; xrdesc = 0;
		    s = "rtitle"
		    }
		next
		}

# get routine title: skip looking for 1st non-blank line

s == "rtitle"	{
		if (ss !~ /^ *$/)
		    {
		    rtitle = ss; rname = $2; ignore = 0; s = "rdesc";
		    argc_usr = 0; argc_ret = 0; argc_add = 0; argc_tmp = 0;
		    xcode = 0; xcode2 = 0; argc_var = 0; varargs = -1;
		    oldl = ""
		    }
		next
		}

# get routine description: skip leading blank lines; make capital lines
#	be subheadings; accumulate rest looking for '*/' or blank line

s == "rdesc"	{
		# check for end of routine description

		if ((l ~ /^\*\//) || (l ~ /^ *$/))
		    {
		    s = "rsy0"
		    next
		    }

		# skip leading blank lines

		if (xrdesc == 0 && ss ~ /^ *$/)
		    next

		# check if VARARGS

		if (l ~ /VARARGS/)
		    {
		    varargs = substr (l, index (l, "VARARGS") + \
				length ("VARARGS"))
		    print ""
		    print "/* VARARGS " varargs " */"
		    next
		    }

		# suppress manual entry if NOMANUAL specified

		if (l ~ /NO[ _-]?MANUAL/)
		    {
		    s = "rtn"
		    next
		    }

		# check for sub heading and accumulate routine description
		# ignore INTERNAL sections

		if (subhead == "")
		    {
		    if (!ignore)
			rdesc[++xrdesc] = ss
		    }
		else
		    {
		    if (subhead ~ /^INTERNAL/)
			ignore = 1
		    else
			{
			if (subheadl != "")
			    {
			    rdesc[++xrdesc] = subhead
			    rdesc[++xrdesc] = subheadl
			    }
			else if (subhead ~ /^RETURN/)
			    rdesc[++xrdesc] = subhead
			ignore = 0
			}
		    }
		next
		}

# get routine synopsis: throw away local routines;

s == "rsy0"	{
		# skip to next non-blank line

		if (l ~ /^ *$/)
		    next

		if (index (l, ")") > 0)
		    {
		    # found the function declaration line
		    # quit processing of local functions,
		    # or types we can't handle, eg. struct's

		    l = oldl ss
		    n = split (l, words)

		    if (words[1] == "LOCAL" || words[1] == "static")
			{
			s = "rtn"
			next
			}
		    else
			s = "rsy1"
		    }
		else
		    {
		    oldl = oldl ss " "
		    next
		    }
		}

# check declared name matches title; accumulate rest looking for "{";
# then output new C routine

s == "rsy1"	{
		# change common WRS types to standard "int"

		if ((words[1] == "VOID") || \
		    (words[1] == "STATUS") || \
		    (words[1] == "BOOL"))
		    {
		    words[1] = "int"
		    }

		validtype = "FALSE"

		for (i = 1; length (types[i]) > 0; i++)
		    {
		    if (words[1] == types[i])
			{
			validtype = "TRUE"
			break;
			}
		    }

		if (validtype != "TRUE")
		    {
		    s = "rtn"
		    next
		    }

		# print forward declaration

		print ""
		print "IMPORT " words[1] " " words[2] "();"

		# save routine declaration line

		rtdecl = words[1] " " words[2] "_ ("
		rtname = words [2]

		if (words[1] == "char" && words[2] ~ /^\*/)
		    {
		    char_flag = "TRUE"

		    argd_tmp [++argc_tmp] = words [1] " *retVal;"

		    argd_ret[++argc_ret] = "char *retStr;"
		    args_ret[argc_ret]   = "retStr"
		    argd_ret[++argc_ret] = "int nretStr;"
		    args_ret[argc_ret]   = "nretStr"
		    rtdecl = rtdecl "retStr, nretStr, "
		    }
		else
		    {
		    char_flag = "FALSE"

		    argd_tmp [++argc_tmp] = words [1] " retVal;"
		    }


		# collect args

		if (words[3] != "()")
		    {
		    for (i = 3; i <= n; i++)
			{
			arg_s = index (words[i], "(")
			if (arg_s > 0)
			    arg_s++
			arg = substr (words[i], arg_s)

			arg_e = index (arg, ",")
			if (arg_e == 0)
			    arg_e = index (arg, ")")

			if (arg_e > 0)
			    arg_e--
			arg = substr (arg, 0, arg_e)

			if (varargs != -1 && arg == "args")
			    {
			    rtdecl = rtdecl "args, arg2, arg3, arg4, arg5"
			    argd_var [++argc_var] = "*arg2, *arg3, *arg4, *arg5"
			    argd_add[++argc_add] = "int *arg2;"
			    argd_add[++argc_add] = "int *arg3;"
			    argd_add[++argc_add] = "int *arg4;"
			    argd_add[++argc_add] = "int *arg5;"
			    }
			else
			    rtdecl = rtdecl arg

			if (i < n)
			    rtdecl = rtdecl ", "
			}
		    }

		# output code

		s = "rsy"
		next
		}

s == "rsy"	{
		# accumulate synopsis til '{' or blank line,
		# then generate Fortran callable C routine

		if ((l !~ /^ *{/) && (l !~ /^ *$/))
		    {
		    # get real part up to ';'

		    if (index (l, ";") > 0)
			{
			t = 1
			if ($1 == "*")
			    t++
			if ($t == "FAST" || $t == "register" || $t == "struct")
			    t++

			arg = substr ($(t+1), 0, index ($(t+1), ";") - 1)

			if ($t == "char" && \
			    (arg ~ /^\*[^\*]/) || ($(t+2) ~ /\[\]/))
			    {
			    if (arg ~ /^\*[^\*]/)
				arg = substr (arg, 2);
			    else if ($(t+2) ~ /\[\]/)
				arg = $(t+1)
			    else
				print "f2cgen: trouble with \"char\" decl."

			    argd_usr[++argc_usr] = "char *" arg ";"
			    argl[argc_usr] = "_t_" arg
			    argd_add[++argc_add] = "int _n_" arg ";"
			    rtdecl = rtdecl ", _n_" arg
			    argd_tmp [++argc_tmp] = "char *_t_" arg ";"
			    code [++xcode] = \
				"_t_" arg " = malloc (_n_" arg " + 1);"
			    code [++xcode] = \
				"bcopy (" arg ", _t_" arg ", _n_" arg ");"
			    code [++xcode] = "_t_" arg " [_n_" arg "] = EOS;"
			    code2 [++xcode2] = "free (_t_" arg ");"
			    }
			else if ($t == "float" || $t == "double")
			    {
			    if (arg ~ /^\*[^\*]/)
				arg = substr (arg, 2)
			    else if (arg ~ /\[\]/)
				arg = substr (arg, 1, index (arg, "[") - 1)
			    else if ($(t+2) !~ /\[\]/)
				arg = "*" arg
			    argd_usr[++argc_usr] = $t " " arg ";"
			    argl[argc_usr] = arg
			    }
			else
			    {
			    if (arg ~ /^\*[^\*]/)
				arg = substr (arg, 2)
			    else if (arg ~ /\[\]/)
				arg = substr (arg, 1, index (arg, "[") - 1)
			    else if ($(t+2) !~ /\[\]/)
				arg = "*" arg

			    argd_usr[++argc_usr] = "int " arg ";"
			    argl[argc_usr] = arg
			    }
			}
		    argd_usr[argc_usr] = argd_usr[argc_usr] \
			" /* " substr (l, 1, index (l, ";") - 1) " */"
		    }
		else
		    {
		    # end of synopsis reached;
		    # generate Fortran callable C routine

		    if (char_flag == "TRUE")
			{
			code [++xcode] = \
			    "retVal = strncpy (retStr, " substr (rtname, 2) " ("
			}
		    else
			{
			code [++xcode] = "retVal = " rtname " ("
			}

		    print ""
		    print rtdecl ")"

		    # return args
		    for (i = 1; i <= argc_ret; i++)
			print "    " argd_ret[i]

		    # normal args

		    for (i = 1; i <= argc_usr; i++)
			print "    " argd_usr[i]

		    # additional args

		    for (i = 1; i <= argc_add; i++)
			print "    " argd_add [i]

		    print ""
		    print "    {"

		    # temporary args

		    for (i = 1; i <= argc_tmp; i++)
			print "    " argd_tmp [i]

		    if (argc_tmp > 0)
			print ""

		    # code

		    for (i = 1; i < xcode; i++)
			print "    " code [i]

		    arglist = ""
		    for (i = 1; i <= argc_usr; i++)
			{
			arglist = arglist argl[i]
			if (i < argc_usr)
			    arglist = arglist ", "
			}

		    # var args

		    for (i = 1; i <= argc_var; i++)
			{
			if (i == 1 && arglist != "")
			    arglist = arglist ", "

			arglist = arglist argd_var[i]
			if (i < argc_var)
			    arglist = arglist ", "
			}

		    print ""

		    if (char_flag == "TRUE")
			print "    " code [xcode] arglist "), nretStr);"
		    else
			print "    " code [xcode] arglist ");"

		    # additional cleanup code

		    if (xcode2 > 0)
			print ""

		    for (i = 1; i <= xcode2; i++)
			print "    " code2 [i]

		    print "    return (retVal);"

		    print "    }"

		    s = "rtn"
		    }

		next
		}

END		{
		}
#STOP_AWK
