%{
/*
 *  R : A Computer Langage for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  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 Mass Ave, Cambridge, MA 02139, USA.
 */

#include "Defn.h"

extern SEXP listAppend(SEXP,SEXP);
void pushCmt();
void popCmt();

static int eatln;
extern SEXP R_CommentSxp;

#define YYSTYPE		SEXP
#ifdef YYBYACC
#define YYRETURN(x)	{ return(x); }
#else
#define YYRETURN(x)	{ free((void*)yys); free((void*)yyv); return(x); }
#endif

%}

%token		STR_CONST NUM_CONST NULL_CONST SYMBOL FUNCTION LEX_ERROR
%token		LBB ERROR
%token		LEFT_ASSIGN RIGHT_ASSIGN
%token		FOR IN IF ELSE WHILE NEXT BREAK REPEAT
%token		GT GE LT LE EQ NE AND OR

%left		'?'
%left		LOW WHILE FOR REPEAT
%right		IF
%left		ELSE
%right		LEFT_ASSIGN
%left		RIGHT_ASSIGN
%nonassoc	'~' TILDE
%left		OR
%left		AND
%left		UNOT NOT
%nonassoc	GT GE LT LE EQ NE
%left		'+' '-'
%left		'*' '/' '%'
%left		SPECIAL
%left		':'
%left		UMINUS UPLUS
%right		'^'
%left		'$'
%nonassoc	'(' '[' LBB

%%

prog:							{ newline = 0; }
	|	prog '\n'				{ R_CurrentExpr = NULL; return 2; }
	|	prog expr '\n'				{ R_CurrentExpr = $2; UNPROTECT(1); YYRETURN(3); }
	|	prog expr ';'				{ R_CurrentExpr = $2; UNPROTECT(1); YYRETURN(4); }
	|	prog error 				{ YYABORT; }
	;

expr:		NUM_CONST				{ $$ = $1; }
	|	STR_CONST				{ $$ = $1; }
	|	NULL_CONST				{ $$ = $1; }
	|	SYMBOL					{ $$ = $1; }
	|	'{' exprlist '}'			{ UNPROTECT(1); TYPEOF($2) = LANGSXP; CAR($2) = $1; $$ = $2; PROTECT($$); eatln = 0; }
	|	'(' expr ')'				{ UNPROTECT(1); $$ = lang2($1, $2); PROTECT($$); }
	|	'-' expr %prec UMINUS			{ UNPROTECT(1); $$ = lang2($1, $2); PROTECT($$); }
	|	'+' expr %prec UMINUS			{ UNPROTECT(1); $$ = lang2($1, $2); PROTECT($$); }
	|	'!' expr %prec UNOT			{ UNPROTECT(1); $$ = lang2($1, $2); PROTECT($$); }
	|	'~' expr %prec TILDE			{ UNPROTECT(1); $$ = lang2($1, $2); PROTECT($$); }
	|	'?' expr				{ UNPROTECT(1); $$ = lang2($1, $2); PROTECT($$); }
	|	expr ':'  expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr '+'  expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr '-' expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr '*' expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr '/' expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr '^' expr 				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr SPECIAL expr			{ UNPROTECT(3); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr '%' expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr '~' expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr LT expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr LE expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr EQ expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr NE expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr GE expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr GT expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr AND expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|	expr OR expr				{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|  	expr LEFT_ASSIGN expr 			{ UNPROTECT(2); $$ = lang3($2, $1, $3); PROTECT($$); }
	|  	expr RIGHT_ASSIGN expr 			{ UNPROTECT(2); $$ = lang3($2, $3, $1); PROTECT($$); }
	|	FUNCTION '(' formlist ')' gobble expr %prec LOW
							{ addcomment($6); UNPROTECT(2); $$ = lang3($1, CDR($3), $6); PROTECT($$); popCmt();}
	|	expr '(' sublist ')'			{ if(isString($1)) $1=install(CHAR(STRING($1)[0])); UNPROTECT(2); if(length(CDR($3)) == 1 && CADR($3) == R_MissingArg )
										$$ = lang1($1);
									else
										$$ = LCONS($1, CDR($3));
									PROTECT($$); }
	|	IF ifcond expr 				{ UNPROTECT(2); $$ = lang3($1, $2, $3); PROTECT($$);  }
	|	IF ifcond expr ELSE expr		{ UNPROTECT(3); $$ = lang4($1, $2, $3, $5); PROTECT($$); }
	|	FOR forcond expr	%prec FOR 	{ UNPROTECT(2); $$ = lang4($1, CAR($2), CDR($2), $3); PROTECT($$); }
	|	WHILE cond expr				{ UNPROTECT(2); $$ = lang3($1, $2, $3); PROTECT($$); }
	|	REPEAT expr				{ UNPROTECT(1); $$ = lang2($1, $2); PROTECT($$); }
	|	expr LBB sublist ']' ']'		{ UNPROTECT(2); $$ = LCONS($2, LCONS($1, CDR($3))); PROTECT($$); }
	|	expr '[' sublist ']'			{ UNPROTECT(2); $$ = LCONS($2, LCONS($1, CDR($3))); PROTECT($$); }
	|	expr '$' SYMBOL				{ $$ = lang3($2, $1, $3); UNPROTECT(2); PROTECT($$); }
	|	expr '$' STR_CONST			{ $$ = lang3($2, $1, $3); UNPROTECT(2); PROTECT($$); }
	|	NEXT					{ $$ = lang1($1); PROTECT($$); }
	|	BREAK					{ $$ = lang1($1); PROTECT($$); }
	;


cond:		'(' expr ')'				{ $$ = $2;  eatln = 1; }
	;

ifcond:		'(' expr ')'				{ $$ = $2; ifpush(); eatln = 1; }
	;

forcond:	'(' SYMBOL IN expr ')' 			{ UNPROTECT(2); $$ = LCONS($2,$4); PROTECT($$); eatln=1;}
	;


exprlist:						{ $$ = newlist(); PROTECT($$); }
	|	expr					{ addcomment($1); UNPROTECT(1); $$ = growlist(newlist(), $1); PROTECT($$);}
	|	exprlist ';' expr			{ addcomment($3); UNPROTECT(2); $$ = growlist($1, $3); PROTECT($$);}
	|	exprlist ';'				{ $$ = $1; addcomment(CAR($$));}
	|	exprlist '\n' expr			{ addcomment($3); UNPROTECT(2); $$ = growlist($1, $3); PROTECT($$);}
	|	exprlist '\n'				{ $$ = $1;}
	;

sublist:	sub					{ UNPROTECT(1); $$ = firstarg(CAR($1),CADR($1)); PROTECT($$); }
	|	sublist gobble ',' sub			{ UNPROTECT(2); $$ = nextarg($1, CAR($4), CADR($4)); PROTECT($$); }
	;

sub:							{ $$ = lang2(R_MissingArg,R_NilValue); PROTECT($$); }
	|	expr					{ UNPROTECT(1); $$ = tagarg($1, R_NilValue); PROTECT($$); }
	|	SYMBOL '=' expr				{ UNPROTECT(2); $$ = tagarg($3, $1); PROTECT($$); }
	|	SYMBOL '=' 				{ UNPROTECT(1); $$ = tagarg(R_MissingArg, $1); PROTECT($$); }
	|	STR_CONST '=' expr			{ UNPROTECT(2); $$ = tagarg($3, $1); PROTECT($$); }
	|	STR_CONST '=' 				{ UNPROTECT(1); $$ = tagarg(R_MissingArg, $1); PROTECT($$); }
	|	NULL_CONST '=' expr			{ UNPROTECT(2); $$ = tagarg($3, install("NULL")); PROTECT($$); }
	|	NULL_CONST '=' 				{ UNPROTECT(1); $$ = tagarg(R_MissingArg, install("NULL")); PROTECT($$); }
	;

formlist:						{ $$ = R_NilValue; PROTECT($$); }
	|	SYMBOL					{ UNPROTECT(1); $$ = firstarg(R_MissingArg, $1); PROTECT($$); }
	|	SYMBOL '=' expr				{ UNPROTECT(2); $$ = firstarg($3, $1); PROTECT($$); }
	|	formlist ',' SYMBOL			{ UNPROTECT(2); check_formals($1,$3); $$ = nextarg($1, R_MissingArg, $3); PROTECT($$); }
	|	formlist ',' SYMBOL '=' expr		{ UNPROTECT(3); check_formals($1,$3); $$ = nextarg($1, $5, $3); PROTECT($$); }
	;

gobble:	{eatln = 1;}
	;
%%

SEXP tagarg(SEXP arg, SEXP tag)
{
	switch (TYPEOF(tag)) {
	case NILSXP:
	case SYMSXP:
	case STRSXP:
		return lang2(arg, tag);
	default:
		error("incorrect tag type\n");
	}
}

/* Lists are created and grown using a special dotted pair. */
/* The CAR of the list points to the last cons-cell in the list */
/* and the CDR points to the first.  The list can be extracted */
/* from the pair by taking its CDR, while the CAR gives fast access */
/* to the end of the list. */

/* Create a stretchy-list dotted pair */

SEXP newlist(void)
{
	SEXP s = CONS(R_NilValue, R_NilValue);
	CAR(s) = s;
	return s;
}

/* Add a new element at the end of a stretchy list */

SEXP growlist(SEXP l, SEXP s)
{
	SEXP tmp;
	PROTECT(l);
	tmp = CONS(s, R_NilValue);
	UNPROTECT(1);
	SETCDR(CAR(l), tmp);
	CAR(l) = tmp;
	return l;
}


	/* Comment Handling */

	/* R_CommentSxp is of the same form as an expression list, */
	/* each time a new { is encountered a new element is placed */
	/* in the R_CommentSxp and when a } is encountered it is */
	/* removed. */

extern void ResetComment()
{
	R_CommentSxp = CONS(R_NilValue, R_NilValue);
}

void pushCmt()
{
	R_CommentSxp = CONS(R_NilValue, R_CommentSxp);
}

void popCmt()
{
	R_CommentSxp = CDR(R_CommentSxp);
}

int isComment(SEXP l)
{
	if (isList(l) && isString(CAR(l)) && !strncmp(CHAR(STRING(CAR(l))[0]), "#", 1))
		return 1;
	else
		return 0;
}

void addcomment(SEXP l)
{
	SEXP tcmt, cmt;
	int i, ncmt;

	tcmt = CAR(R_CommentSxp);

		/* Return if there are no comments */

	if (tcmt == R_NilValue || l == R_NilValue)
		return;

		/* Attach the comments as a comment attribute */

	ncmt = length(tcmt);
	cmt = allocVector(STRSXP, ncmt);
	for(i=0 ; i<ncmt ; i++) {
		STRING(cmt)[i] = CAR(tcmt);
		tcmt = CDR(tcmt);
	}
	PROTECT(cmt);
	setAttrib(l, R_CommentSymbol, cmt);
	UNPROTECT(1);
	
		/* Reset the comment accumulator */

	CAR(R_CommentSxp) = R_NilValue;
}

SEXP firstarg(SEXP s, SEXP tag)
{
	SEXP tmp;
	PROTECT(s);
	PROTECT(tag);
	tmp = newlist();
	tmp = growlist(tmp, s);
	TAG(CAR(tmp)) = tag;
	UNPROTECT(2);
	return tmp;
}

SEXP nextarg(SEXP l, SEXP s, SEXP tag)
{
	PROTECT(tag);
	l = growlist(l, s);
	TAG(CAR(l)) = tag;
	UNPROTECT(1);
	return l;
}


SEXP mkString(char *);
SEXP mkInteger(char *);
SEXP mkFloat(char *);
SEXP mkComplex(char *);
SEXP mkNA(void);
SEXP mkTrue(void);
SEXP mkFalse(void);


/*
//	Basic File IO:
//
//	This code is here because at this particular instant it
//	seems closely related to cget(), which appears below.
*/


int R_fgetc(FILE *fp)
{
	int c = fgetc(fp);
	return feof(fp) ? R_EOF : c;
}


static char *buf;		/* The input stream buffer */
static char *bufp;		/* Pointer within current buffer */
static int cnt = 0;		/* Pointer to character count */

static char buf1[MAXELTSIZE];	/* File or text buffer */

static char buf0[MAXELTSIZE];	/* Console buffer */
static char *bufp0;		/* Pointer within the console buffer */
static int cnt0 = 0;		/* Characters in the console buffer */

static current_input;

/*
//	Set the input stream for the parser
//	    input = 0	initialize
//	    input = 1	console
//	    input = 2	file
//	    input = 3	text
*/

void R_SetInput(int input)
{
	switch (input) {

	case 0:			/* Initialization / Reset */
		cnt = cnt0 = 0;
		buf = buf0;
		bufp = buf0;
		break;

	case 1:			/* Restore console values */
		cnt = cnt0;
		buf = buf0;
		bufp = bufp0;
		R_Console = 1;
		break;

	case 2:			/* Text or file input */
	case 3:
		if(R_Console == 1) {
			cnt0 = cnt;
			bufp0 = bufp;
		}
		cnt = 0;
		buf = buf1;
		bufp = buf1;
		R_Console = 0;
		break;
	}
	current_input = input;
}


/*
//	Fetch a single character from the current input stream.
//	The stream has been set by a call to R_SetInput().
*/

int cget()
{
	if (--cnt < 0) {
		switch(current_input) {

		case 1:
			if (ReadKBD(buf, MAXELTSIZE) == 0) {
				ClearerrConsole();
				return R_EOF;
			}
			break;

		case 2:
			if (fgets(buf, MAXELTSIZE, R_Inputfile) == NULL) {
				ResetConsole();
				return R_EOF;
			}
			break;

		case 3:
			if (R_ParseCnt < LENGTH(R_ParseText)) {
				strcpy(buf, CHAR(STRING(R_ParseText)[(R_ParseCnt)]));
				strcat(buf, "\n");
			}
			else return R_EOF;
			break;

		}
		R_ParseCnt++;
		bufp = buf;
		cnt = strlen(buf);
		cnt--;
	}
	return *bufp++;
}


/*
//	Push n characters back onto the input stream.
//	This is only called when the characters are
//	currently in the input buffer so pushing back
//	beyond the start of the buffer is impossible.
*/

void uncget(int n)
{
	cnt += n;
	bufp -= n;
}


/*
//	Lexical Analyzer:
//
//	Basic lexical analysis is performed by the following
//	routines.  Input is read a line at a time, and, if the
//	program is in batch mode, each input line is echoed to
//	standard output after it is read.
//
//	The function yylex() scans the input, breaking it into
//	tokens which are then passed to the parser.  The lexical
//	analyser maintains a symbol table (in a very messy fashion).
//
//	The fact that if statements need to parse differently
//	depending on whether the statement is being interpreted or
//	part of the body of a function causes the need for ifpop
//	and ifpush. When an if statement is encountered an 'i' is
//	pushed on a stack (provided there are parentheses active).
//	At later points this 'i' needs to be popped off of the if
//	stack.
*/

static int newline = 0;
static int reset = 1;
#ifndef DEBUG_LEX
static
#endif
char *parenp, parenstack[50];

static void ifpush(void)
{
	if (*parenp == '{' || *parenp == '[' || *parenp == '(' || *parenp == 'i')
		*++parenp = 'i';
}

static void ifpop(void)
{
	if (*parenp == 'i')
		parenp--;
}

static int typeofnext(void)
{
	int k, c;

	c = cget();
	if (isdigit(c)) k = 1;
	else if (isalpha(c) || c == '.')
		k = 2;
	else
		k = 3;
	uncget(1);
	return k;
}

static int nextchar(int expect)
{
	int c = cget();

	if (c == expect)
		return 1;
	else
		uncget(1);
	return 0;
}

		/* Special Symbols */
		/* Syntactic Keywords + Symbolic Constants */

struct {
	char *name;
	int token;
} keywords[] = {
	{ "NULL",	NULL_CONST	},
	{ "NA",		NUM_CONST	},
	{ "TRUE",	NUM_CONST	},
	{ "FALSE",	NUM_CONST	},
	{ "GLOBAL.ENV",	NUM_CONST	},
	{ "function",	FUNCTION	},
	{ "while",	WHILE		},
	{ "repeat",	REPEAT		},
	{ "for",	FOR		},
	{ "if",		IF		},
	{ "in",		IN		},
	{ "else",	ELSE		},
	{ "next",	NEXT		},
	{ "break",	BREAK		},
	{ "...",	SYMBOL		},
	{ 0,		0		}
};


	/* klookup has side effects, it sets yylval */

int klookup(s)
char *s;
{
	int i;

	for (i = 0; keywords[i].name; i++) {
		if (strcmp(keywords[i].name, s) == 0) {
			switch (keywords[i].token) {
			case NULL_CONST:
				PROTECT(yylval = R_NilValue);
				eatln = 0;
				break;
			case NUM_CONST:
				switch(i) {
				case 1:
					PROTECT(yylval = mkNA());
					break;
				case 2:
					PROTECT(yylval = mkTrue());
					break;
				case 3:
					PROTECT(yylval = mkFalse());
					break;
				case 4:
					PROTECT(yylval = R_GlobalEnv);
				}
				eatln = 0;
				break;
			case FUNCTION:
			case WHILE:
			case REPEAT:
			case FOR:
			case IF:
				eatln = 1;
				yylval = install(s);
				break;
			case IN:
				eatln = 1;
				break;
			case ELSE:
				ifpop();
				eatln = 1;
				break;
			case NEXT:
			case BREAK:
				eatln = 0;
				yylval = install(s);
				break;
			case SYMBOL:
				PROTECT(yylval = install(s));
				eatln = 0;
				break;
			}
			return keywords[i].token;
		}
	}
	return 0;
}

static void prompt()
{
	if (R_ParseText == R_NilValue && R_Console == 1)
		yyprompt(CHAR(STRING(GetOption(install("continue"), R_NilValue))[0]));
}

SEXP mkString(char *s)
{
	SEXP t;

	PROTECT(t = allocVector(STRSXP, 1));
	STRING(t)[0] = mkChar(s);
	UNPROTECT(1);
	return t;
}

SEXP mkFloat(char *s)
{
	SEXP t = allocVector(REALSXP, 1);
	REAL(t)[0] = atof(s);
	return t;
}

SEXP mkComplex(char *s)
{
	SEXP t = allocVector(CPLXSXP, 1);
	COMPLEX(t)[0].r = 0;
	COMPLEX(t)[0].i = atof(s);
	return t;
}

SEXP mkNA(void)
{
	SEXP t = allocVector(LGLSXP, 1);
	LOGICAL(t)[0] = NA_LOGICAL;
	return t;
}

SEXP mkTrue(void)
{
	SEXP s = allocVector(LGLSXP, 1);
	LOGICAL(s)[0] = 1;
	return s;
}

SEXP mkFalse(void)
{
	SEXP s = allocVector(LGLSXP, 1);
	LOGICAL(s)[0] = 0;
	return s;
}

void yyinit(void)
{
	newline = 0;
	reset = 1;
}

int yywrap()
{
	return feof(R_Inputfile);
}

#ifdef HAVE_LIBREADLINE
extern char R_prompt_buf[512];
#endif


void yyprompt(char *format, ...)
{
	va_list(ap);
	va_start(ap, format);
#ifdef HAVE_LIBREADLINE
	vsprintf(R_prompt_buf, format, ap);
#else
	REvprintf(format, ap);
#endif
	va_end(ap);
	fflush(stdout);
	RBusy(0);
}

void yyerror(char *s)
{
	int i;

	R_CommentSxp = R_NilValue;
	REprintf("%s", buf);
	for (i = 1; i < bufp - buf; i++) {
		REprintf(" ");
	}
	REprintf("^\n");
	if (R_Console == 0) {
		fclose(R_Inputfile);
		ResetConsole();
	}
	else {
		FlushConsole();
		REprintf("Error: %s\n", s);
	}
	newline = 0;
	reset = 1;
	cnt = 0;
}

void check_formals(SEXP formlist, SEXP new)
{
	int i;

	while( formlist != R_NilValue ) {
		if(TAG(formlist) == new ) {
			REprintf("%s", buf);
			for (i = 2; i < bufp - buf; i++) 
				REprintf(" ");
			REprintf("^\n");
			newline = 0;
			reset = 1;
			cnt = 0;
			error("Repeated formal argument.\n");
		}
		formlist=CDR(formlist);
	}
}

int yylex()
{
	SEXP f;
	int c, quote, kw;
	char *p, yytext[MAXELTSIZE];

	if (newline) {
		newline = 0;
		prompt();
	}

    again:
	if (reset) {
		parenp = parenstack;
		*parenp = ' ';
		reset = 0;
		eatln = 0;
		ResetComment();
	}

	while ((c = cget()) == ' ' || c == '\t' || c == '');

	if (c == '#') {
		p = yytext;
		*p++ = c;
		while ((c = cget()) != '\n' && c != R_EOF)
			*p++ = c;
		*p = '\0';
		if(R_CommentSxp != R_NilValue) {
			f = mkChar(yytext);
			f = CONS(f, R_NilValue);
			CAR(R_CommentSxp) = listAppend(CAR(R_CommentSxp), f);
		}
	}


	if (c == R_EOF) {
		return EOF;
	}

		/* This code deals with context sensitivity to      */
		/* newlines.  The main problem is finding out       */
		/* whether a newline is followed by an ELSE clause. */
		/* This is only of importance if we are inside one  */
		/* of "(", "[", or "{".			     */

	if (c == '\n') {
		if (eatln || *parenp == '[' || *parenp == '(') {
			prompt();
			goto again;
		}
		if (*parenp == 'i') {
			prompt();
			while ((c = cget()) == ' ' || c == '\t');
			if (c == R_EOF) {
				error("unexpected end-of-file in parse\n");
			}
			if (c == '#') {
				p = yytext;
				*p++ = c;
				while ((c = cget()) != '\n' && c != R_EOF)
					*p++ = c;
				*p = '\0';
				if(R_CommentSxp != R_NilValue) {
					f = mkChar(yytext);
					f = CONS(f, R_NilValue);
					CAR(R_CommentSxp) = listAppend(CAR(R_CommentSxp), f);
				}
			}
			if (c == '\n') {
				prompt();
				uncget(1);
				goto again;
			}
			if (c == '}' || c == ')' || c == ']' ) {
				while (*parenp == 'i')
					ifpop();
				parenp--;
				return c;
			}
			if (c == ',') {
				ifpop();
				return c;
			}
			uncget(1);
			if (!strncmp(bufp, "else", 4) && !isalnum(bufp[4]) && bufp[4] != '.') {
				eatln = 1;
				bufp += 4;
				cnt -= 4;
				ifpop();
				return ELSE;
			}
			ifpop();
	 	   }
		else newline = 1;
		return '\n';
	}

		/* These are needed because both ";" and "," can */
		/* end an "if" clause without a newline.  Ifpop  */
		/* only does its thing in the right context.     */

	if (c == ';' || c == ',') {
		ifpop();
		return c;
	}

		/* Either digits or symbols can start with a "." */
		/* so we need to decide which it is and jump to  */
		/* the correct spot. */

	if (c == '.') {
		kw = typeofnext();
		if (kw >= 2) goto symbol;
	}

		/* literal numbers */

	if (c == '.' || isdigit(c)) {
		int seendot = (c == '.');
		int seenexp = 0;
		p = yytext;
		*p++ = c;
		while (isdigit(c = cget()) || c == '.' || c == 'e' || c == 'E') {
			if (c == 'E' || c == 'e') {
				if (seenexp)
					break;
				seenexp = 1;
				seendot = 1;
				*p++ = c;
				c = cget();
				if (!isdigit(c) && c != '+' && c != '-')
					break;
			}
			if (c == '.') {
				if (seendot)
					break;
				seendot = 1;
			}
			*p++ = c;
		}
		*p = '\0';
		if(c == 'i') {
			PROTECT(yylval = mkComplex(yytext));
		}
		else {
			PROTECT(yylval = mkFloat(yytext));
			uncget(1);
		}
		eatln = 0;
		return NUM_CONST;
	}

	/* literal strings */

	if (c == '\"' || c == '\'') {
		quote = c;
		p = yytext;
		while ((c = cget()) != R_EOF && c != quote) {
			if (c == '\n') {
				uncget(1);
				return ERROR;
			}
			if (c == '\\') {
				c = cget();
				switch (c) {
				case 'a':
					c = '\a';
					break;
				case 'b':
					c = '\b';
					break;
				case 'f':
					c = '\f';
					break;
				case 'n':
					c = '\n';
					break;
				case 'r':
					c = '\r';
					break;
				case 't':
					c = '\t';
					break;
				case 'v':
					c = '\v';
					break;
				case '\\':
					c = '\\';
					break;
				}
			}
			*p++ = c;
		}
		*p = '\0';
		PROTECT(yylval = mkString(yytext));
		eatln = 0;
		return STR_CONST;
	}

	/* special functions */
	if (c == '%') {
		p = yytext;
		*p++ = c;
		while ((c = cget()) != R_EOF && c != '%') {
			if (c == '\n') {
				uncget(1);
				return ERROR;
			}
			*p++ = c;
		}
		if (c == '%')
			*p++ = c;
		*p++ = '\0';
		PROTECT(yylval = install(yytext));
		eatln=1;
		return SPECIAL;
	}


	/* functions, constants and variables */

	/* gag, barf, but the punters want it */
	if (c == '_') {
		eatln = 1;
		yylval = install("<-");
		return LEFT_ASSIGN;
	}

    symbol:
	if (c == '.' || isalpha(c)) {
		p = yytext;
		do {
			*p++ = c;
		} while ((c = cget()) != R_EOF && (isalnum(c) || c == '.'));
		uncget(1);
		*p = '\0';

		if ((kw = klookup(yytext))) {
			if(kw == FUNCTION) pushCmt();
			return kw;
		}

		PROTECT(yylval = install(yytext));
		eatln = 0;
		return SYMBOL;
	}

	/* compound tokens */

	switch (c) {
	case '<':
		eatln = 1;
		if (nextchar('=')) {
			yylval = install("<=");
			return LE;
		}
		if (nextchar('-')) {
			yylval = install("<-");
			return LEFT_ASSIGN;
		}
		if (nextchar('<'))
			if (nextchar('-')) {
				yylval = install("<<-");
				return LEFT_ASSIGN;
			}
			else
				return ERROR;
		yylval = install("<");
		return LT;
	case '-':
		eatln = 1;
		if (nextchar('>'))
			if (nextchar('>')) {
				yylval = install("<<-");
				return RIGHT_ASSIGN;
			}
			else {
				yylval = install("<-");
				return RIGHT_ASSIGN;
			}
		yylval = install("-");
		return '-';
	case '>':
		eatln = 1;
		if (nextchar('=')) {
			yylval = install(">=");
			return GE;
		}
		yylval = install(">");
		return GT;
	case '!':
		eatln = 1;
		if (nextchar('=')) {
			yylval = install("!=");
			return NE;
		}
		yylval = install("!");
		return '!';
	case '=':
		eatln = 1;
		if (nextchar('=')) {
			yylval = install("==");
			return EQ;
		}
		return '=';
	case ':':
		eatln = 1;
		if (nextchar('=')) {
			yylval = install(":=");
			return LEFT_ASSIGN;
		}
		yylval = install(":");
		return ':';
	case '&':
		eatln = 1;
		if (nextchar('&')) {
			yylval = install("&&");
			return AND;
		}
		yylval = install("&");
		return AND;
	case '|':
		eatln = 1;
		if (nextchar('|')) {
			yylval = install("||");
			return OR;
		}
		yylval = install("|");
		return OR;
	case '{':
		*++parenp = c;
		yylval = install("{");
		pushCmt();
		return c;
	case '}':
		ifpop();
		if(*parenp == '{')
			popCmt();
		parenp--;
		return c;
	case '(':
		*++parenp = c;
		yylval = install("(");
		return c;
	case ')':
		eatln = 0;
		ifpop();
		parenp--;
		return c;
	case '[':
		*++parenp = c;
		if (nextchar('[')) {
			*++parenp = c;
			yylval = install("[[");
			return LBB;
		}
		yylval = install("[");
		return c;
	case ']':
		ifpop();
		eatln = 0;
		parenp--;
		return c;
	case '?':
		eatln = 1;
		strcpy(yytext, "help");
		yylval = install(yytext);
		return c;
	case '*':
		eatln=1;
		if (nextchar('*'))
			c='^';
		yytext[0] = c;
		yytext[1] = '\0';
		yylval = install(yytext);
		return c;
	case '+':
	case '/':
	case '^':
	case '~':
	case '$':
		eatln = 1;
		yytext[0] = c;
		yytext[1] = '\0';
		yylval = install(yytext);
		return c;
	default:
		return c;
	}
}