diff options
Diffstat (limited to 'unix/boot/spp/xpp/decl.c')
| -rw-r--r-- | unix/boot/spp/xpp/decl.c | 565 |
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); +} |