diff options
Diffstat (limited to 'unix/boot/spp/xpp/xppcode.c.bak')
| -rw-r--r-- | unix/boot/spp/xpp/xppcode.c.bak | 1705 |
1 files changed, 1705 insertions, 0 deletions
diff --git a/unix/boot/spp/xpp/xppcode.c.bak b/unix/boot/spp/xpp/xppcode.c.bak new file mode 100644 index 00000000..6db614bb --- /dev/null +++ b/unix/boot/spp/xpp/xppcode.c.bak @@ -0,0 +1,1705 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#include <ctype.h> +#include "xpp.h" + +#define import_spp +#include <iraf.h> + +/* + * C code for the first pass of the IRAF subset preprocessor (SPP). + * The decision to initially organize the SPP compiler into two passes was + * made to permit maximum use of the existing raftor preprocessor, which is + * the basis for the second pass of the SPP. Eventually the two passes + * should be combined into a single program. Most of the operations performed + * by the first pass (XPP) should be performed AFTER macro substitution, + * rather than before as is the case in the current implementation, which + * processes macros in the second pass (RPP). + * + * Beware that this is not a very good program which was not carefully + * designed and which was never intended to have a long lifetime. The next + * step is to replace the two passes by a single program which is functionally + * very similar, but which is more carefully engineered and which is written + * in the SPP language calling IRAF file i/o. Eventually a true compiler + * will be written, providing many new features, i.e., structures and pointers, + * automatic storage class, mapped arrays, enhanced i/o support, and good + * compile time error checking. This compiler will also feature a table driven + * code generator (generating primitive Fortran statements), which will provide + * greater machine independence. + */ + + +extern char *vfn2osfn(); + +/* Escape sequence characters and their binary equivalents. + */ +char *esc_ch = "ntfr\\\"'"; +char *esc_val = "\n\t\f\r\\\"\'"; + +/* External and internal data stuctures. We need access to the LEX i/o + * buffers because we use the LEX i/o macros, which provide pushback, + * because we must change the streams to process includes, and so on. + * These definitions are VERY Lex dependent. + */ +extern char yytext[]; /* LEX character buffer */ +extern int yyleng; /* length of string in yytext */ +extern FILE *yyin, *yyout; /* LEX input, output files */ + +extern char yytchar, *yysptr, yysbuf[]; +extern int yylineno; + +#define U(x) x +/* +#define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10\ +?(yylineno++,yytchar):yytchar)==EOF?0:yytchar) +#define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;} +*/ + +extern int input(); +extern void yyunput(); +extern char *yytext_ptr; +#define unput(c) yyunput( c, (yytext_ptr) ) + + + +int context = GLOBAL; /* lexical context variable */ +extern int hbindefs, foreigndefs; +char *machdefs[] = { "mach.h", "config.h", "" }; + +/* The task structure is used for TASK declarations. Since this is a + * throwaway program we do not bother with dynamic storage allocation, + * which would remove the limit on the number of tasks in a task statment. + */ +struct task { + char *task_name; /* logical task name */ + char *proc_name; /* name of procedure */ + short name_offset; /* offset of name in dictionary */ +}; + +/* The string structure is used for STRING declarations and for inline + * strings. Strings are stored in a fixed size, statically allocated + * string buffer. + */ +struct string { + char *str_name; /* name of string */ + char *str_text; /* ptr to text of string */ + short str_length; /* length of string */ +}; + +struct task task_list[MAX_TASKS]; +struct string string_list[MAX_STRINGS]; + +FILE *istk[MAX_INCLUDE]; /* stack for input file descriptors */ +int linenum[MAX_INCLUDE]; /* line numbers in files */ +char fname[MAX_INCLUDE][SZ_PATHNAME];/* file names */ +int istkptr = 0; /* istk pointer */ + +char obuf[SZ_OBUF]; /* buffer for body of procedure */ +char dbuf[SZ_DBUF]; /* buffer for misc proc. decls. */ +char sbuf[SZ_SBUF]; /* string buffer */ +char *sp = sbuf; /* string buffer pointer */ +char *op = obuf; /* pointer in output buffer */ +char *dp = dbuf; /* pointer in decls buffer */ +int nstrings = 0; /* number of strings so far */ +int strloopdecl; /* data dummy do index declared? */ + +int ntasks = 0; /* number of tasks in interpreter */ +int str_idnum = 0; /* for generating unique string names */ +int nbrace = 0; /* must be zero when "end" is reached */ +int nswitch = 0; /* number switch stmts in procedure */ +int errflag; +int errhand = NO; /* set if proc employs error handler */ +int errchk = NO; /* set if proc employs error checking */ + + +/* SKIPNL -- Skip to newline, e.g., when a comment is encountered. + */ +skipnl() +{ + int c; + while ((c=input()) != '\n') + ; + unput ('\n'); +} + + +/* + * CONTEXT -- Package for setting, saving, and restoring the lexical context. + * The action of the preprocessor in some cases depends upon the context, i.e., + * what type of statement we are processing, whether we are in global space, + * within a procedure, etc. + */ + +#define MAX_CONTEXT 5 /* max nesting of context */ + +int cntxstk[MAX_CONTEXT]; /* for saving context */ +int cntxsp = 0; /* save stack pointer */ + + +/* SETCONTEXT -- Set the context. Clears any saved context. + */ +setcontext (new_context) +int new_context; +{ + context = new_context; + cntxsp = 0; +} + + +/* PUSHCONTEXT -- Push a temporary context. + */ +pushcontext (new_context) +int new_context; +{ + cntxstk[cntxsp++] = context; + context = new_context; + + if (cntxsp > MAX_CONTEXT) + error (XPP_COMPERR, "save context stack overflow"); +} + + +/* POPCONTEXT -- Pop the former context. If the current context is PROCSTMT + * (just finished compiling a procedure statement) then set the context to DECL + * to indicate that we are entering the declarations section of a procedure. + */ +popcontext() +{ + if (context & PROCSTMT) { + context = DECL; + if (cntxsp > 0) + --cntxsp; + } else if (cntxsp > 0) + context = cntxstk[--cntxsp]; + + return (context); +} + + +/* Keyword table. The simple hashing scheme requires that the keywords appear + * in the table in sorted order. + */ +#define LEN_KWTBL 18 + +struct { + char *keyw; /* keyword name string */ + short opcode; /* opcode from above definitions */ + short nelem; /* number of table elements to skip if + * to get to next character class. + */ +} kwtbl[] = { + "FALSE", XTY_FALSE, 0, + "TRUE", XTY_TRUE, 0, + "bool", XTY_BOOL, 0, + "char", XTY_CHAR, 1, + "complex", XTY_COMPLEX, 0, + "double", XTY_DOUBLE, 0, + "error", XTY_ERROR, 1, + "extern", XTY_EXTERN, 0, + "false", XTY_FALSE, 0, + "iferr", XTY_IFERR, 2, + "ifnoerr", XTY_IFNOERR, 1, + "int", XTY_INT, 0, + "long", XTY_LONG, 0, + "pointer", XTY_POINTER, 1, + "procedure", XTY_PROC, 0, + "real", XTY_REAL, 0, + "short", XTY_SHORT, 0, + "true", XTY_TRUE, 0, + }; + +/* short kwindex[30]; simple alphabetic hash index */ +/* #define CINDEX(ch) (isupper(ch)?ch-'A':ch-'a') */ + +#define MAXCH 128 +short kwindex[MAXCH]; /* simple alphabetic hash index */ +#define CINDEX(ch) (ch) + + +/* HASHTBL -- Hash the keyword table. Initializes the "kwindex" hash table. + * For each character in the alphabet, the index gives the index into the + * sorted keyword table. If there is no keyword name beginning with the index + * character, the index entry is set to -1. + */ +hashtbl() +{ + int i, j; + + for (i=j=0; i <= MAXCH; i++) { + if (i == CINDEX (kwtbl[j].keyw[0])) { + kwindex[i] = j; + j = min (LEN_KWTBL-1, j + kwtbl[j].nelem + 1); + } else + kwindex[i] = -1; + } +} + + +/* FINDKW -- Lookup an indentifier in the keyword table. Return the opcode + * of the keyword, or ERR if no match. + */ +findkw() +{ + register char ch, *p, *q; + int i, ilimit; + + if (kwindex[0] == 0) + hashtbl(); + + i = CINDEX (yytext[0]); + if (i < 0 || i >= MAXCH || (i = kwindex[i]) < 0) + return (ERR); + ilimit = i + kwtbl[i].nelem; + + for (; i <= ilimit; i++) { + p = kwtbl[i].keyw + 1; + q = yytext + 1; + + for (; *p != EOS; q++, p++) { + ch = *q; + /* 5DEC95 - Don't case convert keywords. + if (isupper (ch)) + ch = tolower (ch); + */ + if (*p != ch) + break; + } + if (*p == EOS && *q == EOS) + return (kwtbl[i].opcode); + } + return (ERR); +} + + +/* MAPIDENT -- Lookup an identifier in the keyword table. If the identifier is + * not a keyword, output it as is. If a datatype keyword, the action depends + * on whether we are in a procedure body or not (i.e., whether the keyword + * begins a declaration or is a type coercion function). Most of the other + * keywords are mapped into special x$.. identifiers for further processing + * by the second pass. + */ +mapident() +{ + int i, findkw(); + char *str_fetch(); + register char *ip, *op; + + /* If not keyword and not defined string, output as is. The first + * char must be upper case for the name to be recognized as that of + * a defined string. If we are processing a "define" macro expansion + * is disabled. + */ + if ((i = findkw()) == ERR) { + if (!isupper(yytext[0]) || (context & DEFSTMT) || + (ip = str_fetch (yytext)) == NULL) { + + outstr (yytext); + return; + + } else { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + do_string ('"', STR_DEFINE); + return; + } + } + + /* If datatype keyword, call do_type. */ + if (i <= XTY_POINTER) { + do_type (i); + return; + } + + switch (i) { + case XTY_TRUE: + outstr (".true."); + break; + case XTY_FALSE: + outstr (".false."); + break; + case XTY_IFERR: + case XTY_IFNOERR: + outstr (yytext); + errhand = YES; + errchk = YES; + break; + case XTY_ERROR: + outstr (yytext); + errchk = YES; + break; + + case XTY_EXTERN: + /* UNREACHABLE (due to decl.c additions). + */ + outstr ("x$extn"); + break; + + default: + error (XPP_COMPERR, "Keyword lookup error"); + } +} + + +char st_buf[SZ_STBUF]; +char *st_next = st_buf; + +struct st_def { + char *st_name; + char *st_value; +} st_list[MAX_DEFSTR]; + +int st_nstr = 0; + +/* STR_ENTER -- Enter a defined string into the string table. The string + * table is a kludge to provide the capability to define strings in SPP. + * The problem is that XPP handles strings but RPP handles macros, hence + * strings cannot be defined. We get around this by recognizing defines + * of the form 'define NAME "..."'. If a macro with a quoted value is + * encounted we are called to enter the name and the string into the + * table. LOOKUP, above, subsequently searches the table for defined + * strings. The name must be upper case or the table will not be searched. + * + * N.B.: we are called by the lexical analyser with 'define name "' in + * yytext. The next input() will return the first char of the string. + */ +str_enter() +{ + register char *ip, *op, ch; + register struct st_def *s; + register int n; + char name[SZ_FNAME+1]; + + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Do not accept statement unless the name is upper case. + */ + if (!isupper (*ip)) { + outstr (yytext); + return; + } + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op = EOS; + + /* Check for a redefinition. */ + for (n=st_nstr, s=st_list, ch=name[0]; --n >= 0; s++) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, name) == 0) + break; + } + + /* Make a new entry?. */ + if (n < 0) { + s = &st_list[st_nstr++]; + if (st_nstr >= MAX_DEFSTR) + error (XPP_COMPERR, "Too many defined strings"); + + /* Put defined NAME in string buffer. */ + for (s->st_name = st_next, ip=name; *st_next++ = *ip++; ) + ; + } + + /* Put value in string buffer. + */ + s->st_value = st_next; + traverse ('"'); + for (ip=yytext; (*st_next++ = *ip++) != EOS; ) + ; + *st_next++ = EOS; + + if (st_next - st_buf >= SZ_STBUF) + error (XPP_COMPERR, "Too many defined strings"); +} + + +/* STR_FETCH -- Search the defined string table for the named string + * parameter and return a pointer to the string if found, NULL otherwise. + */ +char * +str_fetch (strname) +register char *strname; +{ + register struct st_def *s = st_list; + register int n = st_nstr; + register char ch = strname[0]; + + while (--n >= 0) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, strname) == 0) + return (s->st_value); + s++; + } + + return (NULL); +} + + +/* MACRO_REDEF -- Redefine the macro to automatically add a P2<T> macro + * to struct definitions. + */ +macro_redef () +{ + register int n; + register char *ip, *op, ch; + char name[SZ_FNAME]; + char value[SZ_LINE]; + + + outstr ("define\t"); + memset (name, 0, SZ_FNAME); + memset (value, 0, SZ_LINE); + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op++ = '\t'; + *op = EOS; + outstr (name); + + + /* Modify value. + */ + outstr ("Memr(P2R"); + while ( (ch = input()) != EOF ) { + if (ch == '\n') { + break; + } else if (ch == '#') { /* eat a comment */ + while ((ch = input()) != '\n') + ; + break; + } else if (ch == '[') { + outstr ("("); + } else if (ch == ']') { + outstr (")"); + } else { + char chr[2]; + chr[0] = ch; chr[1] = '\0'; + outstr (chr); + } + } + + outstr (")\n"); + linenum[istkptr]++; +} + + +/* SETLINE -- Set the file line number. Used by the first pass to set + * line number after processing an include file and in various other + * places. Necessary to get correct line numbers in error messages from + * the second pass. + */ +setline() +{ + char msg[20]; + + if (istkptr == 0) { /* not in include file */ + sprintf (msg, "#!# %d\n", linenum[istkptr] - 1); + outstr (msg); + } +} + + +/* OUTPUT -- Output a character. If we are processing the body of a procedure + * or a data statement, put the character into the output buffer. Otherwise + * put the character to the output file. + * + * NOTE -- the redirection logic shown below is duplicated in OUTSTR. + */ +output (ch) +char ch; +{ + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + *op++ = ch; + if (op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + *dp++ = ch; + if (dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + putc (ch, yyout); + } +} + + +/* Datatype keywords for declarations. The special x$.. keywords are + * for communication with the second pass. Note that this table is machine + * dependent, since it maps char into type short. + */ +char *type_decl[] = RPP_TYPES; + + +/* Intrinsic functions used for type coercion. These mappings are machine + * dependent (MACHDEP). If your machine has INTEGER*2 and INTEGER*4, and + * integer cannot be passed as an argument when a short or long is expected, + * and your compiler has INT2 and INT4 type coercion intrinsic functions, + * you should use those here instead of INT (which happens to work for a VAX). + * If you cannot pass an int when a short is expected (i.e., IBM), and you + * do not have an INT2 intrinsic function, you should provide an external + * INTEGER*2 function called "int2" and use that for type coercion. Note + * that it will then be necessary to have the preprocessor automatically + * generate a declaration for the function. This nonsense will all go away + * when we set up a proper table driven code generator!! + */ +char *intrinsic_function[] = { + "", /* table is one-indexed */ + "(0 != ", /* bool(expr) */ + "int", /* char(expr) */ + "int", /* short(expr) */ + "int", /* int(expr) */ + "int", /* long(expr) */ + "real", /* real(expr) */ + "dble", /* double(expr) */ + "cmplx", /* complex(expr) */ + "int" /* pointer(expr) */ +}; + + +/* DO_TYPE -- Process a datatype keyword. The type of processing depends + * on whether we are called when processing a declaration or an expression. + * In expressions, the datatype keyword is the type coercion intrinsic + * function. DEFINE statements are a special case; we treat them as + * expressions, since macros containing datatype keywords are used in + * expressions more than in declarations. This is a kludge until the problem + * is properly resolved by processing macros BEFORE code generation. + * In the current implementation, macros are handled by the second pass (RPP). + */ +do_type (type) +int type; +{ + char ch; + + if (context & (BODY|DEFSTMT)) { + switch (type) { + case XTY_BOOL: + for (ch=input(); ch == ' ' || ch == '\t'; ch=input()) + ; + if (ch != '(') + error (XPP_SYNTAX, "Illegal boolean expr"); + outstr (intrinsic_function[type]); + return; + + case XTY_CHAR: + case XTY_SHORT: + case XTY_INT: + case XTY_LONG: + case XTY_REAL: + case XTY_DOUBLE: + case XTY_COMPLEX: + case XTY_POINTER: + outstr (intrinsic_function[type]); + return; + + default: + error (XPP_SYNTAX, "Illegal type coercion"); + } + + } else { + /* UNREACHABLE when in declarations section of a procedure. + */ + fprintf (yyout, type_decl[type]); + } +} + + +/* DO_CHAR -- Process a char array declaration. Add "+1" to the first + * dimension to allow space for the EOS. Called after LEX has recognized + * "char name[". If we reach the closing ']', convert it into a right paren + * for the second pass. + */ +do_char() +{ + char ch; + + for (ch=input(); ch != ',' && ch != ']'; ch=input()) + if (ch == '\n' || ch == EOS) { + error (XPP_SYNTAX, "Missing comma or ']' in char declaration"); + unput ('\n'); + return; + } else + output (ch); + + outstr ("+1"); + if (ch == ']') + output (')'); + else + output (ch); +} + + +/* SKIP_HELPBLOCK -- Skip over a help block (documentation section). + */ +skip_helpblock() +{ + char ch; + + + /* fgets() no longer works with FLEX + while (fgets (yytext, SZ_LINE, yyin) != NULL) { + if (istkptr == 0) + linenum[istkptr]++; + + if (yytext[0] == '.' && (yytext[1] == 'e' || yytext[1] == 'E')) { + yytext[8] = EOS; + if (strcmp (&yytext[1], "endhelp") == 0 || + strcmp (&yytext[1], "ENDHELP") == 0) + break; + } + } + */ + + while ( (ch = input()) != EOF ) { + if (ch == '.') { /* check for ".endhelp" */ + ch = input (); + if (ch == 'e' || ch == 'E') { + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + break; + } else + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + + } else if (ch == '\n') { /* skip line */ + ; + } else { + for (ch=input(); ch != '\n' && ch != EOS; ch=input()) + ; + } + if (istkptr == 0) + linenum[istkptr]++; + } +} + + +/* PARSE_TASK_STATEMENT -- Parse the task statement, building up a list + * of task_name/procedure_name structures in the "task_list" array. + * + * task task1, task2, task3=proc3, task4, ... + * + * Task names are placed in the string buffer as one big string, with EOS + * delimiters between the names. This "dictionary" string is converted + * into a data statement at "end_code" time, along with any other strings + * in the runtask procedure. The procedure names, which may differ from + * the task names, are saved in the upper half of the output buffer. We can + * do this because we know that the runtask procedure is small and will not + * come close to filling up the output buffer, which buffers only the body + * of the procedure currently being processed. + * N.B.: Upon entry, the input is left positioned to just past the "task" + * keyword. + */ +parse_task_statement() +{ + register struct task *tp; + register char ch, *ip; + char task_name[SZ_FNAME], proc_name[SZ_FNAME]; + int name_offset; + + /* Set global pointers to where we put task and proc name strings. + */ + sp = sbuf; + op = &obuf[SZ_OBUF/2]; + name_offset = 1; + + for (ntasks=0; ntasks < MAX_TASKS; ntasks++) { + /* Process "taskname" or "taskname=procname". There must be + * at least one task name in the declaration. + */ + if (get_task (task_name, proc_name, SZ_FNAME) == ERR) + return (ERR); + + /* Set up the task declaration structure, and copy name strings + * into the string buffers. + */ + tp = &task_list[ntasks]; + tp->task_name = sp; + tp->proc_name = op; + tp->name_offset = name_offset; + name_offset += strlen (task_name) + 1; + + for (ip=task_name; (*sp++ = *ip++) != EOS; ) + if (sp >= &sbuf[SZ_SBUF]) + goto err; + for (ip=proc_name; (*op++ = *ip++) != EOS; ) + if (op >= &obuf[SZ_OBUF]) + goto err; + + /* If the next character is a comma, skip it and a newline if + * one follows and continue processing. If the next character is + * a newline, we are done. Any other character is an error. + * Note that nextch skips whitespace and comments. + */ + ch = nextch(); + if (ch == ',') { + if ((ch = nextch()) != '\n') + unput (ch); + } else if (ch == '\n') { + linenum[istkptr]++; + ntasks++; /* end of task statement */ + break; + } else + return (ERR); + } + + if (ntasks >= MAX_TASKS) { +err: error (XPP_COMPERR, "too many tasks in task statement"); + return (ERR); + } + + /* Set up the task name dictionary string so that it gets output + * as a data statement when the runtask procedure is output. + */ + string_list[0].str_name = "dict"; + string_list[0].str_text = sbuf; + string_list[0].str_length = (sp - sbuf); + nstrings = 1; + + /* Leave the output buffer pointer pointing to the first half of + * the buffer. + */ + op = obuf; + return (OK); +} + + +/* GET_TASK -- Process a single task declaration of the form "taskname" or + * "taskname = procname". + */ +get_task (task_name, proc_name, maxch) +char *task_name; +char *proc_name; +int maxch; +{ + register char ch; + + /* Get task name. + */ + if (get_name (task_name, maxch) == ERR) + return (ERR); + + /* Get proc name if given, otherwise the procedure name is assumed + * to be the same as the task name. + */ + if ((ch = nextch()) == '=') { + if (get_name (proc_name, maxch) == ERR) + return (ERR); + } else { + unput (ch); + strncpy (proc_name, task_name, maxch); + } + + return (XOK); +} + + +/* GET_NAME -- Extract identifier from input, placing in the output string. + * ERR is returned if the output string overflows, or if the token is not + * a legal identifier. + */ +get_name (outstr, maxch) +char *outstr; +int maxch; +{ + register char ch, *op; + register int nchars; + + unput ((ch = nextch())); /* skip leading whitespace */ + + for (nchars=0, op=outstr; nchars < maxch; nchars++) { + ch = input(); + if (isalpha(ch)) { + if (isupper(ch)) + *op++ = tolower(ch); + else + *op++ = ch; + } else if ((isdigit(ch) && nchars > 0) || ch == '_' || ch == '$') { + *op++ = ch; + } else { + *op++ = EOS; + unput (ch); + return (nchars > 0 ? XOK : ERR); + } + } + + return (ERR); +} + + +/* NEXTCH -- Get next nonwhite character from the input stream. Ignore + * comments. Newline is not considered whitespace. + */ +nextch() +{ + register char ch; + + while ((ch = input()) != EOF) { + if (ch == '#') { /* discard comment */ + while ((ch = input()) != '\n') + ; + return (ch); + } else if (ch != ' ' && ch != '\t') + return (ch); + } + return (EOF); +} + + +/* PUT_DICTIONARY -- We are called when the keyword TN$DECL is encountered, + * i.e., while processing "sysruk.x". This should only happen after the + * task statement has been successfully processed. Our function is to replace + * the TN$DECL macro by the declarations for the DP and DICT structures. + * DP is an integer array giving the offsets of the task name strings in DICT, + * the dictionary string buffer. + */ +#define NDP_PERLINE 8 /* num DP data elements per line */ + +put_dictionary() +{ + register struct task *tp; + char buf[SZ_LINE]; + int i, j, offset; + + /* Discard anything found on line after the TN$DECL, which is only + * recognized as the first token on the line. + */ + while (input() != '\n') + ; + unput ('\n'); + + /* Output the data statements required to initialize the DP array. + * These statements are spooled into the output buffer and not output + * until all declarations have been processed, since the Fortran std + * requires that data statements follow declarations. + */ + pushcontext (DATASTMT); + tp = task_list; + + for (j=0; j <= ntasks; j += NDP_PERLINE) { + if (!strloopdecl++) { + pushcontext (DECL); + sprintf (buf, "%s\tiyy\n", type_decl[TY_INT]); + outstr (buf); + popcontext(); + } + + sprintf (buf, "data\t(dp(iyy),iyy=%2d,%2d)\t/", + j+1, min (j+NDP_PERLINE, ntasks+1)); + outstr (buf); + + for (i=j; i < j+NDP_PERLINE && i <= ntasks; i++) { + offset = (tp++)->name_offset; + if (i >= ntasks) + sprintf (buf, "%2d/\n", XEOS); + else if (i == j + NDP_PERLINE - 1) + sprintf (buf, "%4d/\n", offset==EOS ? XEOS: offset); + else + sprintf (buf, "%4d,", offset==EOS ? XEOS: offset); + outstr (buf); + } + } + + popcontext(); + + /* Output type declarations for the DP and DICT arrays. The string + * descriptor for string 0 (dict) was prepared when the TASK statement + * was processed. + */ + sprintf (buf, "%s\tdp(%d)\n", type_decl[XTY_INT], ntasks + 1); + outstr (buf); + sprintf (buf, "%s\tdict(%d)\n", type_decl[XTY_CHAR], + string_list[0].str_length); + outstr (buf); +} + + +/* PUT_INTERPRETER -- Output the statements necessary to scan the dictionary + * for a task and call the associated procedure. We are called when the + * keyword TN$INTERP is encountered in the input stream. + */ +put_interpreter() +{ + char lbuf[SZ_LINE]; + int i; + + while (input() != '\n') /* discard rest of line */ + ; + unput ('\n'); + + for (i=0; i < ntasks; i++) { + sprintf (lbuf, "\tif (streq (task, dict(dp(%d)))) {\n", i+1); + outstr (lbuf); + sprintf (lbuf, "\t call %s\n", task_list[i].proc_name); + outstr (lbuf); + sprintf (lbuf, "\t return (OK)\n"); + outstr (lbuf); + sprintf (lbuf, "\t}\n"); + outstr (lbuf); + } +} + + +/* OUTSTR -- Output a string. Depending on the context, the string will + * either go direct to the output file, or will be buffered in the output + * buffer. + */ +outstr (string) +char *string; +{ + register char *ip; + + + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + for (ip=string; (*op++ = *ip++) != EOS; ) + ; + if (--op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + for (ip=string; (*dp++ = *ip++) != EOS; ) + ; + if (--dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + fputs (string, yyout); + } +} + + +/* BEGIN_CODE -- Code that gets executed when the keyword BEGIN is encountered, + * i.e., when we begin processing the executable part of a procedure + * declaration. + */ +begin_code() +{ + char text[1024]; + + /* If we are already processing the body of a procedure, we probably + * have a missing END. + */ + if (context & BODY) + xpp_warn ("Unmatched BEGIN statement"); + + /* Set context flag noting that we are processing the body of a + * procedure. Output the BEGIN statement, for the benefit of the + * second pass (RPP), which needs to know where the procedure body + * begins. + */ + setcontext (BODY); + d_runtime (text); outstr (text); + outstr ("begin\n"); + linenum[istkptr]++; + + /* Initialization. */ + nbrace = 0; + nswitch = 0; + str_idnum = 1; + errhand = NO; + errchk = NO; +} + + +/* END_CODE -- Code that gets executed when the keyword END is encountered + * in the input. If error checking is used in the procedure, we must declare + * the boolean function XERPOP. If any switches are employed, we must declare + * the switch variables. Next we format and output data statements for any + * strings encountered while processing the procedure body. If the procedure + * being processed is sys_runtask, the task name dictionary string is also + * output. Finally, we output the spooled procedure body, followed by and END + * statement for the benefit of the second pass. + */ +end_code() +{ + int i; + + /* If the END keyword is encountered outside of the body of a + * procedure, we leave it alone. + */ + if (!(context & BODY)) { + outstr (yytext); + return; + } + + /* Output argument and local variable declarations (see decl.c). + * Note d_enter may have been called during processing of the body + * of a procedure to make entries in the symbol table for intrinsic + * functions, switch variables, etc. (this is not currently done). + */ + d_codegen (yyout); + + setcontext (GLOBAL); + + /* Output declarations for error checking and switches. All variables + * and functions must be declared. + */ + if (errhand) + fprintf (yyout, "x$bool xerpop\n"); + if (errchk) + fprintf (yyout, "errchk error, erract\n"); + errhand = NO; + errchk = NO; + + if (nswitch) { /* declare switch variables */ + fprintf (yyout, "%s\t", type_decl[XTY_INT]); + for (i=1; i < nswitch; i++) + fprintf (yyout, "SW%04d,", i); + fprintf (yyout, "SW%04d\n", i); + } + + /* Output any miscellaneous declarations. These include ERRCHK and + * COMMON declarations - anything not a std type declaration or a + * data statement declaration. + */ + *dp++ = EOS; + fputs (dbuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_DBUF; ) dbuf[i++] = '\0'; } + dp = dbuf; + + /* Output the SAVE statement, which must come after all declarations + * and before any DATA statements. + */ + fputs ("save\n", yyout); + + /* Output data statements to initialize character strings, followed + * by any runtime procedure entry initialization statments, followed + * by the spooled text in the output buffer, followed by the END. + * Clear the string and output buffers. Any user data statements + * will already have been moved into the output buffer, and they + * will come out at the end of the declarations section regardless + * of where they were given in the declarations section. Data stmts + * are not permitted in the procedure body. + */ + init_strings(); + *op++ = EOS; + fputs (obuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_OBUF; ) obuf[i++] = '\0'; } + fputs ("end\n", yyout); fflush (yyout); + + op = obuf; + *op = EOS; + sp = sbuf; + + if (nbrace != 0) { + error (XPP_SYNTAX, "Unmatched brace"); + nbrace = 0; + } +} + + +#define BIG_STRING 9 +#define NPERLINE 8 + +/* INIT_STRINGS -- Output data statements to initialize all strings in a + * procedure ("string" declarations, inline strings, and the runtask + * dictionary). Strings are implemented as integer arrays, using the + * smallest integer datatype provided by the host Fortran compiler, usually + * INTEGER*2 (XTY_CHAR). + */ +init_strings() +{ + register int str; + + if (nstrings) + for (str=0; str < nstrings && !strloopdecl; str++) + if (string_list[str].str_length >= BIG_STRING) { + fprintf (yyout, "%s\tiyy\n", type_decl[XTY_INT]); + strloopdecl++; + } + + for (str=0; str < nstrings; str++) + write_string_data_statement (&string_list[str]); + + sp = sbuf; /* clear string buffer */ + nstrings = 0; + strloopdecl = 0; +} + + +/* WRITE_STRING_DATA_STATEMENT -- Output data statement to initialize a single + * string. If short string, output a simple whole-array data statement + * that fits all on one line. Large strings are initialized with multiple + * data statements, each of which initializes a section of the string + * using a dummy subscript. This is thought to be more portable than + * a single large data statement with continuation, because the number of + * continuation cards permitted in a data statement depends on the compiler. + * The loop variable in an implied do loop in a data statement must be declared + * on some compilers (crazy but true). Determine if we will be generating any + * implied dos and declare the variable if so. + */ +write_string_data_statement (s) +struct string *s; +{ + register int i, len; + register char *ip; + char ch, *name; + int j; + + name = s->str_name; + ip = s->str_text; + len = s->str_length; + + if (len < BIG_STRING) { + fprintf (yyout, "data\t%s\t/", name); + for (i=0; i < len-1; i++) { + if ((ch = *ip++) == EOS) + fprintf (yyout, "%3d,", XEOS); + else + fprintf (yyout, "%3d,", ch); + } + fprintf (yyout, "%2d/\n", XEOS); + + } else { + for (j = 0; j < len; j += NPERLINE) { + fprintf (yyout, "data\t(%s(iyy),iyy=%2d,%2d)\t/", + name, j+1, min(j+NPERLINE, len)); + for (i=j; i < j+NPERLINE; i++) { + if (i >= len-1) { + fprintf (yyout, "%2d/\n", XEOS); + return; + } else if (i == j+NPERLINE-1) { + fprintf (yyout, "%3d/\n", ip[i]==EOS ? XEOS: ip[i]); + } else + fprintf (yyout, "%3d,", ip[i]==EOS ? XEOS: ip[i]); + } + } + } +} + + +/* DO_STRING -- Process a STRING declaration or inline string. Add a new + * string descriptor to the string list, copy text of string into sbuf, + * save name of string array in sbuf. If inline string, manufacture the + * name of the string array. + */ +do_string (delim, strtype) +char delim; /* char which delimits string */ +int strtype; /* string type */ +{ + register char ch, *ip; + register struct string *s; + int readstr = 1; + char *str_uniqid(); + + /* If we run out of space for string storage, print error message, + * dump string decls out early, clear buffer and continue processing. + */ + if (nstrings >= MAX_STRINGS) { + error (XPP_COMPERR, "Too many strings in procedure"); + init_strings(); + } + + s = &string_list[nstrings]; + + switch (strtype) { + + case STR_INLINE: + case STR_DEFINE: + /* Inline strings are implemented as Fortran arrays; generate a + * dummy name for the array and set up the descriptor. + * Defined strings are inline strings, but the name of the text of + * the string is already in yytext when we are called. + */ + s->str_name = sp; + for (ip = str_uniqid(); (*sp++ = *ip++) != EOS; ) + ; + sbuf_check(); + break; + + case STR_DECL: + /* String declaration. Read in name of string, used as name of + * Fortran array. + */ + ch = nextch(); /* skip whitespace */ + if (!isalpha (ch)) + goto sterr; + s->str_name = sp; + *sp++ = ch; + + /* Get rest of string name identifier. */ + while ((ch = input()) != EOF) { + if (isalnum(ch) || ch == '_') { + *sp++ = ch; + sbuf_check(); + } else if (ch == '\n') { +sterr: error (XPP_SYNTAX, "String declaration syntax"); + while (input() != '\n') + ; + unput ('\n'); + return; + } else { + *sp++ = EOS; + break; + } + } + + /* Advance to the ' or " string delimiter, in preparation for + * processing the string itself. If syntax error occurs, skip + * to newline to avoid spurious error messages. If the string + * is not quoted the string value field is taken to be the name + * of a string DEFINE. + */ + delim = nextch(); + + if (!(delim == '"' || delim == '\'')) { + register char *ip, *op; + int ch; + char *str_fetch(); + + /* Fetch name of defined macro into yytext. + */ + op = yytext; + *op++ = delim; + while ((ch = input()) != EOF) + if (isalnum(ch) || ch == '_') + *op++ = ch; + else + break; + unput (ch); + *op = EOS; + + /* Fetch body of string into yytext. + */ + if ((ip = str_fetch (yytext)) != NULL) { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + readstr = 0; + } else { + error (XPP_SYNTAX, + "Undefined macro referenced in string declaration"); + } + } + + break; + } + + /* Get the text of the string. Process escape sequences. String may + * not span multiple lines. In the case of a defined string, the text + * of the string will already be in yytext. + */ + s->str_text = sp; + if (readstr && strtype != STR_DEFINE) + traverse (delim); /* process string into yytext */ + strcpy (sp, yytext); + sp += yyleng + 1; + s->str_length = yyleng + 1; + sbuf_check(); + + /* Output array declaration for string. We want the declaration to + * go into the miscellaneous declarations buffer, so toggle the + * the context to DECL before calling OUTSTR. + */ + { + char lbuf[SZ_LINE]; + + pushcontext (DECL); + sprintf (lbuf, "%s\t%s(%d)\n", type_decl[XTY_CHAR], s->str_name, + s->str_length); + outstr (lbuf); + popcontext(); + } + + /* If inline string, replace the quoted string by the name of the + * string variable. This text goes into the output buffer, rather + * than directly to the output file as is the case with the declaration + * above. + */ + if (strtype == STR_INLINE || strtype == STR_DEFINE) + outstr (s->str_name); + + if (++nstrings >= MAX_STRINGS) + error (XPP_COMPERR, "Too many strings in procedure"); +} + + +/* DO_HOLLERITH -- Process and output a Fortran string. If the output + * compiler is Fortran 77, we output a quoted string; otherwise we output + * a hollerith string. Fortran (packed) strings appear in the SPP source + * as in the statement 'call_f77_sub (arg, *"any string", arg)'. Escape + * sequences are not recognized. + */ +do_hollerith() +{ + register char *op; + char strbuf[SZ_LINE], outbuf[SZ_LINE]; + int len; + + /* Read the string into strbuf. */ + for (op=strbuf, len=0; (*op = input()) != '"'; op++, len++) + if (*op == '\n' || *op == EOF) + break; + if (*op == '\n') + error (XPP_COMPERR, "Packed string not delimited"); + else + *op = EOS; /* delete delimiter */ + +#ifdef F77 + sprintf (outbuf, "\'%s\'", strbuf); +#else + sprintf (outbuf, "%dH%s", i, strbuf); +#endif + + outstr (outbuf); +} + + +/* SBUF_CHECK -- Check to see that the string buffer has not overflowed. + * It is a fatal error if it does. + */ +sbuf_check() +{ + if (sp >= &sbuf[SZ_SBUF]) { + error (XPP_COMPERR, "String buffer overflow"); + _exit (1); + } +} + + +/* STR_UNIQID -- Generate a unit identifier name for an inline string. + */ +char * +str_uniqid() +{ + static char id[] = "ST0000"; + + sprintf (&id[2], "%04d", str_idnum++); + return (id); +} + + +/* TRAVERSE -- Called by the lexical analyzer when a quoted string has + * been recognized. Characters are input and deposited in yytext (the + * lexical analyzer token buffer) until the trailing quote is seen. + * Strings may not span lines unless the newline is delimited. The + * recognized escape sequences are converted upon input; all others are + * left alone, presumably to later be converted by other code. + * Quotes may be included in the string by escaping them, or by means of + * the double quote convention. + */ +traverse (delim) +char delim; +{ + register char *op, *cp, ch; + char *index(); + + + for (op=yytext; (*op = input()) != EOF; op++) { + if (*op == delim) { + if ((*op = input()) == EOF) + break; + if (*op == delim) + continue; /* double quote convention; keep one */ + else { + unput (*op); + break; /* normal exit */ + } + + } else if (*op == '\n') { /* error recovery exit */ + unput ('\n'); + xpp_warn ("Newline while processing string"); + break; + + } else if (*op == '\\') { + if ((*op = input()) == EOF) { + break; + } else if (*op == '\n') { + --op; /* explicit continuation */ + continue; + } else if ((cp = index (esc_ch, *op)) != NULL) { + *op = esc_val[cp-esc_ch]; + } else if (isdigit (*op)) { /* '\0DD' octal constant */ + *op -= '0'; + while (isdigit (ch = input())) + *op = (*op * 8) + (ch - '0'); + unput (ch); + } else { + ch = *op; /* unknown escape sequence, */ + *op++ = '\\'; /* leave it alone. */ + *op = ch; + } + } + } + + *op = EOS; + yyleng = (op - yytext); +} + + +/* ERROR -- Output an error message and set exit flag so that no linking occurs. + * Do not abort compiler, however, because it is better to keep going and + * find all the errors in a single compilation. + */ +error (errcode, errmsg) +int errcode; +char *errmsg; +{ + fprintf (stderr, "Error on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], errmsg); + fflush (stderr); + errflag |= errcode; +} + + +/* WARN -- Output a warning message. Do not set exit flag since this is only + * a warning message; linking should occur if there are not any more serious + * errors. + */ +xpp_warn (warnmsg) +char *warnmsg; +{ + fprintf (stderr, "Warning on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], warnmsg); + fflush (stderr); +} + + +/* ACCUM -- Code for conversion of numeric constants to decimal. Convert a + * character string to a binary integer constant, doing the conversion in the + * indicated base. + */ +long +accum (base, strp) +int base; +char **strp; +{ + register char *ip; + long sum; + char digit; + + sum = 0; + ip = *strp; + + switch (base) { + case OCTAL: + case DECIMAL: + for (digit = *ip++; isdigit (digit); digit = *ip++) + sum = sum * base + (digit - '0'); + *strp = ip - 1; + break; + case HEX: + while ((digit = *ip++) != EOF) { + if (isdigit (digit)) + sum = sum * base + (digit - '0'); + else if (digit >= 'a' && digit <= 'f') + sum = sum * base + (digit - 'a' + 10); + else if (digit >= 'A' && digit <= 'F') + sum = sum * base + (digit - 'A' + 10); + else { + *strp = ip; + break; + } + } + break; + default: + error (XPP_COMPERR, "Accum: unknown numeric base"); + return (ERR); + } + + return (sum); +} + + +/* CHARCON -- Convert a character constant to a binary integer value. + * The regular escape sequences are recognized; numeric values are assumed + * to be octal. + */ +charcon (string) +char *string; +{ + register char *ip, ch; + char *cc, *index(); + char *nump; + + ip = string + 1; /* skip leading apostrophe */ + ch = *ip++; + + /* Handle '\c' and '\0dd' notations. + */ + if (ch == '\\') { + if ((cc = index (esc_ch, *ip)) != NULL) { + return (esc_val[cc-esc_ch]); + } else if (isdigit (*ip)) { + nump = ip; + return (accum (OCTAL, &nump)); + } else + return (ch); + } else { + /* Regular characters, i.e., 'c'; just return ASCII value of char. + */ + return (ch); + } +} + + +/* INT_CONSTANT -- Called to decode an integer constant, i.e., a decimal, hex, + * octal, or sexagesimal number, or a character constant. The numeric string + * is converted in the indicated base and replaced by its decimal value. + */ +int_constant (string, base) +char *string; +int base; +{ + char decimal_constant[SZ_NUMBUF], *p; + long accum(), value; + int i; + + p = string; + i = strlen (string); + + switch (base) { + case DECIMAL: + value = accum (10, &p); + break; + case SEXAG: + value = accum (10, &p); + break; + case OCTAL: + value = accum (8, &p); + break; + case HEX: + value = accum (16, &p); + break; + + case CHARCON: + while ((p[i] = input()) != EOF) { + if (p[i] == '\n') { + error (XPP_SYNTAX, "Undelimited character constant"); + return; + } else if (p[i] == '\\') { + p[++i] = input(); + i++; + continue; + } else if (p[i] == '\'') + break; + i += 1; + } + value = charcon (p); + break; + + default: + error (XPP_COMPERR, "Unknown numeric base for integer conversion"); + value = ERR; + } + + /* Output the decimal value of the integer constant. We are simply + * replacing the SPP constant by a decimal constant. + */ + sprintf (decimal_constant, "%ld", value); + outstr (decimal_constant); +} + + +/* HMS -- Convert number in HMS format into a decimal constant, and output + * in that form. Successive : separated fields are scaled to 1/60 th of + * the preceeding field. Thus "12:30" is equivalent to "12.5". Some care + * is taken to preserve the precision of the number. + */ +char * +hms (number) +char *number; +{ + char cvalue[SZ_NUMBUF], *ip; + int bvalue, ndigits; + long scale = 10000000; + long units = 1; + long value = 0; + + for (ndigits=0, ip=number; *ip; ip++) + if (isdigit (*ip)) + ndigits++; + + /* Get the unscaled base value part of the number. */ + ip = number; + bvalue = accum (DECIMAL, &ip); + + /* Convert any sexagesimal encoded fields. */ + while (*ip == ':') { + ip++; + units *= 60; + value += (accum (DECIMAL, &ip) * scale / units); + } + + /* Convert the fractional part of the number, if any. + */ + if (*ip++ == '.') + while (isdigit (*ip)) { + units *= 10; + value += (*ip++ - '0') * scale / units; + } + + /* Format the output number. */ + if (ndigits > MIN_REALPREC) + sprintf (cvalue, "%d.%dD0", bvalue, value); + else + sprintf (cvalue, "%d.%d", bvalue, value); + cvalue[ndigits+1] = '\0'; + + /* Print the translated number. */ + outstr (cvalue); +} + + +/* + * Revision history (when i remembered) -- + * + * 14-Dec-82: Changed hms conversion, to produce degrees or hours, + * rather than seconds (lex pattern, add hms, delete ':' + * action from accum). + * + * 10-Mar-83 Broke C code and Lex code into separate files. + * Added support for error handling. + * Added additional type coercion functions. + * + * 20-Mar-83 Modified processing of TASK stmt to use file inclusion + * to read the RUNTASK file, making it possible to maintain + * the IRAF main as a .x file, rather than as a .r file. + * + * Dec-83 Fixed bug in processing of TASK stmt which prevented + * compilation of processes with many tasks. Added many + * comments and cleaned up the code a bit. + */ |