/*===========================================================================
  Copyright (C) 1995-2009 European Southern Observatory (ESO)
 
  This program 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 2 of 
  the License, or (at your option) any later version.
 
  This program 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 this program; if not, write to the Free 
  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
  MA 02139, USA.
 
  Correspondence concerning ESO-MIDAS should be addressed as follows:
	Internet e-mail: midas@eso.org
	Postal address: European Southern Observatory
			Data Management Division 
			Karl-Schwarzschild-Strasse 2
			D 85748 Garching bei Muenchen 
			GERMANY
===========================================================================*/

/*++++++++++++++
.TYPE		Module
.NAME		forif.c
.LANGUAGE	C
.AUTHOR		Francois Ochsenbein [ESO-IPG]
.CATEGORY	C Compiler
.PURPOSE	
.ENVIRONMENT	Machines with 4-byte addresses.
.COMMENTS	This module parses the ".fc" file to create a .c file.
		The -f parameter specifies how to convewrt routine names.
		It is made of up to 3 characters as [_]C[_]
		where the optional _ mean "add underscore as prefix/sufix"
		and C is l for Lowercase, u for Uppercase, 
		.(dot) for no transformation
		The -v parameter (optional) specifies how to create the 
		common variable "vmr" name. 
		It uses the same syntax as -f.names. 
.VERSION 

 090120		last modif

---------------------------------------------------*/

#include <atype.h>	/* ASCII classification		*/
#include <macrogen.h>	/* General utility macros	*/
#include <errno.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>

#include <proto_os.h>



#if VMS
static char *FORname = "U";	/* Convert to UPPER case,          */
#else
static char *FORname = "l_";	/* Convert to lower case, append _ */
#endif
static char *VMRname;

static int IN = 0;		/* Input  File */
static int OUT = 1;		/* Output File */

#define OK	1
#define NOK	0

#define error0(t)	error(NULL_PTR(char),NULL_PTR(char))
#define error1(t)	error(t,NULL_PTR(char))
#define emits(s)	emit(s, strlen(s))
#define emitq()		emit(printed, pmatched - printed), printed = pmatched

#ifdef isid
#undef isid
#define isid(c)	 (isalnum(c) || (c == '_') || (c == '$')|| (c == '.'))
#endif

#define SYMSIZE		44	/* Maximum length of a symbol		*/

#define _BYTE_		0
#define _SHORT_		1
#define _INT_		2
#define _LONG_		3
#define _FLOAT_		6
#define _DOUBLE_	7
#define _CHARACTER_	8
#define _FINT2C_	9
#define _FLONG2C_	10


/* Definition of Token Classes	*/

#define NONE		0
#define DONE		14
#define DECLARE		15
#define SUBROUTINE	16
#define IDENTIFIER	17
#define ARGUMENT	18		/* Found in SUBROUTINE	*/
#define INUM		19		/* Integer  constant	*/
#define FNUM		20		/* Floating constant	*/
#define SNUM		21		/* String   constant	*/
#define RETURN		22	
#define FOR		23	
#define ROUTINE		24


/* see, if we use #include <varargs.h> (C compilers until April 2003)
               or #include <stdarg.h>  (from gcc3.3 on)	*/


#ifdef VARARGS
static int use_stdarg = 0;
#else
static int use_stdarg = 1;
#endif

typedef struct { 	/* Symbol element	*/
	char	*name;
	char	token; 	/* Token class		*/
	char	pno;	/* Parameter number (1)	*/
	char	sno;	/* Parameter number (0)	*/
	char	dty;	/* Data type        	*/
    } SYMBOL;


/* Declare variables required for the lexical analysis	*/

static long   	value = 0;

static int 	lookahead = 0;
static int	argno = 0;		/* Number of Arguments	*/
static int	found_errors;	/* Collects the errors	*/
static int 	lineno = 1;
static int	brace_level = 0;
static int 	symbols = 0;

static char 	lexbuf[SYMSIZE+3];
static char	*avalue;
static char	execute_mark;	/* Flag 1 = va_dcl to write / 2 = FORmark \
					4 = ftoc_free */
static char	*psource, *printed, *pmatched;

static SYMBOL	*found_symbol;
static SYMBOL 	symbol_table[128] ;

#define issign(c)		((c == '+') || (c == '-'))


/* Static recursive functions are declared */

static int expr0(), expr(), stmt();

/*===========================================================================*/
static void synopsis()
/*+++++
.PURPOSE Just display some help
.RETURNS ??
--------------*/

{
static char *text[] = {
	  "Usage: forif [-fT] [-vT] [-sN] [input_file] [output_file]",
	  "       -f transform names of routines",
	  "       -v transform name of variable vmr",
	  "       T specifies how to transform names (default ._)",
	  "       N provides size of file"
	};
char **p;
int i;
  

for (p = text, i = ITEMS(text); --i >= 0; p++)
   osdwrite(2, *p, strlen(*p)), osdwrite(2, "\r\n", 2);
}

/*==========================================================================
 *			String Utilities (extracted from str1.c)
 *===========================================================================*/
static int strcopy(dest, source)
/*+++++++
.PURPOSE Copy strings, taking care of possible overlays.
.RETURNS Length of destination.
---------*/
char *dest;	/* OUT: destination string 	*/
char *source;	/* IN: source string 	*/

{
register int len;


if (source)
   {
   len = strlen(source); 	
   oscopy(dest, source, len+1);
   }
else
   {
   *dest = '\0';
   len = 0;
   }

return(len);
}

static char *strsave(s)
/*+++++
.PURPOSE Save a string
.RETURNS Address of saved string
------*/
char *s;	/* IN: String to save */

{
int len; char *new;


len = 1 + strlen(s);
new = osmmget(len);
oscopy (new, s, len);
return(new);
}

#define strfree(s)	osmmfree(s)

static int strlower ( str )
/*+++++++++
.PURPOSE  Converts (in place) a string to lower case
.RETURNS  Length of string
--------*/
    char *str;	/* MOD: starting address        */

{
register char *p;


for (p = str; *p; p++) *p = tolower(*p); 
return(p-str);
}

static int strupper ( str )
/*+++++++++
.PURPOSE  Converts (in place) a string to upper case
.RETURNS  Length of string
--------*/
    char *str;	/* MOD: starting address        */

{
register char *p;


for (p = str; *p; p++) *p = toupper(*p); 
return(p-str);
}

#define strdiff(s1,s2)	strcmp(s1,s2)

/*===========================================================================*/
static int getx()
/*+++++
.PURPOSE Get next char
.RETURNS Next char
--------------*/

{
int	c;


c = *(psource++);
if (c == '\n')	lineno += 1;

return(c);
}

static int ungetx()
/*+++++
.PURPOSE Get next char
.RETURNS Deleted char
--------------*/

{
int	c;


c = *(--psource);
if (c == '\n')	lineno -= 1;

return(c);
}

/*===========================================================================*/
static int error(txt, str)
/*+++++
.PURPOSE Error report
.RETURNS Error count
.REMARKS Error always logged on two lines
--------------*/
char	*txt;	/* IN: Text of error text	*/
char	*str;	/* IN: Continuation of error	*/

{
static	char errmsg[] = "Error in line 9999: ";
int	no, i;


oscfill(&errmsg[sizeof(errmsg)-7], 4, ' ');
for (i = sizeof(errmsg)-3, no = lineno; no; no /= 10)
   errmsg[--i] = '0' + no%10;

osdwrite(2, errmsg, sizeof(errmsg)-1);

if (txt) osdwrite(2, txt, strlen(txt));
if (str) osdwrite(2, str, strlen(str));

osdwrite(2, "\r\n", 2);

return(++found_errors);
}

/*===========================================================================*/
static SYMBOL *lookup(s)
/*+++++
.PURPOSE Lookup
.RETURNS Pointer to relevant entry / NULL if fail
.REMARKS Table is scanned from beginning
--------------*/
char	*s;	/* IN: String to locate	*/

{
SYMBOL *p;
int    i;


for (i = symbols, p = symbol_table; --i >= 0; p++)
   if (strdiff(s, p->name) == 0) return(p);

return((SYMBOL *)0);
 	
}

static SYMBOL *insert(s, tok, pno, dty)
/*+++++
.PURPOSE Insert symbol
.RETURNS Allocated symbol address
.REMARKS Don't check if name already exists.
--------------*/
char	*s;	/* IN: Symbol Name to Insert, or NULL */
int	tok;	/* IN: Token Class	*/
int	pno;	/* IN: Parameter number	*/
int	dty;	/* IN: Data type	*/

{
SYMBOL	*p;



if (symbols < ITEMS(symbol_table)) 
   {
   p = &symbol_table[symbols++];
   p->name = strsave(s);
   p->token= tok;
   p->pno  = pno;
   p->dty  = dty;
   p->sno  = 0;
   }
else	
   p = (SYMBOL *)0;

return(p);
}

static SYMBOL *pops()
/*+++++
.PURPOSE Remove latest entered symbol from Local Table
.RETURNS Address of popped symbol
--------------*/

{
SYMBOL	*ps;

  
if (symbols > 0) 
   {
   ps = &symbol_table[--symbols];
   strfree(ps->name);
   }
else	
   ps = (SYMBOL *)0;
  
return(ps);
}

/*===========================================================================*/
static int emit(t, len)
/*+++++
.PURPOSE Write to Output
.RETURNS len
--------*/
char    *t;	/* IN: Token class	*/
int	len;	/* IN: How many bytes	*/

{
osdwrite (OUT, t, len);
return(len);
}

/*===========================================================================*/
static int match_line()
/*+++++
.PURPOSE Match the line (preprocessor statements)
.RETURNS Number of matched lines
.REMARKS Several lines if termination with \
-------*/
{
int	t, previous;
int	starting_line;


starting_line = lineno;	
previous = 0;

while ((t = getx()))
   {
   if ((t == '\n') && (previous != '\\')) break;
   previous = t;
   }

pmatched = psource;
return (lineno - starting_line);
}

static int match_comment()
/*+++++
.PURPOSE Match the end of a comment 
.RETURNS OK / NOK
.REMARKS Don't forget to count the newlines...
-------*/
{
int	t, stat;



stat = OK;
while ((t = getx()))
   {	
   if (t != '*') continue;

   t = getx();	/* Char following the * must be a / ... */
   if (t == '/')	break;
   if (t == EOS)	break;
   ungetx();
   }

if (t == EOS) 
   stat = NOK, error1("Non-terminated comment");

pmatched = psource;
return(stat);
}

/*===========================================================================*/
static int match_num()
/*+++++
.PURPOSE Match a number (double floating), also in hexa form (0x...)
.RETURNS Type (int / float) as INUM / FNUM (number stored in local buffer)
.REMARKS Number stored in value (integer) and fvalue (float). Not really useful
	here, but ...
-------*/
{
char 	x, t;
int	i, stat;
double	atof();
long	atol();
char	the_number[80];
  

value = i = 0, stat = INUM;

while( ((t = getx())) == '0');	/* Skip leading zeroes, not significant */

if (tolower(t) == 'x') 
   {				/* It's 0x hexa representation...	*/
   for (t = getx(); isxdigit(t); t = getx()) 
      {
      if (isdigit(t))	i = t - '0';
      else		i = toupper(t) - ('A' - 10);
      value = (value<<4) | i;
      }
   ungetx();
   return(stat);
   }

while (isdigit(t) && (i < sizeof(the_number)-3))	
   the_number[i++] = t, t = getx();	/* Take digits before .	*/

if (t == '.')	 
   {			/* Floating-point Number*/
   stat = FNUM;
   the_number[i++] = t, t = getx();

   while (isdigit(t) && (i < sizeof(the_number)-3))	
      the_number[i++] = t, t = getx();    /* decimals	*/
	
   if (isalpha(t))  
      {					/* Look for Exponent 	*/
      x = toupper(t);
      if ((x == 'E') || (x == 'D'))	
         {
  	 the_number[i++] = 'e', t = getx();
  	 if (issign(t))	the_number[i++] = t, t = getx();

  	 while (isdigit(t) && (i < sizeof(the_number)-1))	
  	    the_number[i++] = t, t = getx();
         }
      }
   }

the_number[i] = EOS;			/* Terminate the String	*/
ungetx();

if (stat == FNUM) 
   ;					/* was: fvalue = atof(the_number);*/ 
else	
   value = atol(the_number);
  
return(stat);
}
  
/*===========================================================================*/
static int match_char()
/*+++++
.PURPOSE Match a character x or \x
.RETURNS INUM 
.REMARKS Number stored in value 
-------*/
{
	int	i;
	char	t;
  
  value = 0;

  if ((t = getx()) == '\\') switch(t = getx()) {
    case 'n': value = '\n'; break;	/* Newline	*/
    case 'r': value = '\r'; break;	/* <Return>	*/
    case 't': value = '\t'; break;	/* Horiz. Tab	*/
    case 'b': value = '\b'; break;	/* Backspace	*/
    case 'f': value = '\f'; break;	/* Form Feed	*/
    default : value = t;    break;
    case '0': case '1': case '2': case '3':	/* Octal number */
    	for(i=3; (--i >= 0) && isdigit(t); t = getx())
		value = value*8 + (t - '0'); 
	if ((i < 0) || !isdigit(t))	ungetx();
	break;
  } 
  else	value = (unsigned char)t;

  return(INUM);
}
  
/*===========================================================================*/
static int match_str()
/*+++++
.PURPOSE Match a string.
.RETURNS SNUM 
-------*/
{
  match_char();
  for (; value; match_char()) if (value == '\"') break;
  if (value != '\"')	error1("Non-terminated string constant");

  return(SNUM);
}
  
/*===========================================================================*/
static int match_id()
/*+++++
.PURPOSE Match an identifier.
.RETURNS Token class as found in tables, or ID when new identifier
.REMARKS found_symbol contains on return the found symbol.
	avalue contains on return the found name.
-------*/
{
	int	tc, b;
	SYMBOL	*p;
	char	t;

  t = getx(), b = 0, tc = IDENTIFIER;
  
  while ((isid(t)) && (b < SYMSIZE)) {
  	lexbuf[b++] = t;
  	t = getx();
  }
/*  token_name = lexbuf; */
  lexbuf[b] = EOS, ungetx();
  if (b >= SYMSIZE)	
		error("Too long symbol: ", lexbuf);

  if ((p = lookup(lexbuf))) 
	found_symbol = p,
	avalue = p->name, 
	tc = p->token;
  else 	found_symbol = (SYMBOL *)0,
	avalue = lexbuf;

  return(tc);
}

/*===========================================================================*/
static int lexan()
/*+++++
.PURPOSE Lexical Analyzer
.RETURNS Token Symbol
--------------*/
{
	int	tc;
	char	t;

  tc = DONE;
  while(lookahead != DONE) {
  	switch(t = getx()) {
  	  case EOS: 			return(DONE);
  		
  	  case '/':	/* Check for Comments */
  		t = getx();
  		if (t == '*') {	/* It's a comment	*/
  			match_comment();
  			continue;
  		}
		ungetx();
		t = '/';		break;		

  	  case '\'':	/* Character */
  	  	tc = match_char();
  	  	if (getx() != '\'')
  	  		error1("Missing ' in Character");
  	  				return(tc);

  	  case '\"':	/* String */
  	  	tc = match_str();
  	  				return(tc);
  	}

	if(isspace(t))	continue;	/* Includes \n	*/

  	if (isdigit(t) || (t == '.')) {	/* Check for a Number	*/
  		ungetx();
  		tc = match_num();
  		break;
  	}

  	if (isid1(t)) {		/* Check for Known Identifier	*/
  		ungetx();
  		tc = match_id();
  		break;
  	}

		/* No token matched. Use just the next byte	*/
	tc = t;
  	break;
  }
  return(tc);
}

/*===========================================================================*/
static char *tr_sym(ps)
/*+++++
.PURPOSE Transform symbol for Output
.RETURNS Pointer to text
.REMARKS 
--------------*/
	SYMBOL	*ps;	/* IN: Symbol to edit */
{
	static char text[40];
	char	*p;
	int	i;


  if ((ps->dty & 0xf) == _CHARACTER_) {
  	sprintf(text, "%d,%d,%d", ps->pno, argno, ps->sno);
  }
  else  {			/* Write PARAM(pno, argno, sno, type *) */
	switch(ps->dty & 0xf) {
	    case _BYTE_ : 	p = "char ";	break;
	    case _SHORT_:	p = "short ";	break;
	    case _LONG_:	p = "long ";	break;
	    case _INT_:		p = "int ";	break;
	    case _FLOAT_:	p = "float ";	break;
	    case _DOUBLE_:	p = "double ";	break;
	    case _FINT2C_:	p = "fint2c ";	break;
	    case _FLONG2C_:	p = "flong2c ";	break;
	    default:		p = "<dtype> ";	break;
	}
  	sprintf(text, "PARAM(%d,%d,%d,%s", ps->pno, argno, ps->sno, p);
	p = text + strlen(text);
	for (i = ps->dty; i >= 0x10; i -= 0x10)	*(p++) = '*';
	p[0] = ')'; p[1] = EOS;
  }
  return (text);
}

/*===========================================================================*/
static char *atok(t, islookahead)
/*+++++
.PURPOSE Transform token to a comprehensive text
.RETURNS Pointer to text
.REMARKS 
--------------*/
	int	t;		/* IN: token class 			*/
	int	islookahead;	/* IN: 1 if token has symbol in lexbuf	*/
{
	static char text[SYMSIZE+24];
	char	*p;

  p = NULL_PTR(char);
  if (isascii(t))		/* Single character */
	islookahead = 0, 
  	text[0] = '`', text[1] = t, text[2] = '\'', text[3] = EOS;
  else  switch(t) {
	case INUM: case FNUM:
		islookahead = 0, 
  		p = "Constant";		break;
	case SNUM: 
		islookahead = 0, 
  		p = "stringConstant";	break;
  	case IDENTIFIER:
  		p = "Identifier";	break;
	case RETURN:
		islookahead = 0, 
		p = "'return'";		break;
	case SUBROUTINE:
		islookahead = 0, 
		p = "'SUBROUTINE'";	break;
	case FOR:
		islookahead = 0, 
		p = "'for'";		break;
	case DECLARE:
		islookahead = 0, 
		p = "Datatype keywd";	break;
	case ARGUMENT:
		islookahead = 0, 
		p = "an Argument name";	break;
  	case DONE:	
		islookahead = 0, 
  		p = "end-of-source";	break;
	case ROUTINE:
		islookahead = 0, 
		p = "'ROUTINE'";	break;
  	default:
		p = "??";
  }
  if (p) {
  	p = text + strcopy(text, p);
  	if (islookahead)
  		*(p++) = ' ', *(p++) = '`', 
  		p += strcopy(p, lexbuf),
  		*(p++) = '\'', *p = EOS;
  }
  return(text);
}

/*===========================================================================*/
static int match(t)
/*+++++
.PURPOSE Check if next token matches specified type
.RETURNS OK / NOK
.REMARKS 
--------------*/
	int	t;	/* IN: token class to match	*/
{
	char	msg[2*SYMSIZE + 28], *p;
	int	stat;
	
  stat = OK;	pmatched = psource;

  if (lookahead != t)	 {
  	stat = NOK, p = msg + strcopy(msg, "Got ");
  	p += strcopy(p, atok(lookahead, 1));
  	p += strcopy(p, " when waiting for ");
  	strcopy(p, atok(t, 0));
  	error1(msg);
  }
  lookahead = lexan();

  return(stat);
}

static int match_until(t)
/*+++++
.PURPOSE Scan text until token is found
.RETURNS Last token
--------------*/
	int t;	/* IN: Token to find */
{
  while (!match(t)) {
	lookahead = lexan();
	if (lookahead == DONE)	break;
  }
  return(lookahead);
}

/*===========================================================================*/
static void declare()
/*+++++
.PURPOSE Match a declaration: keyword [*]name ;
.RETURNS The array size
.REMARKS Complete declaration added
-------*/
{
	SYMBOL  keyword;

  keyword = *found_symbol;	
  match(DECLARE);
  while ((lookahead != ';') && (lookahead != DONE)) switch(lookahead) {
    case '*':	keyword.dty += 0x10;
	match(lookahead);	continue;
    case ARGUMENT:
	if (keyword.dty == _CHARACTER_)	execute_mark |= 2;
	found_symbol->dty = keyword.dty;	/* NO BREAK */
    default: 
	match(ARGUMENT);	continue;
  }
  match_until(';');
}

/*===========================================================================*/
static int emit0()
/*+++++
.PURPOSE Emit the first statement as va_start and ftoc_mark
.RETURNS 0
.REMARKS Must be done after declarations, before the first statement
--------------*/
{
  emitq();      /* Write out pending text */

if (use_stdarg == 1)
   {
  if (execute_mark & 1)
	emits("  va_start(Cargs,noargs);       /"),
	emits("* <forif> */\n");
   }
else
   {
  if (execute_mark & 1)
	emits("  va_start(Cargs);       /"),
	emits("* <forif> */\n");
   }

  if (execute_mark & 2)
	emits("  FORmark = ftoc_mark(); /"),
	emits("* <forif> */\n");
  execute_mark &= ~3;

  return(0);
}

/*===========================================================================*/
static int stmt()
/*+++++
.PURPOSE Match a statement
.RETURNS The last token encountered.
.REMARKS 
--------------*/
{
  switch(lookahead)
  { case '{':		/* Statement { ... } */
  	match(lookahead);
	brace_level++;
  	while((lookahead != DONE) && (lookahead != '}'))	stmt();
	if (lookahead == '}') {
		brace_level--;
		if ((brace_level == 0) && (execute_mark & 4)) {
			emitq();
			emits("\n  ftoc_free(FORmark);    /");
			emits("* <forif> */");
			execute_mark &= ~4;
		}
	}
  	match('}');
  	break;

    case '#':						/* PREProc. Stmt  */	
	match_line();
	lookahead = lexan();
	break;
    case FOR:
	if ((execute_mark&3) && (lookahead != DECLARE)) emit0();
	match(FOR); 	match('(');
	expr();		match(';');
	expr();		match(';');
	expr();		match(')');
	stmt();
	break;
    case ';':					    	/* NULL Statement */
	if ((execute_mark&3) && (lookahead != DECLARE)) emit0();
        match(';');		break;	
    default: 
	if ((execute_mark&3) && (lookahead != DECLARE)) emit0();
  	expr();	
  	if (lookahead == '{')	stmt();
  	else	match_until(';');
	break;

  }
  return(lookahead);
}

/*===========================================================================*/

static int expr()
/*+++++
.PURPOSE Parse a complete expression made of terms; COMMAS ARE ALLOWED.
.RETURNS Last matched token
.REMARKS Simply starts the opp from top priority level
--------------*/
{ 
  expr0();
  while (lookahead == ',') {
  	match(','), 
  	expr0();
  }
  return(lookahead);
}

/*===========================================================================*/
static int expr0()
/*+++++
.PURPOSE Parse operation (no commas)
.RETURNS OK / NOK (no expression found)
.REMARKS 
--------------*/
{
	int stat;
	SYMBOL *ps;

  stat = OK;
  while (stat) switch (lookahead) {	
    case '(': 
	match('('), 	expr(),  	match(')');
	break;
    case '[': 
	match('['), 	expr(),  	match(']');
	break;
    case RETURN:
	while (isspace(*pmatched))	pmatched++;
	emitq();	/* Write out pending text */
	emits("ftoc_free(FORmark); /");
	emits("* <forif> */");
	execute_mark &= ~4;
	match(lookahead);
	break;
    case ARGUMENT:
	ps = found_symbol;
	emitq();	/* Write out pending text */
	match(lookahead);
	printed = pmatched;
	emits(tr_sym(ps));
	break;
    case INUM: case FNUM: case SNUM: case IDENTIFIER: case DECLARE:
	match(lookahead);
	break;
    case '=': 		/* Possibility of Initialisation... */
	match(lookahead);
	if (lookahead == '{')
		match('{'), 	expr(),  	match('}');
	break;
    case '+': case '-': case '/': case '*': case '%': 
    case '&': case '|': case '^':
    case '<': case '>': case '!': case '?': case ':':
	match(lookahead);
	break;
    default:
	stat = NOK;
  }
  return(stat);
}

/*===========================================================================*/
static int fname (dest, source)
/*+++++
.PURPOSE Transform Subroutine name
.RETURNS Length of name
.REMARKS Use  VMRname form "vmr", FORname for the rest.
--------------*/
	char *dest;	/* OUT: Transformed name */
	char *source;	/* IN: FORTRAN name	 */
{
	char *d, *o;

  d = dest;
  if (strdiff(source,"vmr") == 0)
  	o = VMRname;
  else  o = FORname;

  if (*o == '_') 	/* Prefix with _ */
	*(d++) = '_',	o++;
  d += strcopy (d, source);

  switch(*o) {
    case 'l': case 'L':	
	strlower(dest);	o++; break;
    case 'u': case 'U':	
	strupper(dest);	o++; break;
    case '.':           o++; break;
  }
	
  if (*o == '_') 	/* Postifx with _ */
	*(d++) = '_', *d = EOS;
  
  return (d - dest);
}

/*===========================================================================*/
static int init()
/*+++++
.PURPOSE Initialize
.RETURNS OK
.REMARKS 
--------------*/
{
    static char symb[] = "SUBROUTINE\0for\0ROUTINE\0";
    static char ass [] = { SUBROUTINE, FOR ,ROUTINE } ;
    static char dcl[] = "fint2c\0flong2c\0char\0short\0int\0long\0float\0double\0CHARACTER\0\
static\0extern\0register\0FUNCTION\0";
    static char dty[] = { _FINT2C_, _FLONG2C_ , _BYTE_, _SHORT_, _INT_, _LONG_,  _FLOAT_, 
	_DOUBLE_, _CHARACTER_, 0, 0,0, 0};
    static char DCL[] = "FINT2C\0FLONG2c\0BYTE\0SHORT\0INT\0LONG\0FLOAT\0DOUBLE\0";
    char	*p;
    char	*ps;

	/* Remove stored symbols */
  while (symbols)	pops();

	/* Insert permanent symbols */
  for (p = symb, ps = ass; *p;  ps++, p+= 1+strlen(p))
  	insert(p, *ps, 0, 0);
  for (p = dcl,  ps = dty; *p;  ps++, p+= 1+strlen(p)) 
  	insert(p, DECLARE, 0, *ps);
  for (p = DCL,  ps = dty; *p;  ps++, p+= 1+strlen(p)) 
  	insert(p, DECLARE, 0, *ps + 0x10);
  brace_level = 0;
  execute_mark = 0;

  return(OK);
}

/*===========================================================================*/
static int add_sno()
/*+++++
.PURPOSE Complete argument parameters (add sno #)
.RETURNS Number of arguments
.REMARKS 
--------------*/
{
	SYMBOL	*ps;
	int	i, sno;

  for (ps = symbol_table, i = symbols, sno = 0; --i >= 0; ps++) {
	if (ps->token != ARGUMENT)	continue;
	ps->sno = sno;
	if ((ps->dty & 0xf) == _CHARACTER_)	sno++;
  }
  return (sno);
}
		
/*===========================================================================*/
static int routine()
/*+++++
.PURPOSE Match a ROUTINE: ROUTINE name (arg_list) declarations { ... }
.RETURNS The last token encountered.
.REMARKS 
--------------*/
{
	char	name[SYMSIZE+5];	/* Subroutine Name */
	char	*oname;			/* Subroutine Original Name */

  emitq();	/* Write out pending text */

  init();	match(ROUTINE);	

  while (isspace(*printed))	printed++;

  oname = strsave(avalue);
  fname(name, avalue);

  if (strdiff(name, oname)) {	/* Generate #define code to redefine Name */
  	emits("\n\n#define "); emits(oname); 
	emits("\t"); emits(name); 
	emits("\n");
  }
/*  emitq();*/	/* Write out pending text */

  strfree(oname);
  return(lookahead);
}

static int subroutine()
/*+++++
.PURPOSE Match a SUBROUTINE: SUBROUTINE name (arg_list) declarations { ... }
.RETURNS The last token encountered.
.REMARKS 
--------------*/
{
	char	name[SYMSIZE+5];	/* Subroutine Name */
	char	*oname;			/* Subroutine Original Name */

  emitq();	/* Write out pending text */

  init();	match(SUBROUTINE);	

  emits("\n\n#if 0     /");	emits("* ==== Original Code ==== */\n");	
  while (isspace(*printed))	printed++;

  match(IDENTIFIER);		/* Subroutine Name	*/
  oname = strsave(avalue);
  fname(name, avalue);
  match('(');	
  argno = 0;
  while (lookahead == IDENTIFIER) {
	argno++;
	insert (avalue, ARGUMENT, argno, 0);
	lookahead = lexan();
	if (lookahead == ',')	match(lookahead);
	else	break;
  }
  match(')');

  while ((lookahead != '{') && (lookahead != DONE)) 
	declare();

  emitq();	/* Write out pending text */
  emits("\n#else     /");	emits("* ==== Generated Code === */\n");
  if (strdiff(name, oname)) {	/* Generate #define code to redefine Name */
  	emits("#define "); emits(oname); 
	emits("\t"); emits(name); 
	emits("\n");
  }
  emits(oname);			/* Subroutine Name */
if (use_stdarg == 1)
   {
  emits("(int *noargs, ...) \n{ va_list Cargs;");
   }
else
   {
  emits("(va_alist) va_dcl \n{ va_list Cargs;");
   }

  emits("\n#endif    /");	emits("* ======================= */\n");

	/* Add into list of Arguments the sno number */
  if (add_sno()) {		/* There are string parameters */
	emits("  int FORmark;           /");
	emits("* <forif> */\n");
	insert("return", RETURN, 0, 0);
	execute_mark |= 4;		/* Must use ftoc_free */
  }

  if (lookahead == '{')	{
	execute_mark |= 1;
	printed = psource;
	stmt();
	emitq();	/* Write out pending text */
  }

  strfree(oname);
  return(lookahead);
}

/*===========================================================================*/

static void parse(text)
/*+++++
.PURPOSE Parse the source text 
.RETURNS ??
--------------*/
	char	*text;	/* IN: Text to compile	*/
{
  init();

	/* Initialize compilation	*/

  psource = pmatched = printed = text;
  found_errors = 0, lineno = 1;
  lookahead = lexan();

  while (lookahead != DONE) {
	if (lookahead == SUBROUTINE)	subroutine();
	else if (lookahead == ROUTINE)	routine();
	else	stmt();
  }
			/* Write rest of File */
  emit(printed, --psource - printed);
}

/*===========================================================================
 *			Main Routine
 *===========================================================================*/

int main(argc, argv)
/*++++++++++++++++
.PURPOSE  Convert stdin -> stdout
.RETURNS  To OS
.REMARKS  Parameters in out -f(ftocNAme) -v(ftocNAme)  -s(size)
-----------------*/
int argc; char **argv;

{
char *text, *p, *tend;
char *fin, *fout;
char vmrtr[20];

int  size;


/* Examine Parameters */

VMRname = (char *)0;
size = 0;
fin = fout = (char *)0;
while (--argc > 0) 
   {
   p = *++argv;
   if (*p == '-') switch(*++p) 
         {
         case 'f':	FORname = ++p;	break;
         case 'v':	VMRname = ++p;	break;
         case 's':	p++; size = atoi(p); break;
         default: 	p--; error("Bad argument ", p);
			synopsis();
			ospexit (found_errors);
         }
   else 
      {
      if (!fin)	
         fin = p;
      else if (!fout)	
         fout = p;
      else	
         error("Bad Argument ", p);
      }
   }

if ( VMRname == (char *)0 ) VMRname = FORname;
		
/* Open Files */

if (fin) 
   {
   if (size <= 0)	size = osfsize(fin);
   IN = osaopen(fin, 0);
   }

if (size <= 0)	size = 20000;

/* CG. */
/* First: try to delete the output file if exists. */
/* Second: exit if an error when opening */
/* Third: The osdopen does not take into account the protection flags */

if (fout) 
   {
   osfdelete(fout);
   if ( (OUT = osdopen (fout, 1)) == -1 ) 
      {
      error("Output file: ", osmsg());
      ospexit (found_errors);
      }
   }

text = osmmget (size+2);
tend = text + size + 1;

p = text;
while (osaread(IN, p, tend - p) >= 0)
   p += strlen(p), *(p++) = '\n';
*p = EOS;
if (IN > 2)	osaclose(IN);

/* Add the definition of vmr ... but only if VMRname != "." */

fname(vmrtr, "vmr");
if (strdiff(vmrtr, "vmr")) emits("#define vmr\t"), emits(vmrtr);
emits("\t\t/");
emits("* parameter for Name Translation is ");
emits(VMRname);
emits(" */\n");
emits("#define ROUTINE int\n");


/* Parse the Complete Text	*/

parse(text);
if (OUT > 2)	osdclose(OUT);

ospexit (found_errors);
return(0);
}
