home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Usenet 1994 October
/
usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso
/
unix
/
volume21
/
p2c
/
part13
< prev
next >
Wrap
Text File
|
1990-04-05
|
40KB
|
1,412 lines
Subject: v21i058: Pascal to C translator, Part13/32
Newsgroups: comp.sources.unix
Approved: rsalz@uunet.UU.NET
X-Checksum-Snefru: ff846a8f 2466420e ebd182ba 5ab226d5
Submitted-by: Dave Gillespie <daveg@csvax.caltech.edu>
Posting-number: Volume 21, Issue 58
Archive-name: p2c/part13
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 13 (of 32)."
# Contents: src/lex.c.2
# Wrapped by rsalz@litchi.bbn.com on Mon Mar 26 14:29:36 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/lex.c.2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'src/lex.c.2'\"
else
echo shar: Extracting \"'src/lex.c.2'\" \(36991 characters\)
sed "s/^X//" >'src/lex.c.2' <<'END_OF_FILE'
X if (cp != closing)
X return 0;
X strlist_remove((Strlist **)rctable[i].ptr, namebuf);
X } else {
X if (!isspace(*cp) && *cp != '=')
X return 0;
X skipspc(cp);
X if (*cp == '=') {
X cp++;
X skipspc(cp);
X }
X if (chgmode == '=' || isspace(chgmode))
X strlist_remove((Strlist **)rctable[i].ptr, namebuf);
X sp = strlist_append((Strlist **)rctable[i].ptr, namebuf);
X if (tempopt)
X strlist_insert(&tempoptionlist, namebuf)->value = i;
X cp2 = namebuf;
X while (*cp && cp != closing && !isspace(*cp))
X *cp2++ = *cp++;
X *cp2++ = 0;
X skipspc(cp);
X if (cp != closing)
X return 0;
X sp->value = (long)stralloc(namebuf);
X }
X inbufptr = after;
X if (lex_initialized)
X handle_nameof(); /* as good a place to do this as any! */
X return 1;
X
X case 3: /* Synonym parameter */
X if (isspace(*cp) || *cp == '=' ||
X *cp == '+' || *cp == '-') {
X chgmode = *cp++;
X skipspc(cp);
X cp2 = namebuf;
X while (isalnum(*cp) || *cp == '_' ||
X *cp == '$' || *cp == '%')
X *cp2++ = *cp++;
X *cp2++ = 0;
X if (!*namebuf)
X return 0;
X skipspc(cp);
X if (!pascalcasesens)
X upc(namebuf);
X sym = findsymbol(namebuf);
X if (chgmode == '-') {
X if (cp != closing)
X return 0;
X sym->flags &= ~SSYNONYM;
X inbufptr = after;
X return 1;
X }
X if (*cp == '=') {
X cp++;
X skipspc(cp);
X }
X cp2 = namebuf;
X while (isalnum(*cp) || *cp == '_' ||
X *cp == '$' || *cp == '%')
X *cp2++ = *cp++;
X *cp2++ = 0;
X skipspc(cp);
X if (cp != closing)
X return 0;
X sym->flags |= SSYNONYM;
X if (!pascalcasesens)
X upc(namebuf);
X if (*namebuf)
X strlist_append(&sym->symbolnames, "===")->value =
X (long)findsymbol(namebuf);
X else
X strlist_append(&sym->symbolnames, "===")->value=0;
X inbufptr = after;
X return 1;
X }
X return 0;
X
X }
X return 0;
X
X }
X return 0;
X}
X
X
X
XStatic void comment(starparen)
Xint starparen; /* 0={ }, 1=(* *), 2=C comments*/
X{
X register char ch;
X int nestcount = 1, startlnum = inf_lnum, trailing;
X int i, cmtindent, cmtindent2;
X char *cp;
X
X cp = inbuf;
X while (isspace(*cp))
X cp++;
X trailing = (*cp != '{' && ((*cp != '(' && *cp != '/') || cp[1] != '*'));
X cmtindent = inbufindent;
X cmtindent2 = cmtindent + 1 + (starparen != 0);
X cp = inbufptr;
X while (isspace(*cp))
X cmtindent2++, cp++;
X cp = curtokbuf;
X for (;;) {
X ch = *inbufptr++;
X switch (ch) {
X
X case '}':
X if ((!starparen || nestedcomments == 0) &&
X starparen != 2 &&
X --nestcount <= 0) {
X *cp = 0;
X if (!commenting_flag)
X commentline(trailing ? CMT_TRAIL : CMT_POST);
X return;
X }
X break;
X
X case '{':
X if (nestedcomments == 1 && starparen != 2)
X nestcount++;
X break;
X
X case '*':
X if ((*inbufptr == ((starparen == 2) ? '/' : ')') &&
X (starparen || nestedcomments == 0)) &&
X --nestcount <= 0) {
X inbufptr++;
X *cp = 0;
X if (!commenting_flag)
X commentline(trailing ? CMT_TRAIL : CMT_POST);
X return;
X }
X break;
X
X case '(':
X if (*inbufptr == '*' && nestedcomments == 1 &&
X starparen != 2) {
X *cp++ = ch;
X ch = *inbufptr++;
X nestcount++;
X }
X break;
X
X case 0:
X *cp = 0;
X if (commenting_flag)
X saveinputcomment(inbufptr-1);
X else
X commentline(CMT_POST);
X trailing = 0;
X getline();
X i = 0;
X for (;;) {
X if (*inbufptr == ' ') {
X inbufptr++;
X i++;
X } else if (*inbufptr == '\t') {
X inbufptr++;
X i++;
X if (intabsize)
X i = (i / intabsize + 1) * intabsize;
X } else
X break;
X }
X cp = curtokbuf;
X if (*inbufptr) {
X if (i == cmtindent2 && !starparen)
X cmtindent--;
X cmtindent2 = -1;
X if (i >= cmtindent) {
X *cp++ = '\002';
X i -= cmtindent;
X } else {
X *cp++ = '\003';
X }
X while (--i >= 0)
X *cp++ = ' ';
X } else
X *cp++ = '\003';
X continue;
X
X case EOFMARK:
X error(format_d("Runaway comment from line %d", startlnum));
X return; /* unnecessary */
X
X }
X *cp++ = ch;
X }
X}
X
X
X
Xchar *getinlinepart()
X{
X char *cp, *buf;
X
X for (;;) {
X if (isspace(*inbufptr)) {
X inbufptr++;
X } else if (!*inbufptr) {
X getline();
X } else if (*inbufptr == '{') {
X inbufptr++;
X comment(0);
X } else if (*inbufptr == '(' && inbufptr[1] == '*') {
X inbufptr += 2;
X comment(1);
X } else
X break;
X }
X cp = inbufptr;
X while (isspace(*cp) || isalnum(*cp) ||
X *cp == '_' || *cp == '$' ||
X *cp == '+' || *cp == '-' ||
X *cp == '<' || *cp == '>')
X cp++;
X if (cp == inbufptr)
X return "";
X while (isspace(cp[-1]))
X cp--;
X buf = format_s("%s", inbufptr);
X buf[cp-inbufptr] = 0; /* truncate the string */
X inbufptr = cp;
X return buf;
X}
X
X
X
X
XStatic int getflag()
X{
X int res = 1;
X
X gettok();
X if (curtok == TOK_IDENT) {
X res = (strcmp(curtokbuf, "OFF") != 0);
X gettok();
X }
X return res;
X}
X
X
X
X
Xchar getchartok()
X{
X if (!*inbufptr) {
X warning("Unexpected end of line [236]");
X return ' ';
X }
X if (isspace(*inbufptr)) {
X warning("Whitespace not allowed here [237]");
X return ' ';
X }
X return *inbufptr++;
X}
X
X
X
Xchar *getparenstr(buf)
Xchar *buf;
X{
X int count = 0;
X char *cp;
X
X if (inbufptr < buf) /* this will get most bad cases */
X error("Can't handle a line break here");
X while (isspace(*buf))
X buf++;
X cp = buf;
X for (;;) {
X if (!*cp)
X error("Can't handle a line break here");
X if (*cp == '(')
X count++;
X if (*cp == ')')
X if (--count < 0)
X break;
X cp++;
X }
X inbufptr = cp + 1;
X while (cp > buf && isspace(cp[-1]))
X cp--;
X return format_ds("%.*s", (int)(cp - buf), buf);
X}
X
X
X
Xvoid leadingcomments()
X{
X for (;;) {
X switch (*inbufptr++) {
X
X case 0:
X getline();
X break;
X
X case ' ':
X case '\t':
X case 26:
X /* ignore whitespace */
X break;
X
X case '{':
X if (!parsecomment(1, 0)) {
X inbufptr--;
X return;
X }
X break;
X
X case '(':
X if (*inbufptr == '*') {
X inbufptr++;
X if (!parsecomment(1, 1)) {
X inbufptr -= 2;
X return;
X }
X break;
X }
X /* fall through */
X
X default:
X inbufptr--;
X return;
X
X }
X }
X}
X
X
X
X
Xvoid get_C_string(term)
Xint term;
X{
X char *cp = curtokbuf;
X char ch;
X int i;
X
X while ((ch = *inbufptr++)) {
X if (ch == term) {
X *cp = 0;
X curtokint = cp - curtokbuf;
X return;
X } else if (ch == '\\') {
X if (isdigit(*inbufptr)) {
X i = (*inbufptr++) - '0';
X if (isdigit(*inbufptr))
X i = i*8 + (*inbufptr++) - '0';
X if (isdigit(*inbufptr))
X i = i*8 + (*inbufptr++) - '0';
X *cp++ = i;
X } else {
X ch = *inbufptr++;
X switch (tolower(ch)) {
X case 'n':
X *cp++ = '\n';
X break;
X case 't':
X *cp++ = '\t';
X break;
X case 'v':
X *cp++ = '\v';
X break;
X case 'b':
X *cp++ = '\b';
X break;
X case 'r':
X *cp++ = '\r';
X break;
X case 'f':
X *cp++ = '\f';
X break;
X case '\\':
X *cp++ = '\\';
X break;
X case '\'':
X *cp++ = '\'';
X break;
X case '"':
X *cp++ = '"';
X break;
X case 'x':
X if (isxdigit(*inbufptr)) {
X if (isdigit(*inbufptr))
X i = (*inbufptr++) - '0';
X else
X i = (toupper(*inbufptr++)) - 'A' + 10;
X if (isdigit(*inbufptr))
X i = i*16 + (*inbufptr++) - '0';
X else if (isxdigit(*inbufptr))
X i = i*16 + (toupper(*inbufptr++)) - 'A' + 10;
X *cp++ = i;
X break;
X }
X /* fall through */
X default:
X warning("Strange character in C string [238]");
X }
X }
X } else
X *cp++ = ch;
X }
X *cp = 0;
X curtokint = cp - curtokbuf;
X warning("Unterminated C string [239]");
X}
X
X
X
X
X
Xvoid begincommenting(cp)
Xchar *cp;
X{
X if (!commenting_flag) {
X commenting_ptr = cp;
X }
X commenting_flag++;
X}
X
X
Xvoid saveinputcomment(cp)
Xchar *cp;
X{
X if (commenting_ptr)
X sprintf(curtokbuf, "%.*s", (int)(cp - commenting_ptr), commenting_ptr);
X else
X sprintf(curtokbuf, "\003%.*s", (int)(cp - inbuf), inbuf);
X commentline(CMT_POST);
X commenting_ptr = NULL;
X}
X
X
Xvoid endcommenting(cp)
Xchar *cp;
X{
X commenting_flag--;
X if (!commenting_flag) {
X saveinputcomment(cp);
X }
X}
X
X
X
X
Xint peeknextchar()
X{
X char *cp;
X
X cp = inbufptr;
X while (isspace(*cp))
X cp++;
X return *cp;
X}
X
X
X
X
X#ifdef LEXDEBUG
XStatic void zgettok();
Xvoid gettok()
X{
X zgettok();
X if (tokentrace) {
X printf("gettok() found %s", tok_name(curtok));
X switch (curtok) {
X case TOK_HEXLIT:
X case TOK_OCTLIT:
X case TOK_INTLIT:
X case TOK_MININT:
X printf(", curtokint = %d", curtokint);
X break;
X case TOK_REALLIT:
X case TOK_STRLIT:
X printf(", curtokbuf = %s", makeCstring(curtokbuf, curtokint));
X break;
X default:
X break;
X }
X putchar('\n');
X }
X}
XStatic void zgettok()
X#else
Xvoid gettok()
X#endif
X{
X register char ch;
X register char *cp;
X char ch2;
X char *startcp;
X int i;
X
X debughook();
X for (;;) {
X switch ((ch = *inbufptr++)) {
X
X case 0:
X if (commenting_flag)
X saveinputcomment(inbufptr-1);
X getline();
X cp = curtokbuf;
X for (;;) {
X inbufindent = 0;
X for (;;) {
X if (*inbufptr == '\t') {
X inbufindent++;
X if (intabsize)
X inbufindent = (inbufindent / intabsize + 1) * intabsize;
X } else if (*inbufptr == ' ')
X inbufindent++;
X else if (*inbufptr != 26)
X break;
X inbufptr++;
X }
X if (!*inbufptr && !commenting_flag) { /* blank line */
X *cp++ = '\001';
X getline();
X } else
X break;
X }
X if (cp > curtokbuf) {
X *cp = 0;
X commentline(CMT_POST);
X }
X break;
X
X case '\t':
X case ' ':
X case 26: /* ignore ^Z's in Turbo files */
X while (*inbufptr++ == ch) ;
X inbufptr--;
X break;
X
X case '$':
X if (dollar_idents)
X goto ident;
X if (dollar_flag) {
X dollar_flag = 0;
X curtok = TOK_DOLLAR;
X return;
X }
X startcp = inbufptr-1;
X while (isspace(*inbufptr))
X inbufptr++;
X cp = inbufptr;
X while (isxdigit(*cp))
X cp++;
X if (cp > inbufptr && cp <= inbufptr+8 && !isalnum(*cp)) {
X while (isspace(*cp))
X cp++;
X if (!isdigit(*cp) && *cp != '\'') {
X cp = curtokbuf; /* Turbo hex constant */
X while (isxdigit(*inbufptr))
X *cp++ = *inbufptr++;
X *cp = 0;
X curtok = TOK_HEXLIT;
X curtokint = my_strtol(curtokbuf, NULL, 16);
X return;
X }
X }
X dollar_flag++; /* HP Pascal compiler directive */
X do {
X gettok();
X if (curtok == TOK_IF) { /* $IF expr$ */
X Expr *ex;
X Value val;
X if (!skipping_module) {
X if (!setup_complete)
X error("$IF$ not allowed at top of program");
X
X /* Even though HP Pascal doesn't let these nest,
X there's no harm in supporting it. */
X if (if_flag) {
X skiptotoken(TOK_DOLLAR);
X if_flag++;
X break;
X }
X gettok();
X ex = p_expr(tp_boolean);
X val = eval_expr_consts(ex);
X freeexpr(ex);
X i = (val.type == tp_boolean && val.i);
X free_value(&val);
X if (!i) {
X if (curtok != TOK_DOLLAR) {
X warning("Syntax error in $IF$ expression [240]");
X skiptotoken(TOK_DOLLAR);
X }
X begincommenting(startcp);
X if_flag++;
X while (if_flag > 0)
X gettok();
X endcommenting(inbufptr);
X }
X } else {
X skiptotoken(TOK_DOLLAR);
X }
X } else if (curtok == TOK_END) { /* $END$ */
X if (if_flag) {
X gettok();
X if (!wexpecttok(TOK_DOLLAR))
X skiptotoken(TOK_DOLLAR);
X curtok = TOK_ENDIF;
X if_flag--;
X return;
X } else {
X gettok();
X if (!wexpecttok(TOK_DOLLAR))
X skiptotoken(TOK_DOLLAR);
X }
X } else if (curtok == TOK_IDENT) {
X if (!strcmp(curtokbuf, "INCLUDE") &&
X !if_flag && !skipping_module) {
X char *fn;
X gettok();
X if (curtok == TOK_IDENT) {
X fn = stralloc(curtokcase);
X gettok();
X } else if (wexpecttok(TOK_STRLIT)) {
X fn = stralloc(curtokbuf);
X gettok();
X } else
X fn = "";
X if (!wexpecttok(TOK_DOLLAR)) {
X skiptotoken(TOK_DOLLAR);
X } else {
X if (handle_include(fn))
X return;
X }
X } else if (ignore_directives ||
X if_flag ||
X !strcmp(curtokbuf, "SEARCH") ||
X !strcmp(curtokbuf, "REF") ||
X !strcmp(curtokbuf, "DEF")) {
X skiptotoken(TOK_DOLLAR);
X } else if (!strcmp(curtokbuf, "SWITCH_STRPOS")) {
X switch_strpos = getflag();
X } else if (!strcmp(curtokbuf, "SYSPROG")) {
X if (getflag())
X sysprog_flag |= 1;
X else
X sysprog_flag &= ~1;
X } else if (!strcmp(curtokbuf, "MODCAL")) {
X if (getflag())
X sysprog_flag |= 2;
X else
X sysprog_flag &= ~2;
X } else if (!strcmp(curtokbuf, "PARTIAL_EVAL")) {
X if (shortcircuit < 0)
X partial_eval_flag = getflag();
X } else if (!strcmp(curtokbuf, "IOCHECK")) {
X iocheck_flag = getflag();
X } else if (!strcmp(curtokbuf, "RANGE")) {
X if (getflag()) {
X if (!range_flag)
X note("Range checking is ON [216]");
X range_flag = 1;
X } else {
X if (range_flag)
X note("Range checking is OFF [216]");
X range_flag = 0;
X }
X } else if (!strcmp(curtokbuf, "OVFLCHECK")) {
X if (getflag()) {
X if (!ovflcheck_flag)
X note("Overflow checking is ON [219]");
X ovflcheck_flag = 1;
X } else {
X if (ovflcheck_flag)
X note("Overflow checking is OFF [219]");
X ovflcheck_flag = 0;
X }
X } else if (!strcmp(curtokbuf, "STACKCHECK")) {
X if (getflag()) {
X if (!stackcheck_flag)
X note("Stack checking is ON [217]");
X stackcheck_flag = 1;
X } else {
X if (stackcheck_flag)
X note("Stack checking is OFF [217]");
X stackcheck_flag = 0;
X }
X }
X skiptotoken2(TOK_DOLLAR, TOK_COMMA);
X } else {
X warning("Mismatched '$' signs [241]");
X dollar_flag = 0; /* got out of sync */
X return;
X }
X } while (curtok == TOK_COMMA);
X break;
X
X case '"':
X if (C_lex) {
X get_C_string(ch);
X curtok = TOK_STRLIT;
X return;
X }
X goto stringLiteral;
X
X case '#':
X if (modula2) {
X curtok = TOK_NE;
X return;
X }
X cp = inbufptr;
X while (isspace(*cp)) cp++;
X if (!strcincmp(cp, "INCLUDE", 7)) {
X char *cp2, *cp3;
X cp += 7;
X while (isspace(*cp)) cp++;
X cp2 = cp + strlen(cp) - 1;
X while (isspace(*cp2)) cp2--;
X if ((*cp == '"' && *cp2 == '"' && cp2 > cp) ||
X (*cp == '<' && *cp2 == '>')) {
X inbufptr = cp2 + 1;
X cp3 = stralloc(cp + 1);
X cp3[cp2 - cp - 1] = 0;
X if (handle_include(cp3))
X return;
X else
X break;
X }
X }
X /* fall through */
X
X case '\'':
X if (C_lex && ch == '\'') {
X get_C_string(ch);
X if (curtokint != 1)
X warning("Character constant has length != 1 [242]");
X curtokint = *curtokbuf;
X curtok = TOK_CHARLIT;
X return;
X }
X stringLiteral:
X cp = curtokbuf;
X ch2 = (ch == '"') ? '"' : '\'';
X do {
X if (ch == ch2) {
X while ((ch = *inbufptr++) != '\n' &&
X ch != EOF) {
X if (ch == ch2) {
X if (*inbufptr != ch2 || modula2)
X break;
X else
X inbufptr++;
X }
X *cp++ = ch;
X }
X if (ch != ch2)
X warning("Error in string literal [243]");
X } else {
X ch = *inbufptr++;
X if (isdigit(ch)) {
X i = 0;
X while (isdigit(ch)) {
X i = i*10 + ch - '0';
X ch = *inbufptr++;
X }
X inbufptr--;
X *cp++ = i;
X } else {
X *cp++ = ch & 0x1f;
X }
X }
X while (*inbufptr == ' ' || *inbufptr == '\t')
X inbufptr++;
X } while ((ch = *inbufptr++) == ch2 || ch == '#');
X inbufptr--;
X *cp = 0;
X curtokint = cp - curtokbuf;
X curtok = TOK_STRLIT;
X return;
X
X case '(':
X if (*inbufptr == '*' && !C_lex) {
X inbufptr++;
X switch (commenting_flag ? 0 : parsecomment(0, 1)) {
X case 0:
X comment(1);
X break;
X case 2:
X return;
X }
X break;
X } else if (*inbufptr == '.') {
X curtok = TOK_LBR;
X inbufptr++;
X } else {
X curtok = TOK_LPAR;
X }
X return;
X
X case '{':
X if (C_lex || modula2) {
X curtok = TOK_LBRACE;
X return;
X }
X switch (commenting_flag ? 0 : parsecomment(0, 0)) {
X case 0:
X comment(0);
X break;
X case 2:
X return;
X }
X break;
X
X case '}':
X if (C_lex || modula2) {
X curtok = TOK_RBRACE;
X return;
X }
X if (skipflag > 0) {
X skipflag = 0;
X } else
X warning("Unmatched '}' in input file [244]");
X break;
X
X case ')':
X curtok = TOK_RPAR;
X return;
X
X case '*':
X if (*inbufptr == (C_lex ? '/' : ')')) {
X inbufptr++;
X if (skipflag > 0) {
X skipflag = 0;
X } else
X warning("Unmatched '*)' in input file [245]");
X break;
X } else if (*inbufptr == '*' && !C_lex) {
X curtok = TOK_STARSTAR;
X inbufptr++;
X } else
X curtok = TOK_STAR;
X return;
X
X case '+':
X if (C_lex && *inbufptr == '+') {
X curtok = TOK_PLPL;
X inbufptr++;
X } else
X curtok = TOK_PLUS;
X return;
X
X case ',':
X curtok = TOK_COMMA;
X return;
X
X case '-':
X if (C_lex && *inbufptr == '-') {
X curtok = TOK_MIMI;
X inbufptr++;
X } else if (*inbufptr == '>') {
X curtok = TOK_ARROW;
X inbufptr++;
X } else
X curtok = TOK_MINUS;
X return;
X
X case '.':
X if (*inbufptr == '.') {
X curtok = TOK_DOTS;
X inbufptr++;
X } else if (*inbufptr == ')') {
X curtok = TOK_RBR;
X inbufptr++;
X } else
X curtok = TOK_DOT;
X return;
X
X case '/':
X if (C_lex && *inbufptr == '*') {
X inbufptr++;
X comment(2);
X break;
X }
X curtok = TOK_SLASH;
X return;
X
X case ':':
X if (*inbufptr == '=') {
X curtok = TOK_ASSIGN;
X inbufptr++;
X } else if (*inbufptr == ':') {
X curtok = TOK_COLONCOLON;
X inbufptr++;
X } else
X curtok = TOK_COLON;
X return;
X
X case ';':
X curtok = TOK_SEMI;
X return;
X
X case '<':
X if (*inbufptr == '=') {
X curtok = TOK_LE;
X inbufptr++;
X } else if (*inbufptr == '>') {
X curtok = TOK_NE;
X inbufptr++;
X } else if (*inbufptr == '<') {
X curtok = TOK_LTLT;
X inbufptr++;
X } else
X curtok = TOK_LT;
X return;
X
X case '>':
X if (*inbufptr == '=') {
X curtok = TOK_GE;
X inbufptr++;
X } else if (*inbufptr == '>') {
X curtok = TOK_GTGT;
X inbufptr++;
X } else
X curtok = TOK_GT;
X return;
X
X case '=':
X if (*inbufptr == '=') {
X curtok = TOK_EQEQ;
X inbufptr++;
X } else
X curtok = TOK_EQ;
X return;
X
X case '[':
X curtok = TOK_LBR;
X return;
X
X case ']':
X curtok = TOK_RBR;
X return;
X
X case '^':
X curtok = TOK_HAT;
X return;
X
X case '&':
X if (*inbufptr == '&') {
X curtok = TOK_ANDAND;
X inbufptr++;
X } else
X curtok = TOK_AMP;
X return;
X
X case '|':
X if (*inbufptr == '|') {
X curtok = TOK_OROR;
X inbufptr++;
X } else
X curtok = TOK_VBAR;
X return;
X
X case '~':
X curtok = TOK_TWIDDLE;
X return;
X
X case '!':
X if (*inbufptr == '=') {
X curtok = TOK_BANGEQ;
X inbufptr++;
X } else
X curtok = TOK_BANG;
X return;
X
X case '%':
X if (C_lex) {
X curtok = TOK_PERC;
X return;
X }
X goto ident;
X
X case '?':
X curtok = TOK_QM;
X return;
X
X case '@':
X curtok = TOK_ADDR;
X return;
X
X case EOFMARK:
X if (curtok == TOK_EOF) {
X if (inputkind == INP_STRLIST)
X error("Unexpected end of macro");
X else
X error("Unexpected end of file");
X }
X curtok = TOK_EOF;
X return;
X
X default:
X if (isdigit(ch)) {
X cp = inbufptr;
X while (isxdigit(*cp))
X cp++;
X if (*cp == '#' && isxdigit(cp[1])) {
X i = atoi(inbufptr-1);
X inbufptr = cp+1;
X } else if (toupper(cp[-1]) == 'B' ||
X toupper(cp[-1]) == 'C') {
X inbufptr--;
X i = 8;
X } else if (toupper(*cp) == 'H') {
X inbufptr--;
X i = 16;
X } else if ((ch == '0' && toupper(*inbufptr) == 'X' &&
X isxdigit(inbufptr[1]))) {
X inbufptr++;
X i = 16;
X } else {
X i = 10;
X }
X if (i != 10) {
X curtokint = 0;
X while (isdigit(*inbufptr) ||
X (i > 10 && isxdigit(*inbufptr))) {
X ch = toupper(*inbufptr++);
X curtokint *= i;
X if (ch <= '9')
X curtokint += ch - '0';
X else
X curtokint += ch - 'A' + 10;
X }
X sprintf(curtokbuf, "%ld", curtokint);
X if ((toupper(*inbufptr) == 'B' && i == 8) ||
X (toupper(*inbufptr) == 'H' && i == 16))
X inbufptr++;
X if (toupper(*inbufptr) == 'C' && i == 8) {
X inbufptr++;
X curtok = TOK_STRLIT;
X curtokbuf[0] = curtokint;
X curtokbuf[1] = 0;
X curtokint = 1;
X return;
X }
X if (toupper(*inbufptr) == 'L') {
X strcat(curtokbuf, "L");
X inbufptr++;
X }
X curtok = (i == 8) ? TOK_OCTLIT : TOK_HEXLIT;
X return;
X }
X cp = curtokbuf;
X i = 0;
X while (ch == '0')
X ch = *inbufptr++;
X if (isdigit(ch)) {
X while (isdigit(ch)) {
X *cp++ = ch;
X ch = *inbufptr++;
X }
X } else
X *cp++ = '0';
X if (ch == '.') {
X if (isdigit(*inbufptr)) {
X *cp++ = ch;
X ch = *inbufptr++;
X i = 1;
X while (isdigit(ch)) {
X *cp++ = ch;
X ch = *inbufptr++;
X }
X }
X }
X if (ch == 'e' || ch == 'E' ||
X ch == 'd' || ch == 'D' ||
X ch == 'q' || ch == 'Q') {
X ch = *inbufptr;
X if (isdigit(ch) || ch == '+' || ch == '-') {
X *cp++ = 'e';
X inbufptr++;
X i = 1;
X do {
X *cp++ = ch;
X ch = *inbufptr++;
X } while (isdigit(ch));
X }
X }
X inbufptr--;
X *cp = 0;
X if (i) {
X curtok = TOK_REALLIT;
X curtokint = cp - curtokbuf;
X } else {
X if (cp >= curtokbuf+10) {
X i = strcmp(curtokbuf, "2147483648");
X if (cp > curtokbuf+10 || i > 0) {
X curtok = TOK_REALLIT;
X curtokint = cp - curtokbuf + 2;
X strcat(curtokbuf, ".0");
X return;
X }
X if (i == 0) {
X curtok = TOK_MININT;
X curtokint = -2147483648;
X return;
X }
X }
X curtok = TOK_INTLIT;
X curtokint = atol(curtokbuf);
X if (toupper(*inbufptr) == 'L') {
X strcat(curtokbuf, "L");
X inbufptr++;
X }
X }
X return;
X } else if (isalpha(ch) || ch == '_') {
Xident:
X {
X register char *cp2;
X curtoksym = NULL;
X cp = curtokbuf;
X cp2 = curtokcase;
X *cp2++ = symcase ? ch : tolower(ch);
X *cp++ = pascalcasesens ? ch : toupper(ch);
X while (isalnum((ch = *inbufptr++)) ||
X ch == '_' ||
X (ch == '%' && !C_lex) ||
X (ch == '$' && dollar_idents)) {
X *cp2++ = symcase ? ch : tolower(ch);
X if (!ignorenonalpha || isalnum(ch))
X *cp++ = pascalcasesens ? ch : toupper(ch);
X }
X inbufptr--;
X *cp2 = 0;
X *cp = 0;
X if (pascalsignif > 0)
X curtokbuf[pascalsignif] = 0;
X }
X if (*curtokbuf == '%') {
X if (!strcicmp(curtokbuf, "%INCLUDE")) {
X char *cp2 = inbufptr;
X while (isspace(*cp2)) cp2++;
X if (*cp2 == '\'')
X cp2++;
X cp = curtokbuf;
X while (*cp2 && *cp2 != '\'' &&
X *cp2 != ';' && !isspace(*cp2)) {
X *cp++ = *cp2++;
X }
X *cp = 0;
X cp = my_strrchr(curtokbuf, '/');
X if (cp && (!strcicmp(cp, "/LIST") ||
X !strcicmp(cp, "/NOLIST")))
X *cp = 0;
X if (*cp2 == '\'')
X cp2++;
X while (isspace(*cp2)) cp2++;
X if (*cp2 == ';')
X cp2++;
X while (isspace(*cp2)) cp2++;
X if (!*cp2) {
X inbufptr = cp2;
X (void) handle_include(stralloc(curtokbuf));
X return;
X }
X } else if (!strcicmp(curtokbuf, "%TITLE") ||
X !strcicmp(curtokbuf, "%SUBTITLE")) {
X gettok(); /* string literal */
X break;
X } else if (!strcicmp(curtokbuf, "%PAGE")) {
X /* should store a special page-break comment? */
X break; /* ignore token */
X } else if ((i = 2, !strcicmp(curtokbuf, "%B")) ||
X (i = 8, !strcicmp(curtokbuf, "%O")) ||
X (i = 16, !strcicmp(curtokbuf, "%X"))) {
X while (isspace(*inbufptr)) inbufptr++;
X if (*inbufptr == '\'') {
X inbufptr++;
X curtokint = 0;
X while (*inbufptr && *inbufptr != '\'') {
X ch = toupper(*inbufptr++);
X if (isxdigit(ch)) {
X curtokint *= i;
X if (ch <= '9')
X curtokint += ch - '0';
X else
X curtokint += ch - 'A' + 10;
X } else if (!isspace(ch))
X warning("Bad digit in literal [246]");
X }
X if (*inbufptr)
X inbufptr++;
X sprintf(curtokbuf, "%ld", curtokint);
X curtok = (i == 8) ? TOK_OCTLIT : TOK_HEXLIT;
X return;
X }
X }
X }
X {
X register unsigned int hash;
X register Symbol *sp;
X
X hash = 0;
X for (cp = curtokbuf; *cp; cp++)
X hash = hash*3 + *cp;
X sp = symtab[hash % SYMHASHSIZE];
X while (sp && (i = strcmp(sp->name, curtokbuf)) != 0) {
X if (i < 0)
X sp = sp->left;
X else
X sp = sp->right;
X }
X if (!sp)
X sp = findsymbol(curtokbuf);
X if (sp->flags & SSYNONYM) {
X i = 100;
X while (--i > 0 && sp && (sp->flags & SSYNONYM)) {
X Strlist *sl;
X sl = strlist_find(sp->symbolnames, "===");
X if (sl)
X sp = (Symbol *)sl->value;
X else
X sp = NULL;
X }
X if (!sp)
X break; /* ignore token */
X }
X if (sp->kwtok && !(sp->flags & KWPOSS) &&
X (pascalcasesens != 2 || !islower(*curtokbuf)) &&
X (pascalcasesens != 3 || !isupper(*curtokbuf))) {
X curtok = sp->kwtok;
X return;
X }
X curtok = TOK_IDENT;
X curtoksym = sp;
X if ((i = withlevel) != 0 && sp->fbase) {
X while (--i >= 0) {
X curtokmeaning = sp->fbase;
X while (curtokmeaning) {
X if (curtokmeaning->rectype == withlist[i]) {
X curtokint = i;
X return;
X }
X curtokmeaning = curtokmeaning->snext;
X }
X }
X }
X curtokmeaning = sp->mbase;
X while (curtokmeaning && !curtokmeaning->isactive)
X curtokmeaning = curtokmeaning->snext;
X if (!curtokmeaning)
X return;
X while (curtokmeaning->kind == MK_SYNONYM)
X curtokmeaning = curtokmeaning->xnext;
X /* look for unit.ident notation */
X if (curtokmeaning->kind == MK_MODULE ||
X curtokmeaning->kind == MK_FUNCTION) {
X for (cp = inbufptr; isspace(*cp); cp++) ;
X if (*cp == '.') {
X for (cp++; isspace(*cp); cp++) ;
X if (isalpha(*cp)) {
X Meaning *mp = curtokmeaning;
X Symbol *sym = curtoksym;
X char *saveinbufptr = inbufptr;
X gettok();
X if (curtok == TOK_DOT)
X gettok();
X else
X curtok = TOK_END;
X if (curtok == TOK_IDENT) {
X curtokmeaning = curtoksym->mbase;
X while (curtokmeaning &&
X curtokmeaning->ctx != mp)
X curtokmeaning = curtokmeaning->snext;
X if (!curtokmeaning &&
X !strcmp(sym->name, "SYSTEM")) {
X curtokmeaning = curtoksym->mbase;
X while (curtokmeaning &&
X curtokmeaning->ctx != nullctx)
X curtokmeaning = curtokmeaning->snext;
X }
X } else
X curtokmeaning = NULL;
X if (!curtokmeaning) {
X /* oops, was probably funcname.field */
X inbufptr = saveinbufptr;
X curtokmeaning = mp;
X curtoksym = sym;
X }
X }
X }
X }
X return;
X }
X } else {
X warning("Unrecognized character in file [247]");
X }
X }
X }
X}
X
X
X
Xvoid checkkeyword(tok)
XToken tok;
X{
X if (curtok == TOK_IDENT &&
X curtoksym->kwtok == tok) {
X curtoksym->flags &= ~KWPOSS;
X curtok = tok;
X }
X}
X
X
Xvoid checkmodulewords()
X{
X if (modula2) {
X checkkeyword(TOK_FROM);
X checkkeyword(TOK_DEFINITION);
X checkkeyword(TOK_IMPLEMENT);
X checkkeyword(TOK_MODULE);
X checkkeyword(TOK_IMPORT);
X checkkeyword(TOK_EXPORT);
X } else if (curtok == TOK_IDENT &&
X (curtoksym->kwtok == TOK_MODULE ||
X curtoksym->kwtok == TOK_IMPORT ||
X curtoksym->kwtok == TOK_EXPORT ||
X curtoksym->kwtok == TOK_IMPLEMENT)) {
X if (!strcmp(curtokbuf, "UNIT") ||
X !strcmp(curtokbuf, "USES") ||
X !strcmp(curtokbuf, "INTERFACE") ||
X !strcmp(curtokbuf, "IMPLEMENTATION")) {
X modulenotation = 0;
X findsymbol("UNIT")->flags &= ~KWPOSS;
X findsymbol("USES")->flags &= ~KWPOSS;
X findsymbol("INTERFACE")->flags &= ~KWPOSS;
X findsymbol("IMPLEMENTATION")->flags &= ~KWPOSS;
X } else {
X modulenotation = 1;
X findsymbol("MODULE")->flags &= ~KWPOSS;
X findsymbol("EXPORT")->flags &= ~KWPOSS;
X findsymbol("IMPORT")->flags &= ~KWPOSS;
X findsymbol("IMPLEMENT")->flags &= ~KWPOSS;
X }
X curtok = curtoksym->kwtok;
X }
X}
X
X
X
X
X
X
X
X
X
X
X
X
X/* End. */
X
X
X
END_OF_FILE
if test 36991 -ne `wc -c <'src/lex.c.2'`; then
echo shar: \"'src/lex.c.2'\" unpacked with wrong size!
fi
# end of 'src/lex.c.2'
fi
echo shar: End of archive 13 \(of 32\).
cp /dev/null ark13isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 32 archives.
echo "Now see PACKNOTES and the README"
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
