/* @(#)lex.c 1.17 96/09/11 *//* * ==================================================== * Copyright (C) 1995 by Sun Microsystems, Inc. All rights reserved. * * Developed at SunSoft, a Sun Microsystems, Inc. business. * Permission to use, copy, modify, and distribute this * software is freely granted, provided that this notice * is preserved. * ==================================================== */#include "fpp.h"#include "service.h"#include "symtab.h"#include "rgram.h"#include "lex.h"#include "sb.h"extern uchar	*curp;extern Comment	*comments;/* ltok is a static memory to hold the current token. * As long as we don't expect pushtok() to be called more  * than once the size is equal to 2. */static Token    ltok[2];static Token    *curtok = &ltok[0];static int      cur_stmt_id = 0;        /* current statement id */static int      sym_line;               /* current character lineno */static char     cont_symbol;            /* symbol used in 6th column (fixed mode) */#define nextch(c) \        while (!*curp) refill();\        c = *curp++;\        if (c == SYM_CTRL && ctrl_mode) {\	        while (!*curp) refill();\		if (*curp != SYM_CTRL) {\		        c = (c << 8) | *curp++;\			ctrl_mode--;\		}\		else curp++;\	}#define unnextch(c) \        *--curp = (char)c;\        if (is_special(c)) {\	        *--curp = SYM_CTRL;\		ctrl_mode++;\	}static intskip_comment( unsigned mode ) {        wchar   c;	int	i,n;	int	locfl;	int     lineno;	char	*p;	static char buffer[BUFSIZE];loop:		locfl = 0;		p = buffer;		lineno = line;		nextch(c);		switch (c) {		case 'c':		case 'C':		case 'd':		case 'D':		case '*':			if (!f77fl && !fixedformfl) {			        unnextch(c);				return 0;			}			if (colm != 0) {			        unnextch(c);				return 0;			}			/* no break! */		case '!':			*p++ = (char)c;			for (;;) {				nextch(c);				if (c == '\n') { 					line++; colm=0; 					*p++ = (char)c;					break;				}				else if (c == SYM_EOF) { 					colm=0; 				        *p++ = '\n';					break;				}				*p++ = (char)c;			}			*p = '\0';			for (i=0;i<8;i++) {	/* we treat it as pragma if it has '$' */				if (buffer[i] == '\0') break;				if (buffer[i] == '$') {					if (mode & MOD_LCASE)						tolowcase(buffer);					locfl = 1;					break;				}			}			break;		case '\n':		        if (colm != 0) {			        unnextch(c);				return 0;			}			*p++ = (char)c;			line++;			break;		default:		        if ( !is_blank(c) ) {			        unnextch(c);				return 0;			}			CHECK(colm==0);			for (n = 1;;n++) {				colm++; 				*p++ = (char)c;				nextch(c);				if (c == '\n') {					line++; colm=0;					*p++ = (char)c;					break;				}				else if (c == SYM_EOF) {				        colm = 0;				        *p++ = '\n';					break;				}				else if (c == '!') {				        if (!(fixedformfl && n == 5)) {					        /* Skip the leading spaces. 						 */					        p = buffer;						unnextch(c);						goto loop;					}				}				if (!is_blank(c)) {				        unnextch(c);					while (n--) ungetsym(*(--p));					CHECK(colm==0);					return 0;				}			}			break;		}		*p = '\0';		if ( !(mode & MOD_FPP) && !falselvl &&		     (!rmcommfl || locfl) && (p != buffer)) {			Comment	**t;			/* Place t onto the end of the list */			for (t=&comments; *t; t=&((*t)->next));			(*t) = my_alloc(sizeof(Comment),1);			(*t)->str = my_strdup(buffer);			(*t)->next = NULL;			(*t)->lineno = lineno;			(*t)->length = p - buffer;		}	return 1;}static intskipcont() {	char	locbuf[6];	char	*p = locbuf;	wchar	c;	int 	n;	CHECK(colm==0);	nextch(c);	if (c == '&') {		colm = 6;		line_width = LINE_WIDTH_MAX;		return 1;	}	else if (c == SYM_FPP) {	        unnextch(c);		return 0;	}	colm++;	for (n=5;;n--) {		if (c == '\t') {		        *p++ = (char)c;			nextch(c);			if (is_num(c) && c != '0') {				colm = 6;				line_width = LINE_WIDTH_MAX;				return 1;			}			else {			        unnextch(c);				ungetstr(locbuf, p - locbuf);				return 0;			}		}		else if (c == '/') {		        *p++ = (char)c;			nextch(c);			if (c == '*') {			        unnextch(c);				ungetstr(locbuf, p - locbuf);				return 0;			}			unnextch(c);			c = *--p;		}		else if (c == '\n' || c == SYM_EOF) {		        unnextch(c);			ungetstr(locbuf ,p - locbuf);			colm = 0;			return 0;		}		*p++ = (char)c;		if (n == 0) break;		nextch(c); colm++;	}	if (is_blank(c) || c == '0') {		ungetstr(locbuf, p - locbuf);		return 0;	}	line_width = line_width0;	return 1;}static intskipcont90(unsigned mode) {        wchar   c;	int	locfl=0;	char	locbuf[BUFSIZE];	char	*p; 	p = locbuf;	if (mode & MOD_RAW) {		for (;;) {			nextch(c);			switch (c) {			case ' ' :			case '\t': break;			case '&' :				if (locfl==1) {					colm++;					return 1;				}				else {				        unnextch(c);					ungetstr(locbuf, p - locbuf);					return 0;				}				break;			case '\n':				if (!locfl) {					locfl++;					line++; colm = 0;					p = locbuf;					continue;				}				/* no break */			default  :			        unnextch(c);				ungetstr(locbuf, p - locbuf);				return locfl;			}			*p++ = (char)c;			colm++;		}	}	else {		for (;;) {			nextch(c);			switch (c) {			case ' ' :			case '\t': break;			case '!' :				if (!locfl) {				        unnextch(c);					while (skip_comment(mode));				 	locfl++;				 	p = locbuf;					continue;				}				goto exit;			case '\n':				if (!locfl) {					locfl++;					p = locbuf;					line++; colm = 0;					continue;				}				goto exit;			case '&' :				if (locfl==1) {					colm++;					return 1;				}				goto exit;			case SYM_FPP:				if (locfl==1 && colm==0) {				        unnextch(c);					ungetsym('\n');					return 0;				}				goto exit;			default:				goto exit;			}			*p++ = (char)c;			colm++;		}exit:           unnextch(c);		ungetstr(locbuf, p - locbuf);		if (locfl)			return 1;		else	return 0;	}}static wchargetsym( unsigned mode ) {	wchar 	c;	for (;;) {	        nextch(c);		colm++;		sym_line = line;		if (colm > line_width) {			if (c != '\n' && c!= SYM_EOF)				continue;		}		switch (c) {		case ' ':		case '\t':			if (mode & MOD_SPACE)				continue;			break;		case '\n':		case SYM_EOF:			if ((mode & MOD_RAW) && (mode & MOD_CONT) && colm <= line_width) {				if (falselvl == 0) {					unnextch(c);					c = ' ';				}				else if (c == '\n') {					line++; colm = 0;				}				else {				        colm = 0;				}			}			else if (c == '\n') {				line++; colm = 0;				if (fixedformfl && (mode & MOD_CONT)) {					while (skip_comment(mode));					if (skipcont()) {						CHECK(colm==6);						continue;					}				}			}			else {			        colm = 0;			}			break;		case '!':			if (!(mode & MOD_RAW) && !(fixedformfl && colm==6) 				&& !(mode & MOD_IF)) {			        /* Process a trailing comment */				unnextch(c); 				skip_comment(mode);				CHECK(colm == 0);				if (fixedformfl && (mode & MOD_CONT)) {					while (skip_comment(mode));					if (skipcont()) {						CHECK(colm==6);						continue;					}				}				c = '\n';			}			break;		case '&':			if (!fixedformfl) {				if (mode & MOD_CONT) {					if (skipcont90(mode)) 						continue;				}			}			break;		case '/':			if (!(mode & MOD_RAW) && !no_ccom_fl) {				nextch(c);				if (c == '*') {					int	loclvl=0;						colm++;					for (;;) {						nextch(c);						if (c == '*') {							colm++;							nextch(c);							if (c == '/') {								colm++;								if (!loclvl) break;								else loclvl--;							}							else {							        unnextch(c);							}						}						else if (c == '\n') {							colm = 0;							line++;						}						else if(c == SYM_EOF) {							fppmess(ERR_LCOMM);							break;						}						else if(c == '/') {							colm++;							nextch(c);							if (c == '*') {								colm++;								loclvl++;							}							else {							        unnextch(c);							}						}						else {							colm++;						}					}					c = SYM_DUMMY;				}				else {				        unnextch(c);					c = '/';				}			}			break;		default:			if (!is_special(c) && (mode & MOD_LCASE)) 				c = lowcase(c);			break;		}		return c;	}}		static intget_tkop(SymPtr symp) {	switch (symvali(symp)) {	case FTN_FORMAT:		return(TK_FORMAT);	case FTN_IMPLICIT:		return(TK_IMPLICIT);	case FTN_DO:		return(TK_DO);	case FTN_READ:	case FTN_WRITE:		return(TK_RDWR);	case FTN_ASSIGN:		return(TK_ASGN);	case FTN_TYPE:			/* only for F90 */		return(TK_TYPE0);	case FTN_BYTE:	case FTN_CHARACTER:	case FTN_COMPLEX:	case FTN_DOUBLECOMP:	case FTN_DOUBLEPREC:	case FTN_INTEGER:	case FTN_LOGICAL:	case FTN_REAL:		return(TK_TYPE);	default:		return(TK_KEY);	}/*	return(TK_KEY);	*/}static intisfspec( char *s ) {	char	c;	c = lowcase(*s); s++;	switch (c) {	case 'b':		c = lowcase(*s);		if (c == 'n' || c== 'z') {			s++;			if ( *s == '\0') return 1;			else break;		}		while (is_num(*s)) s++;		if (*s == '\0') return 1;		break;	case 't':		c = lowcase(*s);		if (c == 'l' || c== 'r') 			s++;		while (is_num(*s)) s++;		if (*s == '\0') return 1;		break;	case 'e':		c = lowcase(*s);		if (c == 'n' || c== 's') 			s++;		while (is_num(*s)) s++;		if (*s == '\0') return 1;		break;	case 'a': case 'd': case 'f': case 'g':	case 'i': case 'l': case 'o': case 'z':		while (is_num(*s)) s++;		if (*s == '\0') return 1;		break;	case 's':		c = lowcase(*s);		if (c == 'p' || c == 's' || c == 'u')			s++;		if (*s == '\0')			return 1;		break;			case 'x': case 'r': case 'q': case 'p':		if (*s == '\0')			return 1;		break;			default: 		return 0;	}	return 0;}#define st_move1(x)  if(!(mode & MOD_NOGRAM)) {st_move(x);}Token   *get_token(unsigned mode) {	wchar 	c,c0;	char    *endp;	int	flreal;			/* used in number processing */	SymPtr	symp;	static	int fllogic = 0;	/* to process kind in logical constants */	static	int flimpl = 0;		/* to process implicit statement */	static	int flformat = 0;	/* to process format statement */	unsigned lmode;                 /* local mode */	lmode = mode /* & ~MOD_CONT */;loop:	endp = curtok->token;	curtok->val = TK_DUMMY;	c = getsym(mode);	CHECK(c);	curtok->lineno  = sym_line;	curtok->stid    = cur_stmt_id;	switch (c) {	case '\n':		case SYM_EOF:	curtok->val = TK_NL;	                st_move1(curtok->val);			*endp++ = (char)c;			onequalsym = NULL;	/* break assignment subst control */			flimpl = 0;		/* break implicit processing */			flformat = 0;		/* break format processing */			cur_stmt_id++;			break;	                	case SYM_FPP:	curtok->val = TK_FPP;	                st_move1(curtok->val);			*endp++ = (char)c;			break;	case SYM_DUMMY: *endp++ = ' ';			break;	case SYM_BOS:   curtok->val = TK_BOS;	                st_move1(curtok->val);			if (fixedformfl) {				CHECK(colm == 6);			}			*endp++ = cont_symbol;			break;	case SYM_EOMS:  /* it also delimits lexems */	                sympop();				if (sbfl) sb_mref_end();			goto loop;	case SYM_BF:	/* it simply delimits lexems */	                symhide();			goto loop;	case SYM_EF:    /* it simply delimits lexems */	                symunhide();			goto loop;	case SYM_EOC:   curtok->val = TK_EOC;			break;	case '\\':	*endp++ = (char)c;			c = getsym(MOD_RAW);			if (is_special(c)) {				ungetsym(c);			}			else if (c == '\n' || c == SYM_EOF) {			        goto loop;				/* endp[-1] = c = ' '; */			}			else {				*endp++ = (char)c;				st_move1(curtok->val);  /* TK_DUMMY */			}			break;/*	case ' ':	case '\t':	*endp++ = c;			break;			while (is_blank(c)) {				*endp++ = c;				if (endp - curtok->token >= MAXTOKENSIZE) {					curtok->length = MAXTOKENSIZE;					outtok(curtok);					endp = curtok->token;				}				c = getsym(lmode);			}			ungetsym(c);			break;*/	case '(':	curtok->val = TK_LPAR;			st_move1(curtok->val);			*endp++ = (char)c;			if (flimpl) {				flimpl++;				if (flimpl == 2 && !st_is(ST_NOIMPL)) {					st_move1(TK_IMPLICIT1);				}			}			if (flformat) {				flformat++;			}			break;	case ')':	curtok->val = TK_RPAR;