// ------------------------------------------------------------------------
// A simple SWIG Language module
//
// $Id: ftn.cxx,v 1.4 1998/07/03 10:16:09 poh Exp $
//
// ------------------------------------------------------------------------

#include <ctype.h>
#include <stream.h>
#include <swig.h>

#include "ftn.h"

static int abi64 = 0;
static FILE* f_inc = NULL;

static char *usage = "\
My Language Options\n\
     -32             - Generate 32 ABI code\n\
     -n32            - Generate n32 ABI code\n\
     -64             - Generate 64 ABI code\n\
     -module name    - Set name of module\n\n";


static char*
strtolower(char* name)
{
  static char mangle[90];
  const int len = strlen(name);
  for (int i = 0, j = 0; i < len; i++)
    if (isalpha(name[i])) mangle[j++] = tolower(name[i]);
    else mangle[j++] = name[i];
  mangle[j] = '\0';
  return mangle;
}

static char*
ftn_mangle_name(char* name, int c_decl = 1)
{
  if (strlen(name) > 32)
    cout << "Function name to long: " << name << "\n";
  static char mangle[90];
  const int len = strlen(name);
  for (int i = 0, j = 0; i < len; i++)
    if (isalpha(name[i])) mangle[j++] = tolower(name[i]);
    else mangle[j++] = name[i];
  if (c_decl)
  {
    mangle[j] = '_';
    mangle[j+1] = '\0';
  }
  else
  {
    mangle[j] = '\0';
  }

  return mangle;
}

static char*
ftn_mangle_type(DataType* t, char** ftn_type, int ret_type = 0)
{
  static String def;

  String type;

  def = "";

  switch (t->type)
  {
  case T_INT: type = "int"; *ftn_type = "integer*4"; break;
  case T_SHORT: type = "short"; *ftn_type = "integer*2"; break;

    // Long is integer*8 in 64 ABI, and integer*4 in 32 and N32
  case T_LONG: type = "long"; 
    *ftn_type = abi64 ? "integer*X" : "integer*X";
    break;

  case T_CHAR: type = "char"; *ftn_type = "character*1"; break;
  case T_FLOAT: type = "float"; *ftn_type = "real*4"; break;
  case T_DOUBLE: type = "double"; *ftn_type = "real*8"; break;

    // Address to void is treated as a long value
  case T_VOID: type = "void";
    *ftn_type = abi64 ? "integer*X" : "integer*X";
    break;

  case T_UINT: type = "unsigned int"; *ftn_type = "integer*4"; break;
  case T_USHORT: type = "unsigned short"; *ftn_type = "integer*2"; break;
  case T_ULONG: type = "unsigned long"; *ftn_type = "integer*4"; break;
  case T_UCHAR: type = "unsigned char"; *ftn_type = "character*1"; break;
  case T_SCHAR: type = "signed char"; *ftn_type = "character*1"; break;
  case T_BOOL: type = "short"; *ftn_type = "integer*2"; break;

    // Address to user types are treates as long values
  case T_USER: type = "long";
    *ftn_type = abi64 ? "integer*X" : "integer*X";
    break;

  case T_ERROR: type = "error"; *ftn_type = "ERROR"; break;
  }

  // Sanity check
  if (t->type == T_USER && t->is_pointer == 0)
    fprintf(stderr, "User type paremeters not allowed!\n");


  // Make all strings 132 long
  if (t->type == T_CHAR && t->is_pointer)
    *ftn_type = "character*132";

  // Handle the special void* type
  if ((t->type == T_VOID || t->type == T_USER) && t->is_pointer == 1)
  {
    if (ret_type)
      def << "long";
    else
      def << "long*";
  }
  else
  {
    def << type;
    if (!ret_type || t->is_pointer)
      def << " *";
  }

  return def.get();
}


// ---------------------------------------------------------------------
// FTN::parse_args(int argc, char *argv[])
//
// Parse my command line options and initialize by variables.
// ---------------------------------------------------------------------

void FTN::parse_args(int argc, char *argv[]) {

  // Look for certain command line options
  for (int i = 1; i < argc; i++) {
    if (argv[i]) {
      if (strcmp(argv[i],"-module") == 0) {
	if (argv[i+1]) {
	  set_module(argv[i+1],0);
	  mark_arg(i);
	  mark_arg(i+1);
	  i++;
	}
	else {
	  arg_error();
	}
      } else if (strcmp(argv[i],"-help") == 0) {
	fprintf(stderr,"%s\n", usage);
      }
      else if (strcmp(argv[i],"-64") == 0) {
	abi64 = 1;
	mark_arg(i);
      }
      else if (strcmp(argv[i],"-32") == 0) {
	mark_arg(i);
      }
      else if (strcmp(argv[i],"-n32") == 0) {
	mark_arg(i);
      }
    }
  }

  // Set location of SWIG library
  strcpy(LibDir,"ftn");

  // Add a symbol to the parser for conditional compilation
  add_symbol("SWIGFTN",0,0);

  // Add typemap definitions
  typemap_lang = "ftn";
}

// ---------------------------------------------------------------------
// void FTN::parse()
//
// Start parsing an interface file for FTN.
// ---------------------------------------------------------------------

void FTN::parse() {

  fprintf(stderr,"Making wrappers for Fortran\n");

  headers();       // Emit header files and other supporting code

  // Tell the parser to first include a typemap definition file

  if (include_file("ftn.map") == -1) {
    fprintf(stderr,"Unable to find ftn.map!\n");
    SWIG_exit(1);
  }
  yyparse();       // Run the SWIG parser
}

// ---------------------------------------------------------------------
// FTN::set_module(char *mod_name,char **mod_list)
//
// Sets the module name.  Does nothing if it's already set (so it can
// be overriddent as a command line option).
//
// mod_list is a NULL-terminated list of additional modules.  This
// is really only useful when building static executables.
//----------------------------------------------------------------------

void FTN::set_module(char *mod_name, char **mod_list) {
  if (module) return;
  module = new char[strlen(mod_name)+1];
  strcpy(module,mod_name);
}

// ---------------------------------------------------------------------
// FTN::headers(void)
//
// Generate the appropriate header files for FTN interface.
// ----------------------------------------------------------------------

void FTN::headers(void)
{
  emit_banner(f_header);               // Print the SWIG banner message
  fprintf(f_header,"/* Implementation : Fortran */\n\n");

  // Include header file code fragment into the output
  if (insert_file("header.swg",f_header) == -1) {
    fprintf(stderr,"Fatal Error. Unable to locate 'header.swg'.\n");
    SWIG_exit(1);
  }

  // Emit the default SWIG pointer type-checker (for strings)
//   if (insert_file("swigptr.swg",f_header) == -1) {
//     fprintf(stderr,"Fatal Error. Unable to locate 'swigptr.swg'.\n");
//     SWIG_exit(1);
//   }
}

// --------------------------------------------------------------------
// FTN::initialize(void)
//
// Produces an initialization function.   Assumes that the init function
// name has already been specified.
// ---------------------------------------------------------------------

void FTN::initialize() 
{
  char filename[80];
  if (abi64)
    sprintf(filename, "%s64.inc", module);
  else
    sprintf(filename, "%s.inc", module);
  if((f_inc = fopen(filename, "w")) == 0) {
    fprintf(stderr,"Unable to open %s\n", filename);
    SWIG_exit(1);
  }
}

// ---------------------------------------------------------------------
// FTN::close(void)
//
// Wrap things up.  Close initialization function.
// ---------------------------------------------------------------------

void FTN::close(void)
{
  // Dump the pointer equivalency table
  //emit_ptr_equivalence(f_init);
  fclose(f_inc);
}

// ----------------------------------------------------------------------
// FTN::create_command(char *cname, char *iname)
//
// Creates a FTN command from a C function.
// ----------------------------------------------------------------------

void FTN::create_command(char *cname, char *iname)
{
  // Not needed since fortran calls the wrapper function directly
}

// ----------------------------------------------------------------------
// FTN::create_function(char *name, char *iname, DataType *d, ParmList *l)
//
// Create a function declaration and register it with the interpreter.
// ----------------------------------------------------------------------

void FTN::create_function(char *name, char *iname, DataType *t, ParmList *l)
{
  int i;
  char *tm;
  char* ftn_type;
  String ret_decl, len;
  String source, target;
  String cleanup, outarg;
  int len_arg = 0;

  static DocEntry *last_doc_entry = 0;

  // A new wrapper function object

  WrapperFunction  f;

  // Now write the wrapper function itself....this is pretty ugly

  f.def << "#ifdef __cplusplus\n" "extern \"C\"\n" "#endif\n";
  f.def << "$return\n";
  f.def << ftn_mangle_name(iname) << "($ftn_str_ret";
  
  if (doc_entry)
  {
    if (last_doc_entry != doc_entry) doc_entry->usage = "";
    doc_entry->usage << strtolower(ftn_mangle_name(iname, 0)) << " ";
  }

  // Emit all of the local variables for holding arguments.
  int pcount = emit_args(t,l,f);
  f.code << tab4 << "$ret_decl;\n";

  // Get number of optional/default arguments
  int numopt = l->numopt();


  // Now walk the function parameter list and generate code to get arguments
  int j = 0;                // Total number of non-optional arguments

  for (i = 0; i < pcount ; i++) {
    Parm &p = (*l)[i];         // Get the ith argument
    source = "";
    target = "";

    // Produce string representation of source and target arguments
    source << "par" << j;
    target << "_arg" << i;

    if (!p.ignore) {

      if (j > 0) {
	f.def << ", ";
	if (doc_entry) doc_entry->usage << ", ";
      }

      f.def << ftn_mangle_type(p.t, &ftn_type) << source;
      if (p.t->type == T_CHAR && p.t->is_pointer == 1)
      {
	len_arg++;
	len = "";
	len << "ftn_str_len" << len_arg;
      }

      if (doc_entry)
      {
	doc_entry->usage << ftn_type;
	if (strlen(p.name) > 0) doc_entry->usage << " " << p.name;
      }

      if (j >= (pcount-numopt))  // Check if parsing an optional argument
	;

      // Get typemap for this argument

      tm = typemap_lookup("in",typemap_lang,p.t,p.name,source,target,&f);
      if (tm) {
	f.code << tm << "\n";
	f.code.replace("$arg",source);   // Perform a variable replacement
	f.code.replace("$len", len);
      } else {
	fprintf(stderr,"%s : Line %d. No typemapping for datatype %s\n",
		input_file,line_number, p.t->print_type());
      }
      if (j >= (pcount-numopt))
	;
      j++;
    }

    // Check to see if there was any sort of a constaint typemap
    if ((tm = typemap_lookup("check",typemap_lang,p.t,p.name,source,target))) {
      // Yep.  Use it instead of the default
      f.code << tm << "\n";
      f.code.replace("$arg",source);
    }

    // Check if there was any cleanup code (save it for later)
    if ((tm = typemap_lookup("freearg",typemap_lang,p.t,p.name,target,"interp->result"))) {
      // Yep.  Use it instead of the default
      cleanup << tm << "\n";
      cleanup.replace("$arg",source);
    }
    if ((tm = typemap_lookup("argout",typemap_lang,p.t,p.name,target,"interp->result"))) {
      // Yep.  Use it instead of the default
      outarg << tm << "\n";
      outarg.replace("$arg",source);
    }
  }


  // Now write code to make the function call

  emit_func_call(name,t,l,f);


  // Return value if necessary 

  ftn_type = "void";
  if ((t->type != T_VOID) || (t->is_pointer))
  {
    
    if (t->type == T_CHAR && t->is_pointer)
    {
      len = "char* ftn_str_ret, int* ftn_str_len";
      if (j > 0) len = "char* ftn_str_ret, int ftn_str_len, ";
      else len = "char* ftn_str_ret, int ftn_str_len";
      f.def.replace("$ftn_str_ret", len);
      len = "ftn_str_len";
      ret_decl = "char* ret = ftn_str_ret";
      f.def.replace("$return","void");
      (void)ftn_mangle_type(t, &ftn_type, 1);
    }
    else
    {
      f.def.replace("$ftn_str_ret","");    
      ret_decl << ftn_mangle_type(t, &ftn_type, 1) << " ret";
      f.def.replace("$return",ftn_mangle_type(t, &ftn_type, 1));
    }

    f.code.replace("$ret_decl", ret_decl);
    if ((tm = typemap_lookup("out",typemap_lang,t,name,"_result","ret"))) {
      // Yep.  Use it instead of the default
      f.code << tm << "\n";
      f.code.replace("$len", len);
    } else {
      fprintf(stderr,"%s : Line %d. No return typemap for datatype %s\n",
	      input_file,line_number,t->print_type());
    }
  }
  else
  {
    f.def.replace("$ftn_str_ret","");
    f.def.replace("$return","void");
    f.code.replace("$ret_decl","");
  }

  if (strcmp(ftn_type, "void") == 0)
    fprintf(f_inc, "      external %s\n", ftn_mangle_name(iname, 0));
  else if (strcmp(ftn_type, "integer*X") == 0)
    fprintf(f_inc, "      %s %s\n", abi64 ? "integer*8" : "integer*4",
	    ftn_mangle_name(iname, 0));
  else
    fprintf(f_inc, "      %s %s\n", ftn_type, ftn_mangle_name(iname, 0));

  // Add the lenght arguments
  for (i = 1; i <= len_arg; i++)
  {
    if (j > 0)
      f.def << ", ";
    f.def << "int ftn_str_len" << i;
    j++;
  }

  // Close the function definition
  f.def << ")\n{\n";

  // Dump argument output code;
  f.code << outarg;

  // Dump the argument cleanup code
  f.code << cleanup;

  // Look for any remaining cleanup

  if (NewObject) {
    if ((tm = typemap_lookup("newfree",typemap_lang,t,iname,"_result",""))) {
      f.code << tm << "\n";
    }
  }

  if ((tm = typemap_lookup("ret",typemap_lang,t,name,"_result",""))) {
    f.code << tm << "\n";
  }

  // Wrap things up (in a manner of speaking)
  if ((t->type != T_VOID) || t->is_pointer)
    if ((t->type != T_CHAR) || !t->is_pointer)
      f.code << tab4 << "return ret;\n";
  f.code << "\n}";

  // Substitute the cleanup code (some exception handlers like to have this)
  f.code.replace("$cleanup",cleanup);
 
  // Emit the function
  
  f.print(f_wrappers);
  
  // Now register the function with the language

  create_command(name,iname);
  
  // If there's a documentation entry, produce a usage string
  
  if (doc_entry) {

    // Set the cinfo field to specific a return type 

    if (last_doc_entry != doc_entry) {
      if ((t->type != T_VOID) || (t->is_pointer)) 
	doc_entry->cinfo << "returns " << ftn_type;
      else
	doc_entry->cinfo << "returns void";
      last_doc_entry = doc_entry;
    }
  }
}

// -----------------------------------------------------------------------
// FTN::link_variable(char *name, char *iname, DataType *t)
//
// Create a FTN link to a C variable.
// -----------------------------------------------------------------------

void FTN::link_variable(char *name, char *iname, DataType *t)
{

  char *tm;

  // Uses a typemap to stick code into the module initialization function
  // Check to see if this can be wrapped in the init function
  
  if ((tm = typemap_lookup("varinit",typemap_lang,t,name,name,iname))) {
    String temp = tm;
    if (Status & STAT_READONLY)
      temp.replace("$status"," | TCL_LINK_READ_ONLY");
    else
      temp.replace("$status","");
    //fprintf(f_init,"%s\n",(char *) temp);
  } else {
    fprintf(stderr,"%s : Line %d. Unable to link with variable type %s\n",
	    input_file,line_number,t->print_type());
  }
}

// -----------------------------------------------------------------------
// FTN::declare_const(char *name, char *iname, DataType *type, char *value)
//
// Makes a constant.  A quick trick is to make a variable and create a
// link to it.
// ------------------------------------------------------------------------

void FTN::declare_const(char *name, char *iname, DataType *type, char *value) {

  char *tm;
  
  if ((tm = typemap_lookup("const",typemap_lang,type,name,name,iname))) {
    String str = tm;
    str.replace("$value",value);
    //fprintf(f_init,"%s\n", (char *) str);
  } else {
    fprintf(stderr,"%s : Line %d. Unable to create constant %s = %s\n", 
	    input_file, line_number, type->print_type(), value);
  }
  if (doc_entry)
  {
    doc_entry->usage = iname;
  }
}