Repatch (from linux) of OSX IRAF

1 files changed, 565 insertions, 0 deletions

diff --git a/unix/boot/spp/xpp/decl.c b/unix/boot/spp/xpp/decl.c
new file mode 100644
index 00000000..b5c64774
--- /dev/null
+++ b/unix/boot/spp/xpp/decl.c
@@ -0,0 +1,565 @@
+/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+ */
+
+#include <stdio.h>
+#include <ctype.h>
+#include <string.h>
+#include "xpp.h"
+
+#define	import_spp
+#include <iraf.h>
+
+#ifndef SZ_SBUF
+#define	SZ_SBUF		4096		/* max chars in proc. decls.	*/
+#endif
+#define	SZ_TOKEN	63		/* max chars in a token		*/
+#define	MAX_SYMBOLS	300		/* max symbol table entries	*/
+#define	SPMAX		(&sbuf[SZ_SBUF-1])
+#define	UNDECL		0
+
+/*
+ * DECL.C -- A package of routines for parsing argument lists and declarations
+ * and generating the Fortran (actually, RPP) declarations required to compile
+ * a procedure.  The main functions of this package at present are to remove
+ * arbitrary limitations on the ordering of argument declarations imposed by
+ * Fortran, and to perform various compile time checks on all declarations.
+ * Specifically, we allow scalar arguments to be used to dimension array
+ * arguments before the scalar arguments are declared, and we check for
+ * multiple declarations of the same object.
+ *
+ * Package Externals:
+ *
+ *	    d_newproc (name, type)	process procedure declaration
+ *	d_declaration (typestr)		process typed declaration statement
+ *	    d_codegen (fp)		output declarations for sym table
+ *	    d_runtime (text)		return any runtime initialization text
+ *
+ *	*symbol =  d_enter (symbol, dtype, flags)
+ *	*symbol = d_lookup (symbol)
+ *
+ * The external procedures YY_INPUT() and YY_UNPUT() are called to get/putpack
+ * characters from the input.
+ */
+
+extern	int linenum[];			/* line numbers in files	*/
+extern	int istkptr;			/* istk pointer			*/
+
+struct symbol {
+	char	*s_name;		/* symbol name			*/
+	char	*s_dimstr;		/* dimension string if array	*/
+	short	s_dtype;		/* datatype (0 until declared)	*/
+	short	s_flags;		/* type flags			*/
+};
+
+#define	S_ARGUMENT	001		/* symbol is an argument	*/
+#define	S_ARRAY		002		/* symbol is an array		*/
+#define	S_FUNCTION	004		/* symbol is a function()	*/
+#define	S_EXTERN	010		/* symbol is an external	*/
+
+static	char sbuf[SZ_SBUF+1];		/* string buffer		*/
+static	char *nextch = sbuf;		/* next location in sbuf	*/
+static	char procname[SZ_FNAME+1];	/* procedure name		*/
+static	int  proctype;			/* procedure type if function	*/
+static	struct symbol sym[MAX_SYMBOLS];	/* symbol table			*/
+static	int nsym = 0;			/* number of symbols		*/
+
+struct	symbol *d_enter();
+struct	symbol *d_lookup();
+
+extern  void error (int errcode, char *errmsg);
+extern  void xpp_warn (char *warnmsg);
+extern  int  yy_input (void);
+extern  void yy_unput (char ch);
+
+
+void  d_newproc (char *name, int dtype);
+int   d_declaration (int dtype);
+void  d_codegen (register FILE *fp);
+void  d_runtime (char *text);
+void  d_makedecl (struct symbol *sp, FILE *fp);
+struct symbol *d_enter (char *name, int dtype, int flags);
+struct symbol *d_lookup (char *name);
+void  d_chksbuf (void);
+int   d_gettok (char *tokstr, int maxch);
+void  d_declfunc (struct symbol *sp, FILE *fp);
+
+
+
+
+/* D_NEWPROC -- Process a procedure declaration.  The name of the procedure
+ * is passed as the single argument.  The input stream is left positioned
+ * with the ( of the argument list as the next token (if present).  INPUT is
+ * called repeatedly to read the remainder of the declaration, which may span
+ * several lines.  The symbol table is cleared whenever a new procedure
+ * declaration is started.
+ */
+void
+d_newproc (name, dtype)
+char	*name;			/* procedure name		*/
+int	dtype;			/* procedure type (0 if subr)	*/
+{
+	register int	token;
+	char	tokstr[SZ_TOKEN+1];
+
+
+
+	/* Print procedure name to keep the user amused in case the file
+	 * is large and the machine slow.
+	 */
+	fprintf (stderr, "   %s:\n", name);
+	fflush (stderr);
+
+	strncpy (procname, name, SZ_FNAME);
+	proctype = dtype;
+	nextch = sbuf;
+	nsym = 0;
+
+	/* Check for null argument list. */
+	if (d_gettok(tokstr,SZ_TOKEN) != '(')
+	    return;
+
+	/* Process the argument list.
+	 */
+	while ((token = d_gettok(tokstr,SZ_TOKEN)) != ')') {
+	    if (isalpha(token)) {
+		/* Enter argument name into the symbol table.
+		 */
+		if (d_lookup (tokstr) != NULL) {
+		    char lbuf[200];
+		    sprintf (lbuf, "%s.%s multiply declared",
+			procname, tokstr);
+		    xpp_warn (lbuf);
+		} else
+		    d_enter (tokstr, UNDECL, S_ARGUMENT);
+	    } else if (token == '\n') {
+		linenum[istkptr]++;
+		continue;
+	    } else if (token == ',') {
+		continue;
+	    } else
+		error (XPP_SYNTAX, "bad syntax in procedure argument list");
+	}
+}
+
+
+/* D_DECLARATION -- Process a declaration statement.  This is any statement
+ * of the form
+ *
+ *	type	obj1, obj2, ..., objn
+ *
+ * ignoring comments and newlines following commas.  The recognized types are
+ *
+ *	bool, char, short, int, long, real, double, complex, pointer, extern
+ *
+ * If "obj" is followed by "()" the function type bit is set.  If followed
+ * by "[...]" the array bit is set and the dimension string is accumulated,
+ * converting [] into (), adding 1 for char arrays, etc. in the process.
+ * Each OBJ identifier is entered into the symbol table with its attributes.
+ */
+int
+d_declaration (int dtype)
+{
+	register struct	symbol *sp = NULL;
+	register char	ch;
+	int	token, ndim;
+	char	tokstr[SZ_TOKEN+1];
+
+	while ((token = d_gettok(tokstr,SZ_TOKEN)) != '\n') {
+	    if (isalpha(token)) {
+
+#ifdef CYGWIN
+	        {   if (strncmp ("procedure", tokstr, 9) == 0) { 
+/*
+      			extern char *yytext;
+      			pushcontext (PROCSTMT);
+      			d_gettok (yytext, SZ_TOKEN-1);
+      			d_newproc (yytext, dtype);
+*/
+      			pushcontext (PROCSTMT);
+      			d_gettok (tokstr, SZ_TOKEN-1);
+      			d_newproc (tokstr, dtype);
+                	return (1);
+              	    }
+	        }
+#endif
+
+		/* Enter argument or variable name into the symbol table.
+		 * If symbol is already in table it must be an argument
+		 * or we have a multiple declaration.
+		 */
+		if ((sp = d_lookup (tokstr)) != NULL) {
+		    if (dtype == XTY_EXTERN)
+			sp->s_flags |= S_EXTERN;
+		    else if (sp->s_flags & S_ARGUMENT && sp->s_dtype == UNDECL)
+			sp->s_dtype = dtype;
+		    else {
+			char lbuf[200];
+			sprintf (lbuf, "%s.%s multiply declared",
+			    procname, tokstr);
+			xpp_warn (lbuf);
+		    }
+		} else
+		    sp = d_enter (tokstr, dtype, 0);
+
+		/* Check for trailing () or [].
+		 */
+		token = d_gettok (tokstr, SZ_TOKEN);
+
+		switch (token) {
+		case ',':
+		case '\n':
+		    yy_unput (token);
+		    continue;
+
+		case '(':
+		    /* Function declaration.
+		     */
+		    if ((token = d_gettok(tokstr,SZ_TOKEN)) != ')') {
+			yy_unput (token);
+			error (XPP_SYNTAX,
+			    "missing right paren in function declaration");
+		    } 
+		    sp->s_flags |= S_FUNCTION;
+		    continue;
+
+		case '[':
+		    /* Array declaration.  Turn [] into (), add space for EOS
+		     * if char array, set array bit for operand in symbol table.
+		     */
+		    sp->s_dimstr = nextch;
+		    *nextch++ = '(';
+		    ndim = 1;
+
+		    while ((ch = yy_input()) != ']' && ch > 0) {
+			if (ch == '\n') {
+			    yy_unput (ch);
+			    error (XPP_SYNTAX,
+				"missing right bracket in array declaration");
+			    break;
+			} else if (ch == ',') {
+			    /* Add one char for the EOS in the first axis of
+			     * a multidimensional char array.
+			     */
+			    if (ndim == 1 && dtype == TY_CHAR)
+				*nextch++ = '+', *nextch++ = '1';
+			    *nextch++ = ',';
+			    ndim++;
+			} else if (ch == 'A') {
+			    /* Turn [ARB] into [*] for array arguments. */
+			    if ((ch = yy_input()) == 'R') {
+				if ((ch = yy_input()) == 'B') {
+				    *nextch++ = '*';
+				    ndim++;
+				    if (!(sp->s_flags & S_ARGUMENT)) {
+					error (XPP_SYNTAX,
+					    "local variable dimensioned ARB");
+					break;
+				    }
+				} else {
+				    *nextch++ = 'A';
+				    *nextch++ = 'R';
+				    yy_unput (ch);
+				}
+			    } else {
+				*nextch++ = 'A';
+				yy_unput (ch);
+			    }
+			} else
+			    *nextch++ = ch;
+		    }
+
+		    if (ndim == 1 && dtype == TY_CHAR)
+			*nextch++ = '+', *nextch++ = '1';
+
+		    *nextch++ = ')';
+		    *nextch++ = '\0';
+		    d_chksbuf();
+
+		    sp->s_flags |= S_ARRAY;
+		    break;
+
+		default:
+		    error (XPP_SYNTAX, "declaration syntax error");
+		}
+
+	    } else if (token == ',') {
+		/* Check for implied continuation on the next line.
+		 */
+		do {
+		    ch = yy_input();
+		} while (ch == ' ' || ch == '\t');
+
+		if (ch == '\n')
+		    linenum[istkptr]++;
+		else
+		    yy_unput (ch);
+
+	    } else if (sp && (sp->s_flags & S_ARGUMENT)) {
+		error (XPP_SYNTAX, "bad syntax in procedure argument list");
+	    } else
+		error (XPP_SYNTAX, "declaration syntax error");
+	}
+
+	yy_unput ('\n');
+
+	return (0);
+}
+
+
+/* D_CODEGEN -- Output the RPP declarations for all symbol table entries.
+ * Declare scalar arguments first, followed by array arguments, followed
+ * by nonarguments.
+ */
+void
+d_codegen (fp)
+register FILE	*fp;
+{
+	register struct symbol *sp;
+	register struct	symbol *top = &sym[nsym-1];
+	extern	char *type_decl[];
+	int	col;
+
+	/* Declare the procedure itself.
+	 */
+	if (proctype) {
+	    fputs (type_decl[proctype], fp);
+	    fputs (" x$func ", fp);
+	} else
+	    fputs ("x$subr ", fp);
+
+	fputs (procname, fp);
+	fputs (" ", fp);
+
+	/* Output the argument list.  Keep track of the approximate line length
+	 * and break line if it gets too long for the second pass.
+	 */
+	fputs ("(", fp);
+	col = strlen(procname) + 9;
+
+	for (sp=sym;  sp <= top;  sp++)
+	    if (sp->s_flags & S_ARGUMENT) {
+		if (sp > sym) {
+		    fputs (", ", fp);
+		    col += 2;
+		}
+		col += strlen (sp->s_name);
+		if (col >= 78) {
+		    fputs ("\n\t", fp);
+		    col = strlen (sp->s_name) + 1;
+		}
+		fputs (sp->s_name, fp);
+	    }
+	fputs (")\n", fp);
+
+	/* Declare scalar arguments. */
+	for (sp=sym;  sp <= top;  sp++)
+	    if (sp->s_flags & S_ARGUMENT)
+		if (!(sp->s_flags & S_ARRAY))
+		    d_makedecl (sp, fp);
+
+	/* Declare vector arguments. */
+	for (sp=sym;  sp <= top;  sp++)
+	    if (sp->s_flags & S_ARGUMENT)
+		if (sp->s_flags & S_ARRAY)
+		    d_makedecl (sp, fp);
+
+	/* Declare local variables and externals. */
+	for (sp=sym;  sp <= top;  sp++)
+	    if (sp->s_flags & S_ARGUMENT)
+	        continue;
+	    else if (sp->s_flags & S_FUNCTION)
+	        d_declfunc (sp, fp);
+	    else
+		d_makedecl (sp, fp);
+}
+
+
+/* D_RUNTIME -- Return any runtime procedure initialization statements,
+ * i.e., statements to be executed at runtime when a procedure is entered,
+ * in the given output buffer.
+ */
+void
+d_runtime (char *text)
+{
+	/* For certain types of functions, ensure that the function value
+	 * is initialized to a legal value, in case the procedure is exited
+	 * without returning a value (e.g., during error processing).
+	 */
+	switch (proctype) {
+	case XTY_REAL:
+	case XTY_DOUBLE:
+	    sprintf (text, "\t%s = 0\n", procname);
+	    break;
+	default:
+	    text[0] = EOS;
+	    break;
+	}
+}
+
+
+/* D_MAKEDECL -- Output a single RPP symbol declaration.  Each declaration
+ * is output on a separate line.
+ */
+void
+d_makedecl (sp, fp)
+register struct symbol *sp;	/* symbol table entry		*/
+register FILE	*fp;		/* output file			*/
+{
+	extern	char *type_decl[];
+
+	if (sp->s_dtype != UNDECL) {
+	    fputs (type_decl[sp->s_dtype], fp);
+	    fputs ("\t", fp);
+	    fputs (sp->s_name, fp);
+	    if (sp->s_flags & S_ARRAY)
+		fputs (sp->s_dimstr, fp);
+	    fputs ("\n", fp);
+	}
+
+	if (sp->s_flags & S_EXTERN) {
+	    fputs (type_decl[XTY_EXTERN], fp);
+	    fputs ("\t", fp);
+	    fputs (sp->s_name, fp);
+	    fputs ("\n", fp);
+	}
+}
+
+
+/* D_ENTER -- Add a symbol to the symbol table.  Return a pointer to the
+ * new symbol.
+ */
+struct symbol *
+d_enter (name, dtype, flags)
+char	*name;			/* symbol name			*/
+int	dtype;			/* data type code		*/
+int	flags;			/* flag bits			*/
+{
+	register struct	symbol *sp;
+
+
+	sp = &sym[nsym];
+	nsym++;
+	if (nsym > MAX_SYMBOLS)
+	    error (XPP_COMPERR, "too many declarations in procedure");
+
+	sp->s_name = strcpy (nextch, name);
+	nextch += strlen(name) + 1;
+	d_chksbuf();
+
+	sp->s_dimstr = NULL;
+	sp->s_dtype = dtype;
+	sp->s_flags = flags;
+
+	return (sp);
+}
+
+
+/* D_LOOKUP -- Lookup a symbol in the symbol table.  Return a pointer to the
+ * symbol table entry.
+ */
+struct symbol *
+d_lookup (name)
+char	*name;			/* symbol name			*/
+{
+	register struct	symbol *sp;
+	register struct	symbol *top = &sym[nsym-1];
+
+	for (sp=sym;  sp <= top;  sp++)
+	    if (sp->s_name[0] == name[0])
+		if (strcmp (sp->s_name, name) == 0)
+		    return (sp);
+
+	return (NULL);
+}
+
+
+/* D_CHKSBUF -- Check for overflow on the string buffer.
+ */
+void
+d_chksbuf()
+{
+	if (nextch > SPMAX)
+	    error (XPP_COMPERR, "decl string buffer overflow");
+}
+
+
+/* D_GETTOK -- Get the next token from the input stream.  Return the integer
+ * value of the first character of the token as the function value.  EOF
+ * is an error in this application, not a token.
+ */
+int
+d_gettok (tokstr, maxch)
+char	*tokstr;		/* receives token string	*/
+int	maxch;			/* max chars to token string	*/
+{
+	register char 	*op = tokstr;
+	register int	ch, n;
+
+
+
+	/* Skip whitespace and comments to first char of next token.
+	 */
+	do {
+	    ch = yy_input();
+	} while (ch == ' ' || ch == '\t');
+
+	if (ch == '#') {
+	    /* Skip a comment.
+	     */
+	    while ((ch = yy_input()) != '\n' && ch > 0)
+		;
+	}
+
+	if (ch <= 0)
+	    error (XPP_SYNTAX, "unexpected EOF");
+
+	*op++ = ch;
+	n = maxch - 1;
+
+	if (isalpha (ch)) {
+	    /* Identifer.
+	     */
+	    while ((ch = yy_input()) > 0)
+		if (isalnum(ch) || ch == '_') {
+		    *op++ = ch;
+		    if (--n <= 0)
+			error (XPP_SYNTAX, "identifier too long");
+		} else {
+		    yy_unput (ch);
+		    break;
+		}
+
+	} else if (isdigit (ch)) {
+	    /* Number.
+	     */
+	    while ((ch = yy_input()) > 0)
+		if (isdigit(ch)) {
+		    *op++ = ch;
+		    if (--n <= 0)
+			error (XPP_SYNTAX, "number too long");
+		} else {
+		    yy_unput (ch);
+		    break;
+		}
+
+	}
+
+	*op++ = '\0';
+	if (ch <= 0)
+	    error (XPP_SYNTAX, "unexpected EOF");
+
+	return (tokstr[0]);
+}
+
+
+/* D_DECLFUNC -- Declare a function.  This module is provided to allow
+ * for any special treatment required for certain types of function
+ * declarations.
+ */
+void
+d_declfunc (sp, fp)
+register struct symbol *sp;
+FILE  *fp;
+{
+	d_makedecl (sp, fp);
+}