static char rcsid[] = "$Id: F-main.c,v 1.39 2001/10/18 09:02:26 msato Exp $";
/* 
 * $RWC_Release: Omni-1.6 $
 * $RWC_Copyright:
 *  Omni Compiler Software Version 1.5-1.6
 *  Copyright (C) 2002 PC Cluster Consortium
 *  
 *  This software is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU Lesser General Public License version
 *  2.1 published by the Free Software Foundation.
 *  
 *  Omni Compiler Software Version 1.0-1.4
 *  Copyright (C) 1999, 2000, 2001.
 *   Tsukuba Research Center, Real World Computing Partnership, Japan.
 *  
 *  Please check the Copyright and License information in the files named
 *  COPYRIGHT and LICENSE under the top  directory of the Omni Compiler
 *  Software release kit.
 *  
 *  
 *  $
 */

/* Fortran lanuage front-end */

#include "F-front.h"
#include <math.h>

/* for debug */
int debug_flag = 0;
FILE *debug_fp;
FILE *diag_file;

/* for NaN checking */
int doNaNCheck = FALSE;
int doCoreDumpWhenNaN = FALSE;

/* for pedantic syntax mode */
int doPedanticEquiv = FALSE;
int doPedanticDataType = FALSE;
int doPedanticCommon = FALSE;

/* for i386 only */
int doubleAlign = FALSE;

/* save all Array (for shmem OpenMP) */
int saveArray = FALSE;

/* quad-real, complex folding enabler */
int doQCZFolding = TRUE;

/* quad/multiple precision real optimization */
int doQRealOpt = TRUE;

/* default variable type */
BASIC_DATA_TYPE defaultSingleRealType = TYPE_REAL;
BASIC_DATA_TYPE defaultDoubleRealType = TYPE_DREAL;
BASIC_DATA_TYPE defaultIntType = TYPE_INT;

#ifdef ENABLE_QREAL
/* quad/multi precision real size */
int qRealPrec = OMNI_QREAL_PREC;
int gmpLimbSize = OMNI_QLIM_LEN;
#endif /* ENABLE_QREAL */

/* Treat implicit typed variable as undefined. */
int doImplicitUndef = FALSE;

/* the number of errors */
int nerrors;

char *source_file_name = NULL;
char *output_file_name = NULL;
FILE *source_file,*output_file;
unsigned long int maxStackSize = 0;

extern int	yyparse _ANSI_ARGS_((void));
static void	check_nerrors _ANSI_ARGS_((void));


#define DEFAULT_STACK_MAX	8*1024*1024
static unsigned long int
getCurrentStackSize()
{
#ifdef OMNI_OS_CYGWIN32
    return DEFAULT_STACK_MAX;
#else    
    struct rlimit limit;

    if (getrlimit(RLIMIT_STACK, &limit) < 0) {
	/*
	 * Wild guess
	 */
	return DEFAULT_STACK_MAX;
    }
    return (unsigned long int)(limit.rlim_cur);
#endif /* OMNI_OS_CYGWIN32 */
}


static int
getVarSize(str)
     char *str;
{
    int ret = 0;
    char *ePtr = NULL;

    if (str == NULL || *str == '\0') {
	return 0;
    }
    ret = strtol(str, &ePtr, 10);
    if (ePtr != str) {
	return ret;
    } else {
	return 0;
    }
}


#ifdef ENABLE_QREAL

static void *	gmpAlloc _ANSI_ARGS_((size_t sz));
static void *	gmpRealloc _ANSI_ARGS_((void *ptr, size_t oSz, size_t nSz));
static void	gmpFree _ANSI_ARGS_((void *ptr, size_t sz));

static void *
gmpAlloc(sz)
     size_t sz;
{
    return (void *)malloc(sz);
}

static void *
gmpRealloc(ptr, oSz, nSz)
     void *ptr;
     size_t oSz, nSz;
{
    return (void *)realloc(ptr, nSz);
}

static void
gmpFree(ptr, sz)
     void *ptr;
     size_t sz;
{
    (void)free(ptr);
}

static void
calcMPrecValue()
{
    mpf_t tmp;

    mpf_set_default_prec((unsigned long int)qRealPrec);

    /*
     * We don't need performance so far avoiding allocate/dealocate overhead.
     * Instead, for people who didn't unlimit stack size, use heap for
     * gmp library.
     */

    mp_set_memory_functions(gmpAlloc, gmpRealloc, gmpFree);

    mpf_init(tmp);
    gmpLimbSize = ((__mpf_struct *)(&tmp))->_mp_prec + 1;
    mpf_clear(tmp);
}
#endif /* ENABLE_QREAL */


int
main(argc, argv) 
     int argc; 
     char *argv[]; 
{ 
    extern int yydebug;
    int parseError = 0;

    maxStackSize = getCurrentStackSize();

#ifdef HAVE_SETLOCALE
    (void)setlocale(LC_ALL, "C");
#endif /* HAVE_SETLOCALE */

    --argc;
    ++argv;
    
    /* parse command line */
    while(argc >0 && argv[0][0] == '-'){
	if (strcmp(argv[0],"-d") == 0) {
	    ++debug_flag;
	} else if (strcmp(argv[0], "-yd") == 0) {
	    yydebug = 1;
	} else if (strcmp(argv[0],"-omp") == 0){
	    OMP_flag = FALSE;	/* disable openmp */
	} else if (strcmp(argv[0], "-checkNaN") == 0) {
	    doNaNCheck = TRUE;
	} else if (strcmp(argv[0], "-coredumpNaN") == 0) {
	    doNaNCheck = TRUE;
	    doCoreDumpWhenNaN = TRUE;
	} else if (strcmp(argv[0], "-pedanticEquivalence") == 0) {
	    doPedanticEquiv = TRUE;
	} else if (strcmp(argv[0], "-pedanticDataType") == 0) {
	    doPedanticDataType = TRUE;
	} else if (strcmp(argv[0], "-pedanticCommon") == 0) {
	    doPedanticCommon = TRUE;
	} else if (strcmp(argv[0], "-pedanticAll") == 0) {
	    doPedanticEquiv = TRUE;
	    doPedanticDataType = TRUE;
	    doPedanticCommon = TRUE;
	} else if (strcmp(argv[0], "-doubleAlign") == 0) {
#ifdef OMNI_CPU_I386
	    doubleAlign = TRUE;
#else
	    doubleAlign = FALSE;
#endif /* OMNI_CPU_I386 */
	} else if (strcmp(argv[0], "-saveArray") == 0) {
	    saveArray = TRUE;
	} else if (strncmp(argv[0], "-maxStackSize=", 14) == 0) {
	    int	base = 10;
	    int num;
	    char *ptr = strchr(argv[0], '=') + 1;
	    char *ePtr = NULL;
	    if (ptr == NULL || *ptr == '\0') {
		fprintf(stderr, "must specify max stack size.\n");
		exit(1);
	    }
	    if (*ptr == '0') {
		if (ptr[1] == 'X' || ptr[1] == 'x') {
		    base = 16;
		    ptr += 2;
		} else {
		    base = 8;
		} 
	    }
	    num = strtol(ptr, &ePtr, base);
	    if (ePtr != ptr) {
		maxStackSize = num;
	    } else {
		fprintf(stderr, "can't parse max stack size.\n");
		exit(1);
	    }
	} else if (strcmp(argv[0], "-ffixed-line-length-132") == 0) {
	    extern int fixed_line_len;
	    fixed_line_len = 132;
	} else if (strcmp(argv[0], "-disableQCZFolding") == 0) {
	    doQCZFolding = FALSE;
	} else if (strcmp(argv[0], "-disableQOpt") == 0) {
	    doQRealOpt = FALSE;
	} else if (strcmp(argv[0], "-u") == 0) {
	    doImplicitUndef = TRUE;
	} else if (strcmp(argv[0], "-C") == 0) {
	    fprintf(stderr, "warning: Array range check is not supported, just ignore this option.\n");
	} else if (strncmp(argv[0], "-i", 2) == 0) {
	    int sz = getVarSize(argv[0] + 2);
	    char eMsg[1024];
#ifdef HAS_INT64
	    sprintf(eMsg, "invalid integer size %%d, must be %d, %d or %d.\n",
		    SIZEOF_UNSIGNED_SHORT,
		    SIZEOF_UNSIGNED_INT,
		    SIZEOF_UNSIGNED_LONG_LONG);
#else
	    sprintf(eMsg, "invalid integer size %%s, must be %d or %d.\n",
		    SIZEOF_UNSIGNED_SHORT,
		    SIZEOF_UNSIGNED_INT);
#endif /* HAS_INT64 */
	    switch (sz) {
		case SIZEOF_UNSIGNED_SHORT:	defaultIntType = TYPE_SHORT; break;
		case SIZEOF_UNSIGNED_INT:	defaultIntType = TYPE_INT; break;
#ifdef HAS_INT64
		case SIZEOF_UNSIGNED_LONG_LONG:	defaultIntType = TYPE_LONGLONG; break;
#endif /* HAS_INT64 */
		default: {
		    fprintf(stderr, eMsg, sz);
		    exit(1);
		}
	    }
	} else if (strncmp(argv[0], "-r", 2) == 0) {
	    int sz = getVarSize(argv[0] + 2);
	    switch (sz) {
		case SIZEOF_FLOAT:	defaultSingleRealType = TYPE_REAL; break;
		case SIZEOF_DOUBLE:	defaultSingleRealType = TYPE_DREAL; break;
		default: {
		    fprintf(stderr, "invalid single-real size %d, must be %d or %d.\n",
			    sz, SIZEOF_FLOAT, SIZEOF_DOUBLE);
		    exit(1);
		}
	    }
	} else if (strncmp(argv[0], "-d", 2) == 0) {
	    int sz = getVarSize(argv[0] + 2);
	    switch (sz) {
		case SIZEOF_FLOAT:	defaultDoubleRealType = TYPE_REAL; break;
		case SIZEOF_DOUBLE:	defaultDoubleRealType = TYPE_DREAL; break;
		default: {
		    fprintf(stderr, "invalid double-real size %d, must be %d or %d.\n",
			    sz, SIZEOF_FLOAT, SIZEOF_DOUBLE);
		    exit(1);
		}
	    }
	} else if (strncmp(argv[0], "-m", 2) == 0) {
#ifdef ENABLE_QREAL
	    int sz;
	    if (strncmp(argv[0], "-md", 3) == 0) {
		double d;
		sz = getVarSize(argv[0] + 3);
		if (sz <= 15) {
		    fprintf(stderr, "warning: quad/multiple precision must be greater than 15 digits.\n");
		    qRealPrec = 53;
		} else {
		    d = (double)sz / log10(2.0);
		    qRealPrec = (int)d + 1;
		}
	    } else {
		sz = getVarSize(argv[0] + 2);
		if (sz <= 52) {
		    fprintf(stderr, "warning: quad/multiple precision must be greater than 52 bits.\n");
		    sz = 53;
		}
		qRealPrec = sz;
	    }
#else
	    fprintf(stderr, "warning: quad/multiple precision is not supported.");
#endif /* ENABLE_QREAL */
	} else {
	    fprintf(stderr,"unknown flag: %s\n",argv[0]);
	    exit(1);
	}
	--argc;
	++argv;
    }

    if(argc > 0){
	source_file_name = argv[0];
	if((source_file = fopen(source_file_name,"r")) == NULL){
	    fprintf(stderr,"cannot open %s\n",source_file_name);
	    exit(1);
	}
    } else {
	source_file = stdin;
    }
    
    if(argc > 1){
	output_file_name = argv[1];
	if((output_file = fopen(output_file_name,"w")) == NULL){
	    fprintf(stderr,"cannot open %s\n",output_file_name);
	    exit(1);
	}
    } else output_file = stdout;

    /* DEBUG */
    debug_fp = stderr;
    diag_file = stderr;

#ifdef ENABLE_QREAL
    calcMPrecValue();
#endif /* ENABLE_QREAL */

    initialize_lex();
    initialize_compile();
    
    /* start processing */
    parseError = yyparse();
    if (nerrors != 0 ||
	parseError != 0) {
	goto Done;
    }
    nerrors = 0;
    
    finalize_compile();
    if (nerrors != 0) {
	goto Done;
    }

    output_X_file();

    Done:
    if (nerrors != 0) {
	if (output_file_name != NULL) {
	    fclose(output_file);
	    (void)unlink(output_file_name);
	}
    }

    return(nerrors?1:0);
}

void
where(lineno_info *ln)
{ 
    /* print location of error  */
    if (ln != NULL) {
	fprintf(stderr, "\"%s\", line %d: ",FILE_NAME(ln->file_id), ln->ln_no);
    } else {
	fprintf(stderr, "\"??\", line ??: ");
    }
}

/* nonfatal error message */
/* VARARGS0 */
void
error EXC_VARARGS_DEF(char *, fmt)
{ 
    va_list args;

    ++nerrors;
    where(current_line);
    EXC_VARARGS_START(char *, fmt, args);
    vfprintf(stderr, fmt, args);
    va_end(args);
    fprintf(stderr, "\n" );
    fflush(stderr);
    check_nerrors();
}


/* VARARGS0 */
void
error_at_node EXC_VARARGS_DEF(expr, x)
{
    va_list args;
    char *fmt;

    ++nerrors;
    EXC_VARARGS_START(expr, x, args);
    where(EXPR_LINE(x));
    fmt = va_arg(args, char *);
    vfprintf(stderr, fmt, args);
    va_end(args);
    fprintf(stderr, "\n" );
    fflush(stderr);
    check_nerrors();
}


/* VARARGS0 */
void
warning_at_node EXC_VARARGS_DEF(expr, x)
{ 
    va_list args;
    char *fmt;

    where(EXPR_LINE(x)); /*, "WarnAtNode"); */
    fprintf(stderr,"warning: ");
    EXC_VARARGS_START(expr, x, args);
    fmt = va_arg(args, char *);
    vfprintf(stderr, fmt, args);
    va_end(args);
    fprintf(stderr, "\n" );
    fflush(stderr);
}


static void
check_nerrors()
{
    if(nerrors > 30)
      {
	  /* give the compiler the benefit of the doubt */
	  fprintf(stderr, 
		  "too many error, cannot recover from earlier errors: goodbye!\n" );
	  exit(1);
      }
}

/* compiler error: die */
/* VARARGS1 */
void
fatal EXC_VARARGS_DEF(char *, fmt)
{ 
    va_list args;
    
    where(current_line); /*, "Fatal");*/
    fprintf(stderr, "compiler error: " );
    EXC_VARARGS_START(char *, fmt, args);
    vfprintf(stderr, fmt, args);
    va_end(args);
    fprintf(stderr, "\n" );
    fflush(stderr);
    abort();
}

int warning_flag = FALSE; 

/* warning */
void
warning EXC_VARARGS_DEF(char *, fmt)
{  
    va_list args;
  
    if (warning_flag) return;
    where(current_line); /*, "Warn");*/
    EXC_VARARGS_START(char *, fmt, args);
    fprintf(stderr, "warning: " );
    vfprintf(stderr, fmt, args);
    va_end(args);
    fprintf(stderr, "\n" );
    fflush(stderr);
}