/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. */ #include #include #include "xpp.h" #define import_spp #include /* * 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 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. */