/* @(#)forif.c 17.1.1.1 (ESO-DMD) 01/25/02 17:57:06 */ /*=========================================================================== Copyright (C) 1995 European Southern Observatory (ESO) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, MA 02139, USA. Correspondence concerning ESO-MIDAS should be addressed as follows: Internet e-mail: midas@eso.org Postal address: European Southern Observatory Data Management Division Karl-Schwarzschild-Strasse 2 D 85748 Garching bei Muenchen GERMANY ===========================================================================*/ /*++++++++++++++ .TYPE Module .NAME forif.c .LANGUAGE C .AUTHOR Francois Ochsenbein [ESO-IPG] .CATEGORY C Compiler .PURPOSE .ENVIRONMENT Machines with 4-byte addresses. .COMMENTS This module parses the ".cf" file to create a .c file. The -f parameter specifies how to convewrt routine names. It is made of up to 3 characters as [_]C[_] where the optional _ mean "add underscore as prefix/sufix" and C is L for Lowercase, U for Uppercase, .(dot) for no transformation The -v parameter (optional) specifies how to create the common variable "vmr" name. It uses the same syntax as -f. names. It works .VERSION 010710 last modif ---------------------------------------------------*/ #include /* ASCII classification */ #include /* General utility macros */ #include #include char *osmmget(); #if VMS static char *FORname = "U"; /* Convert to UPPER case, */ #else static char *FORname = "l_"; /* Convert to lower case, append _ */ #endif static char *VMRname; static int IN = 0; /* Input File */ static int OUT = 1; /* Output File */ #define OK 1 #define NOK 0 #define error0(t) error(NULL_PTR(char),NULL_PTR(char)) #define error1(t) error(t,NULL_PTR(char)) #define emits(s) emit(s, strlen(s)) #define emitq() emit(printed, pmatched - printed), printed = pmatched #ifdef isid #undef isid #define isid(c) (isalnum(c) || (c == '_') || (c == '$')|| (c == '.')) #endif #define SYMSIZE 44 /* Maximum length of a symbol */ #define _BYTE_ 0 #define _SHORT_ 1 #define _INT_ 2 #define _LONG_ 3 #define _FLOAT_ 6 #define _DOUBLE_ 7 #define _CHARACTER_ 8 #define _FINT2C_ 9 #define _FLONG2C_ 10 /* Definition of Token Classes */ #define NONE 0 #define DONE 14 #define DECLARE 15 #define SUBROUTINE 16 #define IDENTIFIER 17 #define ARGUMENT 18 /* Found in SUBROUTINE */ #define INUM 19 /* Integer constant */ #define FNUM 20 /* Floating constant */ #define SNUM 21 /* String constant */ #define RETURN 22 #define FOR 23 #define ROUTINE 24 typedef struct { /* Symbol element */ char *name; char token; /* Token class */ char pno; /* Parameter number (1) */ char sno; /* Parameter number (0) */ char dty; /* Data type */ } SYMBOL; /* Declare variables required for the lexical analysis */ static char lexbuf[SYMSIZE+3]; static long value = 0; /* static double fvalue; */ /* CG. Not used. LintPlus */ static char *avalue; /* static char *token_name = (char *)0; */ /* CG. Not used. LintPlus */ static SYMBOL *found_symbol; static int lookahead = 0; static int argno = 0; /* Number of Arguments */ static int found_errors; /* Collects the errors */ static int lineno = 1; static int brace_level = 0; static char execute_mark; /* Flag 1 = va_dcl to write / 2 = FORmark \ 4 = ftoc_free */ static SYMBOL symbol_table[128] ; static int symbols = 0; static char *psource, *printed, *pmatched; #define issign(c) ((c == '+') || (c == '-')) /* Static recursive functions are declared */ static int expr0(), expr(), stmt(); /*===========================================================================*/ static void synopsis() /*+++++ .PURPOSE Just display some help .RETURNS ?? --------------*/ { static char *text[] = { "Usage: forif [-fT] [-vT] [-sN] [input_file] [output_file]", " -f transform names of routines", " -v transform name of variable vmr", " T specifies how to transform names (default ._)", " N provides size of file" }; char **p; int i; for (p = text, i = ITEMS(text); --i >= 0; p++) osdwrite(2, *p, strlen(*p)), osdwrite(2, "\r\n", 2); } /*========================================================================== * String Utilities (extracted from str1.c) *===========================================================================*/ static int strcopy(dest, source) /*+++++++ .PURPOSE Copy strings, taking care of possible overlays. .RETURNS Length of destination. ---------*/ char *dest; /* OUT: destination string */ char *source; /* IN: source string */ { register int len; if (source) len = strlen(source), oscopy(dest, source, len+1); else *dest = '\0', len = 0; return(len); } static char *strsave(s) /*+++++ .PURPOSE Save a string .RETURNS Address of saved string ------*/ char *s; /* IN: String to save */ { int len; char *new; len = 1 + strlen(s); new = osmmget(len); oscopy (new, s, len); return(new); } #define strfree(s) osmmfree(s) static int strlower ( str ) /*+++++++++ .PURPOSE Converts (in place) a string to lower case .RETURNS Length of string --------*/ char *str; /* MOD: starting address */ { register char *p; for (p = str; *p; p++) *p = tolower(*p); return(p-str); } static int strupper ( str ) /*+++++++++ .PURPOSE Converts (in place) a string to upper case .RETURNS Length of string --------*/ char *str; /* MOD: starting address */ { register char *p; for (p = str; *p; p++) *p = toupper(*p); return(p-str); } #define strdiff(s1,s2) strcmp(s1,s2) /*===========================================================================*/ static int getx() /*+++++ .PURPOSE Get next char .RETURNS Next char --------------*/ { int c; c = *(psource++); if (c == '\n') lineno += 1; return(c); } static int ungetx() /*+++++ .PURPOSE Get next char .RETURNS Deleted char --------------*/ { int c; c = *(--psource); if (c == '\n') lineno -= 1; return(c); } /*===========================================================================*/ static int error(txt, str) /*+++++ .PURPOSE Error report .RETURNS Error count .REMARKS Error always logged on two lines --------------*/ char *txt; /* IN: Text of error text */ char *str; /* IN: Continuation of error */ { static char errmsg[] = "Error in line 9999: "; int no, i; oscfill(&errmsg[sizeof(errmsg)-7], 4, ' '); for (i = sizeof(errmsg)-3, no = lineno; no; no /= 10) errmsg[--i] = '0' + no%10; osdwrite(2, errmsg, sizeof(errmsg)-1); if (txt) osdwrite(2, txt, strlen(txt)); if (str) osdwrite(2, str, strlen(str)); osdwrite(2, "\r\n", 2); return(++found_errors); } /*===========================================================================*/ static SYMBOL *lookup(s) /*+++++ .PURPOSE Lookup .RETURNS Pointer to relevant entry / NULL if fail .REMARKS Table is scanned from beginning --------------*/ char *s; /* IN: String to locate */ { SYMBOL *p; int i; for (i = symbols, p = symbol_table; --i >= 0; p++) if (strdiff(s, p->name) == 0) return(p); return((SYMBOL *)0); } static SYMBOL *insert(s, tok, pno, dty) /*+++++ .PURPOSE Insert symbol .RETURNS Allocated symbol address .REMARKS Don't check if name already exists. --------------*/ char *s; /* IN: Symbol Name to Insert, or NULL */ int tok; /* IN: Token Class */ int pno; /* IN: Parameter number */ int dty; /* IN: Data type */ { SYMBOL *p; if (symbols < ITEMS(symbol_table)) { p = &symbol_table[symbols++]; p->name = strsave(s); p->token= tok; p->pno = pno; p->dty = dty; p->sno = 0; } else p = (SYMBOL *)0; return(p); } static SYMBOL *pops() /*+++++ .PURPOSE Remove latest entered symbol from Local Table .RETURNS Address of popped symbol --------------*/ { SYMBOL *ps; if (symbols > 0) { ps = &symbol_table[--symbols]; strfree(ps->name); } else ps = (SYMBOL *)0; return(ps); } /*===========================================================================*/ static int emit(t, len) /*+++++ .PURPOSE Write to Output .RETURNS len --------*/ char *t; /* IN: Token class */ int len; /* IN: How many bytes */ { osdwrite (OUT, t, len); return(len); } /*===========================================================================*/ static int match_line() /*+++++ .PURPOSE Match the line (preprocessor statements) .RETURNS Number of matched lines .REMARKS Several lines if termination with \ -------*/ { int t, previous; int starting_line; starting_line = lineno; previous = 0; while (t = getx()) { if ((t == '\n') && (previous != '\\')) break; previous = t; } pmatched = psource; return (lineno - starting_line); } static int match_comment() /*+++++ .PURPOSE Match the end of a comment .RETURNS OK / NOK .REMARKS Don't forget to count the newlines... -------*/ { int t, stat; stat = OK; while (t = getx()) { if (t != '*') continue; t = getx(); /* Char following the * must be a / ... */ if (t == '/') break; if (t == EOS) break; ungetx(); } if (t == EOS) stat = NOK, error1("Non-terminated comment"); pmatched = psource; return(stat); } /*===========================================================================*/ static int match_num() /*+++++ .PURPOSE Match a number (double floating), also in hexa form (0x...) .RETURNS Type (int / float) as INUM / FNUM (number stored in local buffer) .REMARKS Number stored in value (integer) and fvalue (float). Not really useful here, but ... -------*/ { char x, t; int i, stat; double atof(); long atol(); char the_number[80]; value = i = 0, stat = INUM; while( (t = getx()) == '0'); /* Skip leading zeroes, not significant */ if (tolower(t) == 'x') { /* It's 0x hexa representation... */ for (t = getx(); isxdigit(t); t = getx()) { if (isdigit(t)) i = t - '0'; else i = toupper(t) - ('A' - 10); value = (value<<4) | i; } ungetx(); return(stat); } while(isdigit(t) && (i < sizeof(the_number)-3)) the_number[i++] = t, t = getx();/* Take digits before . */ if (t == '.') { /* Floating-point Number*/ stat = FNUM; the_number[i++] = t, t = getx(); while(isdigit(t) && (i < sizeof(the_number)-3)) the_number[i++] = t, t = getx(); /* decimals */ if (isalpha(t)) { /* Look for Exponent */ x = toupper(t); if ((x == 'E') || (x == 'D')) { the_number[i++] = 'e', t = getx(); if (issign(t)) the_number[i++] = t, t = getx(); while(isdigit(t) && (i < sizeof(the_number)-1)) the_number[i++] = t, t = getx(); } } } the_number[i] = EOS; /* Terminate the String */ ungetx(); if (stat == FNUM) /* fvalue = atof(the_number)*/ ; else value = atol(the_number); return(stat); } /*===========================================================================*/ static int match_char() /*+++++ .PURPOSE Match a character x or \x .RETURNS INUM .REMARKS Number stored in value -------*/ { int i; char t; value = 0; if ((t = getx()) == '\\') switch(t = getx()) { case 'n': value = '\n'; break; /* Newline */ case 'r': value = '\r'; break; /* */ case 't': value = '\t'; break; /* Horiz. Tab */ case 'b': value = '\b'; break; /* Backspace */ case 'f': value = '\f'; break; /* Form Feed */ default : value = t; break; case '0': case '1': case '2': case '3': /* Octal number */ for(i=3; (--i >= 0) && isdigit(t); t = getx()) value = value*8 + (t - '0'); if ((i < 0) || !isdigit(t)) ungetx(); break; } else value = (unsigned char)t; return(INUM); } /*===========================================================================*/ static int match_str() /*+++++ .PURPOSE Match a string. .RETURNS SNUM -------*/ { match_char(); for (; value; match_char()) if (value == '\"') break; if (value != '\"') error1("Non-terminated string constant"); return(SNUM); } /*===========================================================================*/ static int match_id() /*+++++ .PURPOSE Match an identifier. .RETURNS Token class as found in tables, or ID when new identifier .REMARKS found_symbol contains on return the found symbol. avalue contains on return the found name. -------*/ { int tc, b; SYMBOL *p; char t; t = getx(), b = 0, tc = IDENTIFIER; while ((isid(t)) && (b < SYMSIZE)) { lexbuf[b++] = t; t = getx(); } /* token_name = lexbuf; */ lexbuf[b] = EOS, ungetx(); if (b >= SYMSIZE) error("Too long symbol: ", lexbuf); if (p = lookup(lexbuf)) found_symbol = p, avalue = p->name, tc = p->token; else found_symbol = (SYMBOL *)0, avalue = lexbuf; return(tc); } /*===========================================================================*/ static int lexan() /*+++++ .PURPOSE Lexical Analyzer .RETURNS Token Symbol --------------*/ { int tc; char t; tc = DONE; while(lookahead != DONE) { switch(t = getx()) { case EOS: return(DONE); case '/': /* Check for Comments */ t = getx(); if (t == '*') { /* It's a comment */ match_comment(); continue; } ungetx(); t = '/'; break; case '\'': /* Character */ tc = match_char(); if (getx() != '\'') error1("Missing ' in Character"); return(tc); case '\"': /* String */ tc = match_str(); return(tc); } if(isspace(t)) continue; /* Includes \n */ if (isdigit(t) || (t == '.')) { /* Check for a Number */ ungetx(); tc = match_num(); break; } if (isid1(t)) { /* Check for Known Identifier */ ungetx(); tc = match_id(); break; } /* No token matched. Use just the next byte */ tc = t; break; } return(tc); } /*===========================================================================*/ static char *tr_sym(ps) /*+++++ .PURPOSE Transform symbol for Output .RETURNS Pointer to text .REMARKS --------------*/ SYMBOL *ps; /* IN: Symbol to edit */ { static char text[40]; char *p; int i; if ((ps->dty & 0xf) == _CHARACTER_) { sprintf(text, "%d,%d,%d", ps->pno, argno, ps->sno); } else { /* Write PARAM(pno, argno, sno, type *) */ switch(ps->dty & 0xf) { case _BYTE_ : p = "char "; break; case _SHORT_: p = "short "; break; case _LONG_: p = "long "; break; case _INT_: p = "int "; break; case _FLOAT_: p = "float "; break; case _DOUBLE_: p = "double "; break; case _FINT2C_: p = "fint2c "; break; case _FLONG2C_: p = "flong2c "; break; default: p = " "; break; } sprintf(text, "PARAM(%d,%d,%d,%s", ps->pno, argno, ps->sno, p); p = text + strlen(text); for (i = ps->dty; i >= 0x10; i -= 0x10) *(p++) = '*'; p[0] = ')'; p[1] = EOS; } return (text); } /*===========================================================================*/ static char *atok(t, islookahead) /*+++++ .PURPOSE Transform token to a comprehensive text .RETURNS Pointer to text .REMARKS --------------*/ int t; /* IN: token class */ int islookahead; /* IN: 1 if token has symbol in lexbuf */ { static char text[SYMSIZE+24]; char *p; p = NULL_PTR(char); if (isascii(t)) /* Single character */ islookahead = 0, text[0] = '`', text[1] = t, text[2] = '\'', text[3] = EOS; else switch(t) { case INUM: case FNUM: islookahead = 0, p = "Constant"; break; case SNUM: islookahead = 0, p = "stringConstant"; break; case IDENTIFIER: p = "Identifier"; break; case RETURN: islookahead = 0, p = "'return'"; break; case SUBROUTINE: islookahead = 0, p = "'SUBROUTINE'"; break; case FOR: islookahead = 0, p = "'for'"; break; case DECLARE: islookahead = 0, p = "Datatype keywd"; break; case ARGUMENT: islookahead = 0, p = "an Argument name"; break; case DONE: islookahead = 0, p = "end-of-source"; break; case ROUTINE: islookahead = 0, p = "'ROUTINE'"; break; default: p = "??"; } if (p) { p = text + strcopy(text, p); if (islookahead) *(p++) = ' ', *(p++) = '`', p += strcopy(p, lexbuf), *(p++) = '\'', *p = EOS; } return(text); } /*===========================================================================*/ static int match(t) /*+++++ .PURPOSE Check if next token matches specified type .RETURNS OK / NOK .REMARKS --------------*/ int t; /* IN: token class to match */ { char msg[2*SYMSIZE + 28], *p; int stat; stat = OK; pmatched = psource; if (lookahead != t) { stat = NOK, p = msg + strcopy(msg, "Got "); p += strcopy(p, atok(lookahead, 1)); p += strcopy(p, " when waiting for "); strcopy(p, atok(t, 0)); error1(msg); } lookahead = lexan(); return(stat); } static int match_until(t) /*+++++ .PURPOSE Scan text until token is found .RETURNS Last token --------------*/ int t; /* IN: Token to find */ { while (!match(t)) { lookahead = lexan(); if (lookahead == DONE) break; } return(lookahead); } /*===========================================================================*/ static void declare() /*+++++ .PURPOSE Match a declaration: keyword [*]name ; .RETURNS The array size .REMARKS Complete declaration added -------*/ { SYMBOL keyword; keyword = *found_symbol; match(DECLARE); while ((lookahead != ';') && (lookahead != DONE)) switch(lookahead) { case '*': keyword.dty += 0x10; match(lookahead); continue; case ARGUMENT: if (keyword.dty == _CHARACTER_) execute_mark |= 2; found_symbol->dty = keyword.dty; /* NO BREAK */ default: match(ARGUMENT); continue; } match_until(';'); } /*===========================================================================*/ static int emit0() /*+++++ .PURPOSE Emit the first statement as va_start and ftoc_mark .RETURNS 0 .REMARKS Must be done after declarations, before the first statement --------------*/ { emitq(); /* Write out pending text */ if (execute_mark & 1) emits(" va_start(Cargs); /"), emits("* */\n"); if (execute_mark & 2) emits(" FORmark = ftoc_mark(); /"), emits("* */\n"); execute_mark &= ~3; return(0); } /*===========================================================================*/ static int stmt() /*+++++ .PURPOSE Match a statement .RETURNS The last token encountered. .REMARKS --------------*/ { switch(lookahead) { case '{': /* Statement { ... } */ match(lookahead); brace_level++; while((lookahead != DONE) && (lookahead != '}')) stmt(); if (lookahead == '}') { brace_level--; if ((brace_level == 0) && (execute_mark & 4)) { emitq(); emits("\n ftoc_free(FORmark); /"); emits("* */"); execute_mark &= ~4; } } match('}'); break; case '#': /* PREProc. Stmt */ match_line(); lookahead = lexan(); break; case FOR: if ((execute_mark&3) && (lookahead != DECLARE)) emit0(); match(FOR); match('('); expr(); match(';'); expr(); match(';'); expr(); match(')'); stmt(); break; case ';': /* NULL Statement */ if ((execute_mark&3) && (lookahead != DECLARE)) emit0(); match(';'); break; default: if ((execute_mark&3) && (lookahead != DECLARE)) emit0(); expr(); if (lookahead == '{') stmt(); else match_until(';'); break; } return(lookahead); } /*===========================================================================*/ static int expr() /*+++++ .PURPOSE Parse a complete expression made of terms; COMMAS ARE ALLOWED. .RETURNS Last matched token .REMARKS Simply starts the opp from top priority level --------------*/ { expr0(); while (lookahead == ',') { match(','), expr0(); } return(lookahead); } /*===========================================================================*/ static int expr0() /*+++++ .PURPOSE Parse operation (no commas) .RETURNS OK / NOK (no expression found) .REMARKS --------------*/ { int stat; SYMBOL *ps; stat = OK; while (stat) switch (lookahead) { case '(': match('('), expr(), match(')'); break; case '[': match('['), expr(), match(']'); break; case RETURN: while (isspace(*pmatched)) pmatched++; emitq(); /* Write out pending text */ emits("ftoc_free(FORmark); /"); emits("* */"); execute_mark &= ~4; match(lookahead); break; case ARGUMENT: ps = found_symbol; emitq(); /* Write out pending text */ match(lookahead); printed = pmatched; emits(tr_sym(ps)); break; case INUM: case FNUM: case SNUM: case IDENTIFIER: case DECLARE: match(lookahead); break; case '=': /* Possibility of Initialisation... */ match(lookahead); if (lookahead == '{') match('{'), expr(), match('}'); break; case '+': case '-': case '/': case '*': case '%': case '&': case '|': case '^': case '<': case '>': case '!': case '?': case ':': match(lookahead); break; default: stat = NOK; } return(stat); } /*===========================================================================*/ static int fname (dest, source) /*+++++ .PURPOSE Transform Subroutine name .RETURNS Length of name .REMARKS Use VMRname form "vmr", FORname for the rest. --------------*/ char *dest; /* OUT: Transformed name */ char *source; /* IN: FORTRAN name */ { char *d, *o; d = dest; if (strdiff(source,"vmr") == 0) o = VMRname; else o = FORname; if (*o == '_') /* Prefix with _ */ *(d++) = '_', o++; d += strcopy (d, source); switch(*o) { case 'l': case 'L': strlower(dest); o++; break; case 'u': case 'U': strupper(dest); o++; break; case '.': o++; break; } if (*o == '_') /* Postifx with _ */ *(d++) = '_', *d = EOS; return (d - dest); } /*===========================================================================*/ static int init() /*+++++ .PURPOSE Initialize .RETURNS OK .REMARKS --------------*/ { static char symb[] = "SUBROUTINE\0for\0ROUTINE\0"; static char ass [] = { SUBROUTINE, FOR ,ROUTINE } ; static char dcl[] = "fint2c\0flong2c\0char\0short\0int\0long\0float\0double\0CHARACTER\0\ static\0extern\0register\0FUNCTION\0"; static char dty[] = { _FINT2C_, _FLONG2C_ , _BYTE_, _SHORT_, _INT_, _LONG_, _FLOAT_, _DOUBLE_, _CHARACTER_, 0, 0,0, 0}; static char DCL[] = "FINT2C\0FLONG2c\0BYTE\0SHORT\0INT\0LONG\0FLOAT\0DOUBLE\0"; char *p; char *ps; /* Remove stored symbols */ while (symbols) pops(); /* Insert permanent symbols */ for (p = symb, ps = ass; *p; ps++, p+= 1+strlen(p)) insert(p, *ps, 0, 0); for (p = dcl, ps = dty; *p; ps++, p+= 1+strlen(p)) insert(p, DECLARE, 0, *ps); for (p = DCL, ps = dty; *p; ps++, p+= 1+strlen(p)) insert(p, DECLARE, 0, *ps + 0x10); brace_level = 0; execute_mark = 0; return(OK); } /*===========================================================================*/ static int add_sno() /*+++++ .PURPOSE Complete argument parameters (add sno #) .RETURNS Number of arguments .REMARKS --------------*/ { SYMBOL *ps; int i, sno; for (ps = symbol_table, i = symbols, sno = 0; --i >= 0; ps++) { if (ps->token != ARGUMENT) continue; ps->sno = sno; if ((ps->dty & 0xf) == _CHARACTER_) sno++; } return (sno); } /*===========================================================================*/ static int routine() /*+++++ .PURPOSE Match a ROUTINE: ROUTINE name (arg_list) declarations { ... } .RETURNS The last token encountered. .REMARKS --------------*/ { char name[SYMSIZE+5]; /* Subroutine Name */ char *oname; /* Subroutine Original Name */ emitq(); /* Write out pending text */ init(); match(ROUTINE); while (isspace(*printed)) printed++; oname = strsave(avalue); fname(name, avalue); if (strdiff(name, oname)) { /* Generate #define code to redefine Name */ emits("\n\n#define "); emits(oname); emits("\t"); emits(name); emits("\n"); } /* emitq();*/ /* Write out pending text */ strfree(oname); return(lookahead); } static int subroutine() /*+++++ .PURPOSE Match a SUBROUTINE: SUBROUTINE name (arg_list) declarations { ... } .RETURNS The last token encountered. .REMARKS --------------*/ { char name[SYMSIZE+5]; /* Subroutine Name */ char *oname; /* Subroutine Original Name */ emitq(); /* Write out pending text */ init(); match(SUBROUTINE); emits("\n\n#if 0 /"); emits("* ==== Original Code ==== */\n"); while (isspace(*printed)) printed++; match(IDENTIFIER); /* Subroutine Name */ oname = strsave(avalue); fname(name, avalue); match('('); argno = 0; while (lookahead == IDENTIFIER) { argno++; insert (avalue, ARGUMENT, argno, 0); lookahead = lexan(); if (lookahead == ',') match(lookahead); else break; } match(')'); while ((lookahead != '{') && (lookahead != DONE)) declare(); emitq(); /* Write out pending text */ emits("\n#else /"); emits("* ==== Generated Code === */\n"); if (strdiff(name, oname)) { /* Generate #define code to redefine Name */ emits("#define "); emits(oname); emits("\t"); emits(name); emits("\n"); } emits(oname); /* Subroutine Name */ emits("(va_alist) va_dcl \n{ va_list Cargs;"); emits("\n#endif /"); emits("* ======================= */\n"); /* Add into list of Arguments the sno number */ if (add_sno()) { /* There are string parameters */ emits(" int FORmark; /"); emits("* */\n"); insert("return", RETURN, 0, 0); execute_mark |= 4; /* Must use ftoc_free */ } if (lookahead == '{') { execute_mark |= 1; printed = psource; stmt(); emitq(); /* Write out pending text */ } strfree(oname); return(lookahead); } /*===========================================================================*/ static void parse(text) /*+++++ .PURPOSE Parse the source text .RETURNS ?? --------------*/ char *text; /* IN: Text to compile */ { init(); /* Initialize compilation */ psource = pmatched = printed = text; found_errors = 0, lineno = 1; lookahead = lexan(); while (lookahead != DONE) { if (lookahead == SUBROUTINE) subroutine(); else if (lookahead == ROUTINE) routine(); else stmt(); } /* Write rest of File */ emit(printed, --psource - printed); } /*=========================================================================== * Main Routine *===========================================================================*/ main(argc, argv) /*++++++++++++++++ .PURPOSE Convert stdin -> stdout .RETURNS To OS .REMARKS Parameters in out -f(ftocNAme) -v(ftocNAme) -s(size) -----------------*/ int argc; char **argv; { char *text, *p, *tend; char *fin, *fout; int size; char vmrtr[20]; /* Examine Parameters */ VMRname = (char *)0; size = 0; fin = fout = (char *)0; while (--argc > 0) { p = *++argv; if (*p == '-') switch(*++p) { case 'f': FORname = ++p; break; case 'v': VMRname = ++p; break; case 's': p++; size = atoi(p); break; default: p--; error("Bad argument ", p); synopsis(); ospexit (found_errors); } else { if (!fin) fin = p; else if (!fout) fout = p; else error("Bad Argument ", p); } } if ( VMRname == (char *)0 ) VMRname = FORname; /* Open Files */ if (fin) { if (size <= 0) size = osfsize(fin); IN = osaopen(fin, 0); } if (size <= 0) size = 20000; /* CG. */ /* First: try to delete the output file if exists. */ /* Second: exit if an error when opening */ /* Third: The osdopen does not take into account the protection flags */ if (fout) { osfdelete(fout); if ( (OUT = osdopen (fout, 1)) == -1 ) { error("Output file: ", osmsg()); ospexit (found_errors); } } text = osmmget (size+2); tend = text + size + 1; p = text; while (osaread(IN, p, tend - p) >= 0) p += strlen(p), *(p++) = '\n'; *p = EOS; if (IN > 2) osaclose(IN); /* Add the definition of vmr ... but only if VMRname != "." */ fname(vmrtr, "vmr"); if (strdiff(vmrtr, "vmr")) emits("#define vmr\t"), emits(vmrtr); emits("\t\t/"); emits("* parameter for Name Translation is "); emits(VMRname); emits(" */\n"); emits("#define ROUTINE int\n"); /* Parse the Complete Text */ parse(text); if (OUT > 2) osdclose(OUT); ospexit (found_errors); }