problem_compile.c

Go to the documentation of this file.

/* $Id: problem_compile.c,v 1.98 2008/10/22 20:03:26 seymour Exp $ */
/* $UTK_Copyright: $ */


#include <stdio.h>
#include <string.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <sys/wait.h>
#include <errno.h>
#include <unistd.h>
#include <dirent.h>
#include <stdlib.h>
#include <ctype.h>

#ifdef HAVE_CONFIG_H
#include "config.h"
#include "gridsolve-config.h"
#endif /* HAVE_CONFIG_H */
#include "problem.h"
#include "comm_encode.h"
#include "utility.h"

char *gridsolve_root = NULL;

int gs_remove_failed_service = TRUE;

char *
gs_idl_emit_fortran_ifdefs(FILE *file, char *name, char *lang)
{
  if(!name || !lang)
    return NULL;

  if(!strcasecmp(lang, "FORTRAN")) {
    char *lo, *up;
    int i;

    lo = strdup(name);
    if(!lo) return NULL;

    up = strdup(name);
    if(!up) {
      free(lo);
      return NULL;
    }

    for(i=0;i<strlen(name);i++) {
      lo[i] = tolower(lo[i]);
      up[i] = toupper(up[i]);
    }

    fprintf(file, "#ifdef F2CNOCHANGE\n");
    fprintf(file, "#define GS_USER_ROUTINE %s\n", lo);
    fprintf(file, "#elif F2CADD_\n");
    fprintf(file, "#define GS_USER_ROUTINE %s_\n", lo);
    fprintf(file, "#elif F2CADD__\n");
    fprintf(file, "#define GS_USER_ROUTINE %s__\n", lo);
    fprintf(file, "#elif F2CUPCASE\n");
    fprintf(file, "#define GS_USER_ROUTINE %s\n", up);
    fprintf(file, "#else\n");
    fprintf(file, "#define GS_USER_ROUTINE %s\n", lo);
    fprintf(file, "#endif\n");
    fprintf(file, "\n");

    return strdup("GS_USER_ROUTINE");
  }

  return strdup(name);
}

char *
gs_idl_arg_name_mangle(gs_argument_t * arg, char *lang, int argnum)
{
  char *string;

  if(!arg || !lang)
    return NULL;

  if((arg->objecttype == GS_FILE) || (arg->objecttype == GS_PACKEDFILE))
    string = dstring_sprintf("(%s *) argdata[%d]",
                             gs_c_datatype[arg->datatype], argnum);
  /* if it's passed by value, dereference before calling */
  else if(!strcasecmp(lang, "C") && arg->objecttype == GS_SCALAR &&
     ((arg->inout == GS_IN) || (arg->inout == GS_WORKSPACE)))
    string = dstring_sprintf("(*(%s*)argdata[%d])",
                             gs_c_datatype[arg->datatype], argnum);
  else if(arg->inout == GS_VAROUT)
    string = dstring_sprintf("(%s**) argdata[%d]",
                             gs_c_datatype[arg->datatype], argnum);
  else
    string = dstring_sprintf("(%s*) argdata[%d]",
                             gs_c_datatype[arg->datatype], argnum);

  return (string);
}

int
gs_non_workspace_args_left(gs_argument_t *arg)
{
  gs_argument_t *atmp;

  for(atmp = arg->next; atmp != NULL; atmp = atmp->next) {
    if(atmp->inout != GS_WORKSPACE)
      return FALSE;
  }

  return TRUE;
}

int
gs_idl_generate_grpc_example(gs_problem_t * problem)
{
  gs_argument_t *arg;
  char *fname;
  FILE *file;
  int needs_scval = 0, needs_dcval = 0;

  fname = dstring_sprintf("%s/service/%s/%s_grpc_example.c",
                          gridsolve_root, problem->name,
                          problem->name);
  if(!fname) {
    ERRPRINTF("Could not generate name of service file\n");
    return -1;
  }

  if((file = fopen(fname, "w")) == NULL) {
    ERRPRINTF("Could not open file %s\n", fname);
    free(fname);
    return -1;
  }

  free(fname);

  /* first generate the typical header stuff */
  fprintf(file, "/* This is an automatically generated code example, so\n");
  fprintf(file, " * arguments are initialized with some arbitrary values\n");
  fprintf(file, " * that may not be valid for the routine.  It is just\n");
  fprintf(file, " * intended to show the proper calling sequence (whether\n");
  fprintf(file, " * arguments should be passed by reference, how\n");
  fprintf(file, " * they could be declared, etc) and simple GridRPC\n");
  fprintf(file, " * initialization, calling, and error handling.\n");
  fprintf(file, " */\n");
  fprintf(file, "\n");

  fprintf(file, "#include <stdio.h>\n");
  fprintf(file, "#include <stdlib.h>\n");
  fprintf(file, "\n");

  fprintf(file, "#undef  max\n");
  fprintf(file, "#define max(a, b)  (((a) > (b)) ? (a) : (b))\n");
  fprintf(file, "\n");

  fprintf(file, "#undef  min\n");
  fprintf(file, "#define min(a, b)  (((a) < (b)) ? (a) : (b))\n");
  fprintf(file, "\n");

  fprintf(file, "\n");
  fprintf(file, "#include \"grpc.h\"\n");
  fprintf(file, "\n");
  fprintf(file, "int main()\n");
  fprintf(file, "{\n");
  fprintf(file, "  grpc_function_handle_t __handle;\n");
  fprintf(file, "  grpc_error_t __status;\n");

  /* now generate local variable declarations for the args */
  for(arg = problem->arglist; arg != NULL; arg = arg->next) {
    /* skip workspace args */
    if(arg->inout == GS_WORKSPACE)
      continue;

    fprintf(file, "  %s ", gs_c_datatype[arg->datatype]);
    if((arg->objecttype == GS_VECTOR) || (arg->objecttype == GS_MATRIX)
       || (arg->objecttype == GS_SPARSEMATRIX) || (arg->objecttype == GS_FILE))
      fprintf(file, "*");
    else if(arg->objecttype == GS_PACKEDFILE)
      fprintf(file, "**");
    fprintf(file, "%s;\n", arg->name);

    if(arg->datatype == GS_SCOMPLEX)
      needs_scval = 1;
    if(arg->datatype == GS_DCOMPLEX)
      needs_dcval = 1;
  }

  if(needs_scval)
    fprintf(file, "  %s __scval = {4.0, 6.0};\n", gs_c_datatype[GS_SCOMPLEX]);

  if(needs_dcval)
    fprintf(file, "  %s __dcval = {4.0, 6.0};\n", gs_c_datatype[GS_DCOMPLEX]);

  fprintf(file, "\n");

  /* initialize scalar arguments */
  for(arg = problem->arglist; arg != NULL; arg = arg->next) {
    /* skip workspace args */
    if(arg->inout == GS_WORKSPACE)
      continue;

    /* skip this if it's a sparse matrix attribute */
    if(gs_arg_is_sparse_attr(arg->name, problem->arglist))
      continue;

    if((arg->objecttype == GS_SCALAR) && (arg->inout != GS_OUT))
      fprintf(file, "  %s = %s;\n", arg->name, gs_const[arg->datatype]);
    else if(arg->objecttype == GS_FILE)
      fprintf(file, "  %s = \"foo\";\n", arg->name);
  }

  /* for non-scalar args we must allocate memory */
  for(arg = problem->arglist; arg != NULL; arg = arg->next) {
    /* skip workspace args */
    if(arg->inout == GS_WORKSPACE)
      continue;

    /* skip this if it's a sparse matrix attribute */
    if(gs_arg_is_sparse_attr(arg->name, problem->arglist))
      continue;

    if((arg->objecttype == GS_VECTOR) || (arg->objecttype == GS_MATRIX) 
        || (arg->objecttype == GS_PACKEDFILE))
      fprintf(file, "  %s = (%s %s)malloc((%s)*(%s)*sizeof(*%s));\n", arg->name,
              gs_c_datatype[arg->datatype], 
              arg->objecttype == GS_PACKEDFILE ? "**" : "*",
              arg->rowexp, arg->colexp, arg->name);
  }

  for(arg = problem->arglist; arg != NULL; arg = arg->next) {
    /* skip this if it's a sparse matrix attribute */
    if(gs_arg_is_sparse_attr(arg->name, problem->arglist))
      continue;

    if(((arg->objecttype == GS_VECTOR) || (arg->objecttype == GS_MATRIX))
       && (arg->inout != GS_OUT) && (arg->inout != GS_WORKSPACE)) {
      fprintf(file, "  {\n    int __i;\n");

      fprintf(file, "    for(__i=0;__i<(%s)*(%s);__i++)\n", arg->rowexp,
              arg->colexp);
      fprintf(file, "      %s[__i] = %s;\n", arg->name,
              gs_const[arg->datatype]);
      fprintf(file, "  }\n");
    }
    else if(arg->objecttype == GS_PACKEDFILE) {
      fprintf(file, "  {\n    int __i;\n");
      fprintf(file, "    for(__i=0;__i<(%s);__i++)\n", arg->rowexp);
      fprintf(file, "      %s[__i] = \"foo\";\n", arg->name);
      fprintf(file, "  }\n");
    }
    else if(arg->objecttype == GS_SPARSEMATRIX) {
      fprintf(file, "\n  /* initialize sparse matrix %s */\n", arg->name);
      fprintf(file, "  if((%s = gs_gen_sparse_mat_%s(%s, (0*%s)+1, (1*%s)-1 , &%s, &%s, &%s)) < 0) {\n",
        arg->sparse_attr.nnzexp, gs_c_datatype[arg->datatype], arg->colexp, 
        arg->rowexp, arg->rowexp, arg->name, arg->sparse_attr.indices, 
        arg->sparse_attr.pointer);
      fprintf(file, "    fprintf(stderr,\"Error creating sparse matrix\\n\");\n");
      fprintf(file, "    exit(EXIT_FAILURE);\n");
      fprintf(file, "  }\n");
    }
  }

  fprintf(file, "\n");

  /* generate a call to initialize GRPC */
  fprintf(file, "  if(grpc_initialize(NULL) != GRPC_NO_ERROR) {\n");
  fprintf(file, "    grpc_perror(\"grpc_initialize\");\n");
  fprintf(file, "    exit(EXIT_FAILURE);\n");
  fprintf(file, "  }\n");
  fprintf(file, "\n");

  /* create the GRPC function handle to the function we want to call */
  fprintf(file,
          "  if(grpc_function_handle_default(&__handle, \"%s\") != GRPC_NO_ERROR) {\n",
          problem->name);
  fprintf(file,
          "    fprintf(stderr,\"Error creating function handle\\n\");\n");
  fprintf(file, "    exit(EXIT_FAILURE);\n");
  fprintf(file, "  }\n");

  /* start generating the actual call */
  fprintf(file, "  __status = grpc_call(&__handle,");

  for(arg = problem->arglist; arg != NULL; arg = arg->next) {
    /* skip workspace args */
    if(arg->inout == GS_WORKSPACE)
      continue;

    /* if this is a scalar passed by reference, pass the address */
    if(((arg->objecttype == GS_SCALAR) && (arg->inout != GS_IN)) ||
        (arg->inout == GS_VAROUT))
      fprintf(file, "&");
    fprintf(file, "%s", arg->name);
    if(!gs_non_workspace_args_left(arg))
      fprintf(file, ",");
  }

  fprintf(file, ");\n\n");

  /* call is complete, check the status */
  fprintf(file, "  if(__status != GRPC_NO_ERROR) {\n");
  fprintf(file, "    printf(\"GRPC error __status  = %%d\\n\", __status);\n");
  fprintf(file, "    grpc_perror(\"grpc_call\");\n");
  fprintf(file, "    exit(__status);\n");
  fprintf(file, "  }\n");

  fprintf(file, "\n  printf(\"GridRPC call completed successfully.\\n\");\n");

  /* we are done.  finalize */
  fprintf(file, "  grpc_finalize();\n");
  fprintf(file, "  exit(EXIT_SUCCESS);\n");

  fprintf(file, "}\n");
  fclose(file);

  return 0;
}

int
gs_idl_generate_source(gs_problem_t * problem)
{
  char *fname, *language, *problem_name;
  gs_argument_t *arg, *lastarg;
  int i, argcount;
  FILE *file;

  if(!problem)
    return -1;

  language = gs_problem_getinfo(problem, "LANGUAGE", "C");

  /* generate source code for the interface */
  fname = dstring_sprintf("%s/service/%s/%s_service.c",
                          gridsolve_root, problem->name,
                          problem->name);
  if(!fname) {
    ERRPRINTF("Could not generate name of service file\n");
    return -1;
  }

  DBGPRINTF("Generating source for %s in file %s\n", problem->name, fname);
  if((file = fopen(fname, "w")) == NULL) {
    ERRPRINTF("Could not open file %s\n", fname);
    free(fname);
    return -1;
  }

  free(fname);

  fprintf(file, "#include <stdio.h>\n");
  fprintf(file, "#include <stdlib.h>\n");
  fprintf(file, "#include <unistd.h>\n");
  fprintf(file, "\n");
  fprintf(file, "#include \"problem.h\"\n");
  fprintf(file, "\n");

  problem_name = gs_idl_emit_fortran_ifdefs(file, problem->name, language);

  if(!problem_name)
    return -1;

  for(lastarg = problem->arglist; lastarg && lastarg->next;
      lastarg = lastarg->next)
    /* spin */ ;

  if(problem->type == GS_FUNCTION && !lastarg) {
    ERRPRINTF("Error: expected non-null last argument for function\n");
    return -1;
  }

  /* emit the prototype for the user's function that will be called */

  if(problem->type == GS_SUBROUTINE)
    fprintf(file, "extern void %s(", problem_name);
  else
    fprintf(file, "extern %s %s %s(", gs_c_datatype[lastarg->datatype],
            (lastarg->objecttype == GS_SCALAR) ? " " : "*", problem_name);

  for(argcount = 0, arg = problem->arglist; arg != NULL;
      arg = arg->next, argcount++) {
    arg->prob = problem;

    /* if this problem has a return value and we're on the last arg, don't
       emit it since it's not part of the routine's calling sequence. */
    if((problem->type == GS_FUNCTION) && (arg->next == NULL)) {
      argcount++;
      break;
    }

    /* if this is passed by value (i.e. a C input-only scalar argument) then
       do not declare as pointer in the prototype. */
    if(!strcasecmp(language, "C") && arg->objecttype == GS_SCALAR &&
       ((arg->inout == GS_IN) || (arg->inout == GS_WORKSPACE)))
      fprintf(file, "%s %s", gs_c_datatype[arg->datatype], arg->name);
    else if(arg->inout == GS_VAROUT)
      fprintf(file, "%s** %s", gs_c_datatype[arg->datatype], arg->name);
    else
      fprintf(file, "%s* %s", gs_c_datatype[arg->datatype], arg->name);

    if(problem->type == GS_FUNCTION) {
      if(arg->next && arg->next->next)
        fprintf(file, ", ");
    }
    else if(arg->next) {
      fprintf(file, ", ");
    }

    if((argcount % 4) == 0)
      fprintf(file, "\n   ");
  }

  fprintf(file, ");\n");
  fprintf(file, "\n");

  /* start emitting service routine and generate variable declarations */

  fprintf(file, "int gs_problem_service(gs_problem_t *problem)  /* %s */ \n",
          problem->name);
  fprintf(file, "{ \n");
  fprintf(file, "  gs_argument_t *arg; \n");
  fprintf(file, "  void *argdata[%d]; \n", argcount);
  fprintf(file, "  int i; \n");
  if(problem->type == GS_FUNCTION)
    fprintf(file, "  gs_argument_t *lastarg;\n");
  fprintf(file, "\n");

  if(problem->type == GS_FUNCTION)
    fprintf(file, "  lastarg=problem->arglist;\n");

  /* set up the array of arguments from the linked list */

  fprintf(file, "  for(arg=problem->arglist,i=0; arg!=NULL; \
    arg=arg->next,i++) {\n");
  fprintf(file, "    argdata[i] = arg->data;\n");
  if(problem->type == GS_FUNCTION)
    fprintf(file, "    if(!arg->next) lastarg = arg;\n");
  fprintf(file, "  }\n");
  fprintf(file, "\n");

  if((problem->type == GS_FUNCTION) && (lastarg->objecttype == GS_SCALAR))
    fprintf(file, "  lastarg->data = (%s*)malloc(sizeof(%s));\n",
            gs_c_datatype[lastarg->datatype],
            gs_c_datatype[lastarg->datatype]);

  /* now emit the call to the user's routine */

  if(problem->type == GS_FUNCTION) {
    if(lastarg->objecttype == GS_SCALAR)
      fprintf(file, "  *((%s*)(lastarg->data)) = %s(",
              gs_c_datatype[lastarg->datatype], problem_name);
    else
      fprintf(file, "  lastarg->data = %s(", problem_name);
  }
  else
    fprintf(file, "  %s(", problem_name);

  free(problem_name);

  for(i = 0, arg = problem->arglist; arg != NULL; arg = arg->next, i++) {
    char *carg;

    /* if this problem has a return value and we're on the last arg, don't
       emit it since it's not part of the routine's calling sequence. */
    if((problem->type == GS_FUNCTION) && (arg->next == NULL))
      break;

    carg = gs_idl_arg_name_mangle(arg, language, i);

    if(carg) {
      fprintf(file, "%s", carg);
      free(carg);
    }
    else {
      ERRPRINTF("gs_idl_arg_name_mangle failed\n");
      fclose(file);
      return -1;
    }

    if(problem->type == GS_FUNCTION) {
      if(arg->next && arg->next->next)
        fprintf(file, ", ");
    }
    else if(arg->next) {
      fprintf(file, ", ");
    }

    if((i % 4) == 0)
      fprintf(file, "\n   ");
  }

  fprintf(file, ");\n");
  fprintf(file, "  return 0;\n");
  fprintf(file, "} \n");

  /* Set up main program to call service_template */
  fprintf(file, "\n");
  fprintf(file, "\n");
  fprintf(file, "/* The service_template routine is defined in the */\n");
  fprintf(file, "/* problem directory and is compiled into a library */\n");
  fprintf(file, "/* and linked in.  It sets up some stuff, and then */\n");
  fprintf(file, "/* calls the gs_problem_service above */ \n");
  fprintf(file, "int service_template(int argc, char *argv[]); \n");
  fprintf(file, "\n");
  fprintf(file, "int gs_argc;\n");
  fprintf(file, "char **gs_argv;\n");
  fprintf(file, "\n");
  fprintf(file, "int main(int argc, char *argv[]) \n");
  fprintf(file, "{ \n");
  fprintf(file, "  gs_argc = argc;\n");
  fprintf(file, "  gs_argv = argv;\n");
  fprintf(file, "  return service_template(argc, argv); \n");
  fprintf(file, "} \n");
  fprintf(file, "\n");

  fclose(file);

  return 0;
}

int
gs_emit_service_vars(FILE *file, char *bin_name, char *serv_src, char *language, 
  char *libs, char *service)
{
  fprintf(file, "%s_SOURCES = %s.c\n", bin_name, serv_src);
  fprintf(file, "%s_LDFLAGS = \n", bin_name);
  fprintf(file, "%s_OBJECTS = %s.o\n", bin_name, serv_src);
  fprintf(file, "%s_DEPENDENCIES = \n", bin_name);
  fprintf(file, "%s_LDADD = -L%s/lib -l%s %s/lib/libgridsolve_infrastructure.a \
     $(FLIBS) $(LIBS) -lm $(IBPLIB)\n", bin_name, gridsolve_root, service,
     gridsolve_root);
  fprintf(file, "\n\n");

  return 0;
}

int
gs_emit_service_link(FILE *file, char *parallel, char *language, char *pname)
{
  if(!strcasecmp(parallel, "sequential") && !strcasecmp(language, "C"))
    fprintf(file, "%s_LD = $(CCLD)\n", pname);
  else if(!strcasecmp(parallel, "sequential")
          && !strcasecmp(language, "FORTRAN"))
    fprintf(file, "%s_LD = $(SERVICE_LINK)\n", pname);
  else if(!strcasecmp(parallel, "parallel") && !strcasecmp(language, "C"))
    fprintf(file, "%s_LD = $(MPICC)\n", pname);
  else if(!strcasecmp(parallel, "parallel") && !strcasecmp(language, "C"))
    fprintf(file, "%s_LD = $(MPIF77)\n", pname);

  fprintf(file, "%s_LINK = $(%s_LD) $(AM_LDFLAGS) $(LDFLAGS) -o $@\n",
          pname, pname);
  fprintf(file, "%s: $(%s_OBJECTS) $(%s_DEPENDENCIES) \n", pname, pname,
          pname);
  fprintf(file, "\t$(%s_LINK) $(%s_LDFLAGS) $(%s_OBJECTS) \
    $(%s_LDADD) $(LIBS) $(__USER_LIBS)\n", pname, pname, pname, pname);
  fprintf(file, "\n");

  return 0;
}

int
gs_idl_generate_makefile(gs_problem_t * problem)
{
  char *fname, *language, *parallel, *libs, *pname, *bname, *grpc_pname;
  char *submit_script, *probe_script, *cancel_script, *linker;
  gs_info_t *info;
  int batch_mode;
  FILE *file;

  submit_script = gs_problem_getinfo(problem, "BATCH_SUBMIT", NULL);
  probe_script = gs_problem_getinfo(problem, "BATCH_PROBE", NULL);
  cancel_script = gs_problem_getinfo(problem, "BATCH_CANCEL", NULL);

  if(submit_script && probe_script && cancel_script)
    batch_mode = 1;
  else if(!submit_script && !probe_script && !cancel_script)
    batch_mode = 0;
  else {
    ERRPRINTF("If using batch mode, BATCH_SUBMIT, BATCH_PROBE, and BATCH_CANCEL must all be specified.\n");
    return -1;
  }

  if(!problem)
    return -1;

  DBGPRINTF("Generating makefile %s\n", problem->name);

  language = gs_problem_getinfo(problem, "LANGUAGE", "C");
  parallel = gs_problem_getinfo(problem, "PARALLEL", "sequential");
  linker = gs_problem_getinfo(problem, "LINKER", NULL);
  libs = gs_problem_getinfo(problem, "LIBS", "");

  fname = dstring_sprintf("%s/service/%s/%s_makefile",
                          gridsolve_root, problem->name,
                          problem->name);
  if(!fname) {
    ERRPRINTF("Error generating the name of the makefile\n");
    return -1;
  }

  unlink(fname);

  if((file = fopen(fname, "w")) == NULL) {
    ERRPRINTF("Could not open file '%s'\n", fname);
    free(fname);
    return -1;
  }
  free(fname);

  pname = dstring_sprintf("%s_service", problem->name);
  if(!pname) {
    ERRPRINTF("Error generating the name of the service\n");
    return -1;
  }

  gs_emit_service_vars(file, pname, pname, language, libs, "gsservice_template");

  if(batch_mode) {
    bname = dstring_sprintf("%s_batch_service", problem->name);
    if(!bname) {
      ERRPRINTF("Error generating the name of the service\n");
      return -1;
    }

    gs_emit_service_vars(file, bname, pname, language, libs, "gsbatch_template");
  }
  else
    bname = "";

  grpc_pname = dstring_sprintf("%s_grpc_example", problem->name);
  if(!grpc_pname) {
    ERRPRINTF("Error generating the name of the service\n");
    free(pname);
    return -1;
  }

  gs_emit_service_vars(file, grpc_pname, grpc_pname, language, libs, "gsservice_template");

  fprintf(file, "bin_PROGRAMS = %s %s %s\n", pname, grpc_pname, bname);
  fprintf(file, "\n");

  fprintf(file, "include ../template_problem/Makefile.inc\n");

  for(info = problem->infolist; info != NULL; info = info->next) {
    if(!strcmp(info->type, "LIBS"))
      fprintf(file, "__USER_LIBS=%s\n", info->value);
    else
      fprintf(file, "%s=%s\n", info->type, info->value);
  }

  if(!strcmp(gridsolve_root, GRIDSOLVE_TOP_BUILD_DIR))
    fprintf(file, "INCLUDES = -I%s/include -I%s/include $(IBP_INCDIR)\n", GRIDSOLVE_TOP_BUILD_DIR, GRIDSOLVE_TOP_SRC_DIR);
  else 
    fprintf(file, "INCLUDES = -I%s/include $(IBP_INCDIR)\n", gridsolve_root);
  fprintf(file, "\n");
  
  if(linker)
    fprintf(file, "CCLD=%s\n", linker);
  
  gs_emit_service_link(file, parallel, language, pname);
  gs_emit_service_link(file, parallel, language, grpc_pname);
  if(batch_mode) {
    gs_emit_service_link(file, parallel, language, bname);
    fprintf(file, "gs_copy_batch_scripts:\n");
    fprintf(file, "\tcp %s gs_submit\n", submit_script);
    fprintf(file, "\tchmod u+rwx gs_submit\n");
    fprintf(file, "\tcp %s gs_probe\n", probe_script);
    fprintf(file, "\tchmod u+rwx gs_probe\n");
    fprintf(file, "\tcp %s gs_cancel\n", cancel_script);
    fprintf(file, "\tchmod u+rwx gs_cancel\n");
  }

  fprintf(file, "check_f77:\n");
  fprintf(file, "ifeq ($(strip $(F77)),)\n");
  fprintf(file, "\techo no f77\n");
  fprintf(file, "\texit -7\n");
  fprintf(file, "else\n");
  fprintf(file, "\texit 0\n");
  fprintf(file, "endif\n");

  free(pname);
  free(grpc_pname);

  fclose(file);

  return 0;
}

int
gs_idl_generate_description(gs_problem_t * problem)
{
  char *fname = NULL;
  FILE *file = NULL;
  char *problemstr = NULL;

  if(!problem)
    return -1;

  DBGPRINTF("Generating description %s\n", problem->name);

  fname = dstring_sprintf("%s/service/%s/%s.xml",
                          gridsolve_root, problem->name,
                          problem->name);

  if(!fname) {
    ERRPRINTF("Error generating xml service desc name.\n");
    return -1;
  }

  DBGPRINTF("Creating problem description in %s\n", fname);
  if((file = fopen(fname, "w")) == NULL) {
    ERRPRINTF("Error creating problem description file '%s'.\n", fname);
    free(fname);
    return -1;
  }

  free(fname);

  DBGPRINTF("Encoding problem to string\n");
  if(gs_encode_problem(&problemstr, problem) < 0) {
    ERRPRINTF("Failed to encode problem.\n");
    return -1;
  }

  DBGPRINTF("Problem description: %s\n", problemstr);
  fprintf(file, "%s\n", problemstr);

#ifdef GS_DEBUG
  gs_idl_dump_info(problem, problemstr);
#endif

  free(problemstr);
  fclose(file);

  return 0;
}

int
gs_idl_do_make(gs_problem_t * problem, char *target)
{
  char *command;
  int status;

  if(!problem)
    return -1;

  DBGPRINTF("Executing makefile for %s\n", problem->name);

  command =
      dstring_sprintf("cd \"%s/service/%s\"; make -f %s_makefile %s",
                      gridsolve_root, problem->name,
                      problem->name, target);

  if(!command) {
    ERRPRINTF("Error creating command to build target = '%s'\n", target);
    goto gs_idl_do_make_error;
  }

  DBGPRINTF("Make command: %s\n", command);

  status = system(command);

  if((status < 0) || (WEXITSTATUS(status) != 0)) {
    ERRPRINTF("Error building problem (%s), target = '%s'\n", command, target);
    goto gs_idl_do_make_error;
  }

  free(command);
  return 0;

gs_idl_do_make_error:
  if(command)
    free(command);
  return -1;
}

int
gs_idl_create_service_dir(char *suffix)
{
  char *fname;
  struct stat stbuf;
  
  fname = calloc((strlen(gridsolve_root) + strlen("/service/") +
         + (suffix ? strlen(suffix) + 1 : 0) + 1), sizeof(char));
  sprintf(fname, "%s", gridsolve_root);

  /* if the directory doesn't exist, try to create it */
  if(stat(fname, &stbuf) < 0)
    if(mkdir(fname, 0755) < 0)
      return -1;

  sprintf(fname, "%s/service%s%s", gridsolve_root,
          suffix ? "/" : "", suffix ? suffix : "");

  /* if the directory doesn't exist, try to create it */
  if(stat(fname, &stbuf) < 0)
    if(mkdir(fname, 0755) < 0)
      return -1;

  free(fname);
  return 0;
}

int
gs_idl_remove_directory(char *suffix)
{
  char *fname;
  struct stat stbuf;
  struct dirent *dp;
  char *entry;
  DIR *dirp;
  int max;

  if(!suffix)
    return -1;

  fname = calloc((strlen(gridsolve_root) + strlen("/service/") +
          + (suffix ? strlen(suffix) + 1 : 0) + 1), sizeof(char));
  sprintf(fname, "%s", gridsolve_root);

  /* quick return if the root directory doesn't exist */
  if(stat(fname, &stbuf) < 0)
    return 0;

  sprintf(fname, "%s/service%s%s", gridsolve_root,
          suffix ? "/" : "", suffix ? suffix : "");

  /* quick return if the service directory doesn't exist */
  if(stat(fname, &stbuf) < 0)
    return 0;

  dirp = opendir(fname);

  if(!dirp)
    return -1;

  /* find the longest file name so we can allocate the proper size
   * array to hold the fully-qualified name.
   */
  max = 0;
  while ((dp = readdir(dirp)) != NULL)
    if(strlen(dp->d_name) > max)
      max = strlen(dp->d_name);

  rewinddir(dirp);

  /* now remove each file in the service directory */
  if(max > 0) {
    entry = (char *)malloc(strlen(fname) + max + 2);

    if(!entry) return -1;

    while ((dp = readdir(dirp)) != NULL)
    {
      if(strcmp(".", dp->d_name) && strcmp("..", dp->d_name))
      {
        sprintf(entry, "%s/%s", fname, dp->d_name);

        if(unlink(entry) < 0)
        {
          perror("unlink");
          free(entry);
          return -1;
        }
      }
    }
    free(entry);
  }

  (void)closedir(dirp);

  /* finally remove the service directory itself */

  if(rmdir(fname) < 0)
    return -1;

  free(fname);
  return 0;
}

int
gs_idl_find_arg(gs_problem_t *problem, char *tag, gs_argument_t **found_arg)
{
  gs_argument_t *f;
  int found = 0;

  for(f = problem->arglist; f; f = f->next)
    if(!strcmp(f->name, tag)) {
      found = 1;
      break;
    }

  *found_arg = found ? f : NULL;

  return found ? 0 : -1;
}

int
gs_idl_check_dim_expr(gs_problem_t * problem, gs_argument_t *arg)
{
  icl_list_t *vlist, *l;
  int errors;

  errors = 0;

  /* this list holds the names of all the variables used in
   * the dimension expressions.
   */

  vlist = icl_list_new();

  if(gs_get_var_list_from_expr(arg->rowexp, vlist) < 0) {
    ERRPRINTF("Failed to parse row expression '%s'\n", arg->rowexp);
    icl_list_destroy(vlist, free);
    return -1;
  }

  if(gs_get_var_list_from_expr(arg->colexp, vlist) < 0) {
    ERRPRINTF("Failed to parse column expression '%s'\n", arg->rowexp);
    icl_list_destroy(vlist, free);
    return -1;
  }

  for(l=icl_list_first(vlist); l!=NULL; l=icl_list_next(vlist, l)) {
    gs_argument_t *found_arg;

    if(gs_idl_find_arg(problem, (char *)l->data, &found_arg) < 0) {
      ERRPRINTF("Var '%s' not found. (referenced in size expr of '%s')\n",
        (char *)l->data, arg->name);
      errors++;
      continue;
    }

    if(found_arg->objecttype != GS_SCALAR) {
      ERRPRINTF("Unsupported use of non-scalar var '%s' in dim expr\n",
        found_arg->name);
      errors++;
      continue;
    }

    if((found_arg->datatype != GS_INT) &&
       (found_arg->datatype != GS_FLOAT) && 
       (found_arg->datatype != GS_DOUBLE) && 
       (found_arg->datatype != GS_CHAR))
    {
      if((found_arg->datatype == GS_SCOMPLEX) ||
         (found_arg->datatype == GS_DCOMPLEX))
        ERRPRINTF("Unsupported use of complex var '%s' in dim expr\n",
          found_arg->name);
      else
        ERRPRINTF("Unsupported use of non-numeric var '%s' in dim expr\n",
          found_arg->name);

      errors++;
      continue;
    }

    /* make sure the variables referenced in the dimension expression 
     * are IN or INOUT (doesn't apply to VAROUT, FILE, etc).
     */

    if((arg->inout == GS_IN) || (arg->inout == GS_INOUT) ||
       (arg->inout == GS_OUT) || (arg->inout == GS_WORKSPACE)) {
      if((found_arg->inout != GS_IN) && (found_arg->inout != GS_INOUT)) {
        ERRPRINTF("Var '%s' used in dim expr should be defined as IN or INOUT\n",
          found_arg->name);
        errors++;
      }
    }
    else if(arg->inout == GS_VAROUT) {
      if(found_arg->inout != GS_OUT) {
        ERRPRINTF("Var '%s' in dim expr of a VAROUT should be defined as OUT\n",
          found_arg->name);
        errors++;
      }
    }
  }

  icl_list_destroy(vlist, free);
  return errors > 0 ? -1 : 0;
}

int
gs_idl_check_sparse_mat(gs_problem_t * problem, gs_argument_t *arg)
{
  gs_argument_t *found_arg;
  int errors = 0;

  if(arg->inout == GS_WORKSPACE) {
    ERRPRINTF("WORKSPACE not yet supported for sparse matrices (%s)\n",
       arg->name);
    errors++;
  }
  else if(arg->inout == GS_VAROUT) {
    ERRPRINTF("VAROUT not yet supported for sparse matrices (%s)\n",
       arg->name);
    errors++;
  }

  if(gs_idl_find_arg(problem, arg->sparse_attr.nnzexp, &found_arg) < 0) {
    ERRPRINTF("Var '%s' not found. (referenced in NNZ expr of '%s')\n",
      arg->sparse_attr.nnzexp, arg->name);
    errors++;
  }
  else {
    if(found_arg->objecttype != GS_SCALAR) {
      ERRPRINTF("NNZ expr '%s' must be scalar. (referenced in '%s')\n",
        found_arg->name, arg->name);
      errors++;
    }

    if(found_arg->datatype != GS_INT) {
      ERRPRINTF("NNZ expr '%s' must be integer. (referenced in '%s')\n",
        found_arg->name, arg->name);
      errors++;
    }

    if(found_arg->inout != GS_IN) {
      ERRPRINTF("NNZ expr '%s' must be IN only. (referenced in '%s')\n",
        found_arg->name, arg->name);
      errors++;
    }
  }

  if(gs_idl_find_arg(problem, arg->sparse_attr.indices, &found_arg) < 0) {
    ERRPRINTF("Var '%s' not found. (referenced in IDX expr of '%s')\n",
      arg->sparse_attr.indices, arg->name);
    errors++;
  } 
  else {
    if(found_arg->objecttype != GS_VECTOR) {
      ERRPRINTF("IDX expr '%s' must be a vector. (referenced in '%s')\n",
        found_arg->name, arg->name);
      errors++;
    }

    if(found_arg->datatype != GS_INT) {
      ERRPRINTF("IDX expr '%s' must be integer. (referenced in '%s')\n",
        found_arg->name, arg->name);
      errors++;
    }

    if(found_arg->inout != arg->inout) {
      ERRPRINTF("INOUT mode of '%s' and '%s' must match.\n",
        found_arg->name, arg->name);
      errors++;
    }
  }

  if(gs_idl_find_arg(problem, arg->sparse_attr.pointer, &found_arg) < 0) {
    ERRPRINTF("Var '%s' not found. (referenced in PTR expr of '%s')\n",
      arg->sparse_attr.pointer, arg->name);
    errors++;
  } 
  else {
    if(found_arg->objecttype != GS_VECTOR) {
      ERRPRINTF("PTR expr '%s' must be a vector. (referenced in '%s')\n",
        found_arg->name, arg->name);
      errors++;
    }

    if(found_arg->datatype != GS_INT) {
      ERRPRINTF("PTR expr '%s' must be integer. (referenced in '%s')\n",
        found_arg->name, arg->name);
      errors++;
    }

    if(found_arg->inout != arg->inout) {
      ERRPRINTF("INOUT mode of '%s' and '%s' must match.\n",
        found_arg->name, arg->name);
      errors++;
    }
  }

  return errors > 0 ? -1 : 0;
}

int
gs_idl_check_complexity(gs_problem_t *problem)
{
  icl_list_t *vlist, *l;
  char *complexity;
  int errors;

  errors = 0;

  complexity = gs_problem_getinfo(problem, "COMPLEXITY", NULL);

  if(!complexity)
    return 0;

  /* this list holds the names of all the variables used in
   * the complexity expression.
   */

  vlist = icl_list_new();
  
  if(gs_get_var_list_from_expr(complexity, vlist) < 0) {
    ERRPRINTF("Failed to parse complexity expression '%s'\n", complexity);
    icl_list_destroy(vlist, free); 
    return -1;
  } 
  
  for (l=icl_list_first(vlist); l!=NULL; l=icl_list_next(vlist, l)) {
    gs_argument_t *found_arg;
    
    if(gs_idl_find_arg(problem, (char *)l->data, &found_arg) < 0) {
      ERRPRINTF("Var '%s' not found. (referenced in complexity '%s')\n",
        (char *)l->data, complexity); 
      errors++;
      continue;
    }
    
    if(found_arg->objecttype != GS_SCALAR) {
      ERRPRINTF("Unsupported use of non-scalar var '%s' in complexity expr\n",
        found_arg->name);
      errors++;
      continue;
    }
    
    if((found_arg->datatype != GS_INT) &&
       (found_arg->datatype != GS_FLOAT) &&
       (found_arg->datatype != GS_DOUBLE) &&
       (found_arg->datatype != GS_CHAR))
    {
      if((found_arg->datatype == GS_SCOMPLEX) ||
         (found_arg->datatype == GS_DCOMPLEX))
        ERRPRINTF("Unsupported use of complex var '%s' in complexity expr\n",
          found_arg->name);
      else
        ERRPRINTF("Unsupported use of non-numeric var '%s' in complexity expr\n",
          found_arg->name);

      errors++;
      continue;
    }
    
    if((found_arg->inout != GS_IN) && (found_arg->inout != GS_INOUT)) {
      ERRPRINTF("Var '%s' used in complexity expr should be IN or INOUT\n",
        found_arg->name); 
      errors++;
    }
  }

  icl_list_destroy(vlist, free);
  return errors ? -1 : 0;
}

int
gs_idl_check_problems(gs_problem_t * problemlist)
{   
  gs_problem_t *problem;
  int errors;

  errors = 0;

  if(!problemlist)
    return -1;

  for(problem = problemlist; problem != NULL; problem = problem->next) {
    gs_argument_t *arg;

    for(arg = problem->arglist; arg != NULL; arg = arg->next) {
      if(arg->objecttype == GS_SPARSEMATRIX) {
        if(gs_idl_check_sparse_mat(problem, arg) < 0)
          errors++;
      }

      if(gs_idl_check_dim_expr(problem, arg) < 0)
        errors++;
    }

    if(gs_idl_check_complexity(problem) < 0)
      errors++;

  }

  return errors ? -1 : 0;
}

int
gs_idl_compile_problems(gs_problem_t * problemlist)
{
  gs_problem_t *problem;

  if(!problemlist)
    return -1;

  DBGPRINTF("Compiling problemlist\n");

  /* create $GRIDSOLVE_ROOT/service/ */
  gs_idl_create_service_dir(NULL);

  for(problem = problemlist; problem != NULL; problem = problem->next) {
    /* create $GRIDSOLVE_ROOT/service/problem_name */
    gs_idl_create_service_dir(problem->name);

    if(gs_idl_generate_source(problem) < 0) {
      ERRPRINTF("gs_idl_generate_source failed\n");
      if(gs_remove_failed_service)
        gs_idl_remove_directory(problem->name);
      return -1;
    }
    if(gs_idl_generate_makefile(problem) < 0) {
      ERRPRINTF("gs_idl_generate_makefile failed\n");
      if(gs_remove_failed_service)
        gs_idl_remove_directory(problem->name);
      return -1;
    }
    if(gs_idl_generate_description(problem) < 0) {
      ERRPRINTF("gs_idl_generate_description failed\n");
      if(gs_remove_failed_service)
        gs_idl_remove_directory(problem->name);
      return -1;
    }
    if(gs_idl_generate_grpc_example(problem) < 0) {
      ERRPRINTF("Warning: couldn't generate example (probably non-fatal).\n");
    }
    if(gs_idl_do_make(problem, "install") < 0) {
      char * lang;

      lang = gs_problem_getinfo(problem, "LANGUAGE", NULL);

      if(lang && !strcmp(lang, "FORTRAN")) {
        if(gs_idl_do_make(problem, "check_f77") < 0) {
          ERRPRINTF("Build failed: probably due to lack of Fortran compiler.\n");
          if(gs_remove_failed_service)
            gs_idl_remove_directory(problem->name);

          /* continue to allow others to complete */
          continue;
        }
      }

      ERRPRINTF("gs_idl_do_make failed\n");
      if(gs_remove_failed_service)
        gs_idl_remove_directory(problem->name);
      return -1;
    }
    if(gs_problem_getinfo(problem, "BATCH_SUBMIT", NULL) &&
       gs_problem_getinfo(problem, "BATCH_PROBE", NULL) &&
       gs_problem_getinfo(problem, "BATCH_CANCEL", NULL))
    {
      if(gs_idl_do_make(problem, "gs_copy_batch_scripts") < 0) {
        ERRPRINTF("gs_idl_do_make failed\n");
        if(gs_remove_failed_service)
          gs_idl_remove_directory(problem->name);
        return -1;
      }
    }
  }

  return 0;
}

int
gs_idl_parse_and_compile(char *idlfile)
{
  FILE *fin = NULL;
  int status = -1;

  /* Used by the lexer and parser */
  extern gs_problem_t *problemp;
  extern int idl_parse();
  extern FILE *idl_in;

  if(!idlfile)
    return -1;

  if((fin = fopen(idlfile, "r")) == NULL) {
    ERRPRINTF("Could not open idl file: %s \n", idlfile);
    return -1;
  }

  DBGPRINTF("Calling parser\n");
  idl_in = fin;
  status = idl_parse();
  fclose(fin);
  idl_lexer_free_memory();

  if(status != 0)
    return -1;

  status = gs_idl_check_problems(problemp);

  if(status < 0) {
    gs_free_problem(problemp);
    return -1;
  }

  status = gs_idl_compile_problems(problemp);

  gs_free_problem(problemp);

  return status;
}

int
gs_idl_dump_info(gs_problem_t * problem, char *problemstr)
{
  if(!problem || !problemstr)
    return -1;

  DBGPRINTF("Dumping the xml\n %s\n", problemstr);

  return 0;
}

int
gs_idl_compiler_parse_cmd_line(int argc, char **argv,
  char ***idlfiles, int *remove_failed)
{
  int c;

  *remove_failed = 1;

  /* when making changes to the command line args, update
   * GS_COMPILER_USAGE_STR so the usage information is printed
   * correctly upon error.
   */

#define GS_COMPILER_USAGE_STR \
  "Usage: GS_problem_compiler [-k] <IDL Files...>"

  while((c = getopt(argc,argv,"k")) != EOF) {
    switch(c) {
      case 'k':
        *remove_failed = 0;
        break;
      case '?':
        return -1;
        break;
      default:
        ERRPRINTF("Bad arg: '%c'.\n",c);
        return -1;
    }
  }

  *idlfiles = (char **)malloc((argc - optind + 1) * sizeof(char *));

  if(!*idlfiles)
    return -1;

  for (c = optind; c < argc; c++) {
    (*idlfiles)[c-optind] = strdup(argv[c]);
    if(!(*idlfiles)[c-optind])
      return -1;
  }
  (*idlfiles)[argc-optind] = NULL;
  return 0;
}

int
main(int argc, char *argv[])
{
  int i, failure = 0;
  char **idlfiles;

  if(gs_idl_compiler_parse_cmd_line(argc, argv, &idlfiles, 
      &gs_remove_failed_service) < 0) {
    ERRPRINTF("%s\n", GS_COMPILER_USAGE_STR);
    exit(EXIT_FAILURE);
  }

  if(!(gridsolve_root = getenv("GRIDSOLVE_ROOT"))) 
    gridsolve_root = GRIDSOLVE_TOP_BUILD_DIR;

  if(!gridsolve_root) {
    ERRPRINTF("Error: GRIDSOLVE_ROOT could not be set.  ");
    ERRPRINTF("Please check the environment variables.\n");
    exit(EXIT_FAILURE);
  }

  for(i=0;idlfiles[i];i++) {
    if(gs_idl_parse_and_compile(idlfiles[i]) < 0) {
      ERRPRINTF("Failed to compile '%s'\n", idlfiles[i]);
      failure = 1;
    }
  }

  if(failure) {
    ERRPRINTF("Some IDL files could not be compiled \n");
    ERRPRINTF("Possible problems Check the environment variables especially GRIDSOLVE_ROOT.\n");
    ERRPRINTF("GridSolve expects to find files in $GRIDSOLVE_ROOT/include and $GRIDSOLVE_ROOT/lib\n");
  }

  /* temporarily return SUCCESS always.  when we add the capability
   * to parse the enabled problems from server_config, we should
   * change this back so that failures are fatal.
   */

  /*  exit(failure ? EXIT_FAILURE : EXIT_SUCCESS); */
  exit(EXIT_SUCCESS);
}