123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587 |
- /* L E X I C A L A N A L Y S E R F O R I S O - P A S C A L */
- #include <stdlib.h>
- #include <stdio.h>
- #include <string.h>
- #include "debug.h"
- #include "idfsize.h"
- #include "numsize.h"
- #include "strsize.h"
- #include <alloc.h>
- #include <em_arith.h>
- #include <em_label.h>
- #include "LLlex.h"
- #include "Lpars.h"
- #include "class.h"
- #include "const.h"
- #include "f_info.h"
- #include "idf.h"
- #include "input.h"
- #include "main.h"
- #include "type.h"
- extern long str2long();
- extern char *Malloc();
- #define TO_LOWER(ch) (ch |= ( ch>='A' && ch<='Z' ) ? 0x0020 : 0)
- #ifdef DEBUG
- extern int cntlines;
- #endif
- int idfsize = IDFSIZE;
- struct token dot,
- aside;
- struct type *toktype,
- *asidetype;
- static int eofseen;
- int tokenseen = 0; /* Some comment-options must precede any program text */
- /* Warning: The options specified inside comments take precedence over
- * the ones on the command line.
- */
- CommentOptions()
- {
- register int ch, ci;
- int on_on_minus = 0;
- /* Parse options inside comments */
- do {
- LoadChar(ch);
- ci = ch;
- switch ( ci ) {
- case 'c': /* for strings */
- case 'd': /* for longs */
- case 's': /* check for standard */
- case 'u': /* for underscores */
- case 'C': /* for different cases */
- case 'U': /* for underscores */
- if( tokenseen ) {
- lexwarning("the '%c' option must precede any program text", ci);
- break;
- }
- LoadChar(ch);
- if( ci == 's' && options[ci] && ch == '-')
- lexwarning("option '%c-' overrides previous one", ci);
- if( ch == '-' ) options[ci] = 0;
- else if( ch == '+' ) options[ci] = 1;
- else PushBack();
- break;
- case 'l': ci = 'L' ; /* for indexing */
- /* fall through */
- case 'L': /* FIL & LIN instructions */
- case 'R': /* range checks */
- case 'a': /* assertions */
- on_on_minus = 1;
- /* fall through */
- case 't': /* tracing */
- case 'A': /* extra array range-checks */
- LoadChar(ch);
- if( ch == '-' ) options[ci] = on_on_minus;
- else if( ch == '+' ) options[ci] = !on_on_minus;
- else PushBack();
- on_on_minus = 0;
- break;
- case 'i':
- {
- register int i=0;
- LoadChar(ch);
- while( ch >= '0' && ch <= '9' ) {
- i = 10 * i + (ch - '0');
- LoadChar(ch);
- }
- PushBack();
- if( tokenseen ) {
- lexwarning("the '%c' option must precede any program text", ci);
- break;
- }
- if( i <= 0 ) {
- lexwarning("bad '%c' option", ci);
- break;
- }
- max_intset = i;
- break;
- }
- default:
- break;
- }
- LoadChar(ch);
- } while (ch == ',' );
- PushBack();
- }
- STATIC
- SkipComment()
- {
- /* Skip ISO-Pascal comments (* ... *) or { ... }.
- Note :
- comments may not be nested (ISO 6.1.8).
- (* and { are interchangeable, so are *) and }.
- */
- register int ch;
- LoadChar(ch);
- if (ch == '$') CommentOptions();
- for (;;) {
- if( class(ch) == STNL ) {
- LineNumber++;
- #ifdef DEBUG
- cntlines++;
- #endif
- }
- else if( ch == '*' ) {
- LoadChar(ch);
- if( ch == ')' ) return; /* *) */
- else continue;
- }
- else if( ch == '}' ) return;
- else if( ch == EOI ) {
- lexerror("unterminated comment");
- break;
- }
- LoadChar(ch);
- }
- }
- STATIC struct string *
- GetString( delim )
- register int delim;
- {
- /* Read a Pascal string, delimited by the character ' or ".
- */
- register int ch;
- register struct string *str = (struct string *)
- Malloc((unsigned) sizeof(struct string));
- register char *p;
- register int len = ISTRSIZE;
-
- str->s_str = p = Malloc((unsigned int) ISTRSIZE);
- for( ; ; ) {
- LoadChar(ch);
- if( ch & 0200 ) {
- fatal("non-ascii '\\%03o' read", ch & 0377);
- /*NOTREACHED*/
- }
- if( class(ch) == STNL ) {
- lexerror("newline in string");
- LineNumber++;
- #ifdef DEBUG
- cntlines++;
- #endif
- break;
- }
- if( ch == EOI ) {
- lexerror("end-of-file in string");
- break;
- }
- if( ch == delim ) {
- LoadChar(ch);
- if( ch != delim )
- break;
- }
- *p++ = ch;
- if( p - str->s_str == len ) {
- extern char *Srealloc();
- str->s_str = Srealloc(str->s_str,
- (unsigned int) len + RSTRSIZE);
- p = str->s_str + len;
- len += RSTRSIZE;
- }
- }
- if( ch == EOI ) eofseen = 1;
- else PushBack();
- str->s_length = p - str->s_str;
- *p++ = '\0';
- /* ISO 6.1.7: string length at least 1 */
- if( str->s_length == 0 ) {
- lexerror("character-string: at least one character expected");
- str->s_length = 1;
- }
- return str;
- }
- static char *s_error = "illegal line directive";
- CheckForLineDirective()
- {
- register int ch;
- register int i = 0;
- char buf[IDFSIZE + 2];
- register char *c = buf;
- LoadChar(ch);
- if( ch != '#' ) {
- PushBack();
- return;
- }
- do { /*
- * Skip to next digit. Do not skip newlines.
- */
- LoadChar(ch);
- if( class(ch) == STNL ) {
- LineNumber++;
- lexerror(s_error);
- return;
- }
- else if( ch == EOI ) {
- eofseen = 1;
- break;
- }
- } while( class(ch) != STNUM );
- while( class(ch) == STNUM ) {
- i = i * 10 + (ch - '0');
- LoadChar(ch);
- }
- if( ch == EOI ) {
- eofseen = 1;
- }
- while( ch != '"' && ch != EOI && class(ch) != STNL) LoadChar(ch);
- if( ch == '"' ) {
- do {
- LoadChar(ch);
- *c++ = ch;
- if( class(ch) == STNL ) {
- LineNumber++;
- error(s_error);
- return;
- }
- } while( ch != '"' );
- *--c = '\0';
- do {
- LoadChar(ch);
- } while( class(ch) != STNL );
- /*
- * Remember the filename
- */
- if( !eofseen && strcmp(FileName, buf) ) {
- FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
- }
- }
- if( eofseen ) {
- error(s_error);
- return;
- }
- LineNumber = i;
- }
- int
- LLlex()
- {
- /* LLlex() is the Lexical Analyzer.
- The putting aside of tokens is taken into account.
- */
- register struct token *tk = ˙
- register int ch, nch;
- toktype = error_type;
- if( ASIDE ) { /* a token is put aside */
- *tk = aside;
- toktype = asidetype;
- ASIDE = 0;
- return tk->tk_symb;
- }
- tk->tk_lineno = LineNumber;
- again1:
- if( eofseen ) {
- eofseen = 0;
- ch = EOI;
- }
- else {
- again:
- LoadChar(ch);
- if( !options['C'] ) /* -C : cases are different */
- TO_LOWER(ch);
- if( (ch & 0200) && ch != EOI ) {
- fatal("non-ascii '\\%03o' read", ch & 0377);
- /*NOTREACHED*/
- }
- }
- switch( class(ch) ) {
- case STNL:
- LineNumber++;
- tk->tk_lineno++;
- #ifdef DEBUG
- cntlines++;
- #endif
- CheckForLineDirective();
- goto again1;
- case STSKIP:
- goto again;
- case STGARB:
- if( !tokenseen && (ch == '"' || ch == '_') ) {
- return tk->tk_symb = ch;
- }
- if( (unsigned) ch < 0177 )
- lexerror("garbage char %c", ch);
- else
- crash("(LLlex) garbage char \\%03o", ch);
- goto again;
- case STSIMP:
- if( ch == '(' ) {
- LoadChar(nch);
- if( nch == '*' ) { /* (* */
- SkipComment();
- tk->tk_lineno = LineNumber;
- goto again1;
- }
- if( nch == '.' ) /* (. is [ */
- return tk->tk_symb = '[';
- if( nch == EOI ) eofseen = 1;
- else PushBack();
- }
- else if( ch == '{' ) {
- SkipComment();
- tk->tk_lineno = LineNumber;
- goto again1;
- }
- else if( ch == '@' ) ch = '^'; /* @ is ^ */
- return tk->tk_symb = ch;
- case STCOMP:
- LoadChar(nch);
- switch( ch ) {
- case '.':
- if( nch == '.' ) /* .. */
- return tk->tk_symb = UPTO;
- if( nch == ')' ) /* .) is ] */
- return tk->tk_symb = ']';
- break;
- case ':':
- if( nch == '=' ) /* := */
- return tk->tk_symb = BECOMES;
- break;
- case '<':
- if( nch == '=' ) /* <= */
- return tk->tk_symb = LESSEQUAL;
- if( nch == '>' ) /* <> */
- return tk->tk_symb = NOTEQUAL;
- break;
- case '>':
- if( nch == '=' ) /* >= */
- return tk->tk_symb = GREATEREQUAL;
- break;
- default :
- crash("(LLlex, STCOMP)");
- /*NOTREACHED*/
- }
- if( nch == EOI ) eofseen = 1;
- else PushBack();
- return tk->tk_symb = ch;
- case STIDF: {
- char buf[IDFSIZE + 1];
- register char *tag = &buf[0];
- register struct idf *id;
- extern struct idf *str2idf();
- do {
- if( !options['C'] ) /* -C : cases are different */
- TO_LOWER(ch);
- if( tag - buf < idfsize )
- *tag++ = ch;
- LoadChar(ch);
- } while( in_idf(ch) );
- *tag = '\0';
- if( ch == EOI ) eofseen = 1;
- else PushBack();
- /* dtrg: removed to allow Pascal programs to access system routines
- * (necessary to make them do anything useful). What's this for,
- * anyway? */
-
- #if 0
- if( buf[0] == '_' ) lexerror("underscore starts identifier");
- #endif
- tk->TOK_IDF = id = str2idf(buf, 1);
- return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
- }
- case STSTR: {
- register struct string *str = GetString(ch);
- if( str->s_length == 1 && ch == '\'') {
- #ifdef DEBUG
- if( options['l'] ) {
- /* to prevent LexScan from crashing */
- tk->tk_data.tk_str = str;
- return tk->tk_symb = STRING;
- }
- #endif
- tk->TOK_INT = *(str->s_str) & 0377;
- toktype = char_type;
- free(str->s_str);
- free((char *) str);
- }
- else {
- if( ch == '\'' ) {
- tk->tk_data.tk_str = str;
- toktype = standard_type(T_STRINGCONST, 1, str->s_length);
- }
- else {
- tk->tk_data.tk_str = str;
- toktype = string_type;
- }
- }
- return tk->tk_symb = STRING;
- }
- case STNUM: {
- #define INT_MODE 0
- #define REAL_MODE 1
- char buf[NUMSIZE+2];
- register char *np = &buf[1];
- register int state = INT_MODE;
- extern char *Salloc();
- buf[0] = '-';
- do {
- if( np <= &buf[NUMSIZE] )
- *np++ = ch;
- LoadChar(ch);
- } while( is_dig(ch) );
- if( ch == '.' ) {
- LoadChar(ch);
- if( is_dig(ch) ) {
- if( np <= &buf[NUMSIZE] )
- *np++ = '.';
- do {
- /* fractional part */
- if( np <= &buf[NUMSIZE] )
- *np++ = ch;
- LoadChar(ch);
- } while( is_dig(ch) );
- state = REAL_MODE;
- }
- else {
- PushBack();
- PushBack();
- goto end;
- }
-
- }
- if( ch == 'e' || ch == 'E' ) {
- char *tp = np; /* save position in string */
- /* scale factor */
- if( np <= &buf[NUMSIZE] )
- *np++ = ch;
- LoadChar(ch);
- if( ch == '+' || ch == '-' ) {
- /* signed scale factor */
- if( np <= &buf[NUMSIZE] )
- *np++ = ch;
- LoadChar(ch);
- }
- if( is_dig(ch) ) {
- do {
- if( np <= &buf[NUMSIZE] )
- *np++ = ch;
- LoadChar(ch);
- } while( is_dig(ch) );
- state = REAL_MODE;
- }
- else {
- PushBack();
- PushBack();
- if( np - tp == 2 ) /* sign */
- PushBack();
- np = tp; /* restore position */
- goto end;
- }
- }
- /* syntax of number is correct */
- if( ch == EOI ) eofseen = 1;
- else PushBack();
- end:
- *np++ = '\0';
- if( state == INT_MODE ) {
- if( np > &buf[NUMSIZE+1] ) {
- tk->TOK_INT = 1;
- lexerror("constant too long");
- }
- else {
- np = &buf[1];
- while (*np == '0') /* skip leading zeros */
- np++;
- tk->TOK_INT = str2long(np, 10);
- if( tk->TOK_INT < 0 ||
- strlen(np) > strlen(maxint_str) ||
- strlen(np) == strlen(maxint_str) &&
- strcmp(np, maxint_str) > 0 )
- lexwarning("overflow in constant");
- }
- toktype = int_type;
- return tk->tk_symb = INTEGER;
- }
- /* REAL_MODE */
- tk->tk_data.tk_real = (struct real *)
- Malloc(sizeof(struct real));
- /* allocate struct for inverse */
- tk->TOK_RIV = (struct real *) Malloc(sizeof(struct real));
- tk->TOK_RIV->r_inverse = tk->tk_data.tk_real;
- tk->TOK_RLA = 0;
- tk->TOK_RIV->r_lab = 0;
- if( np > &buf[NUMSIZE+1] ) {
- tk->TOK_REL = Salloc("0.0", 4);
- tk->TOK_RIV->r_real = tk->TOK_REL;
- lexerror("floating constant too long");
- }
- else {
- tk->TOK_RIV->r_real = Salloc(buf,(unsigned) (np - buf));
- tk->TOK_REL = tk->TOK_RIV->r_real + 1;
- }
- toktype = real_type;
- return tk->tk_symb = REAL;
- /*NOTREACHED*/
- }
- case STEOI:
- return tk->tk_symb = -1;
- case STCHAR:
- default:
- crash("(LLlex) Impossible character class");
- /*NOTREACHED*/
- }
- /*NOTREACHED*/
- }
|