home *** CD-ROM | disk | FTP | other *** search
- 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
-