123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411 |
- /* 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 "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;
- 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);
- 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()
- {
- /* Read a Pascal string, delimited by the character "'".
- */
- 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 == '\'' ) {
- LoadChar(ch);
- if( ch != '\'' )
- 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;
- }
- 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;
- 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
- goto again;
- case STSKIP:
- goto again;
- case STGARB:
- 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 again;
- }
- if( nch == '.' ) /* (. is [ */
- return tk->tk_symb = '[';
- if( nch == EOI ) eofseen = 1;
- else PushBack();
- }
- else if( ch == '{' ) {
- SkipComment();
- tk->tk_lineno = LineNumber;
- goto again;
- }
- 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();
- 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();
- if( str->s_length == 1 ) {
- #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 {
- tk->tk_data.tk_str = str;
- toktype = standard_type(T_STRING, 1, str->s_length);
- }
- return tk->tk_symb = STRING;
- }
- case STNUM: {
- #define INT_MODE 0
- #define REAL_MODE 1
- char buf[NUMSIZE+2];
- register char *np = buf;
- register int state = INT_MODE;
- extern char *Salloc();
- 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;
- 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;
- /* sign */
- tk->TOK_RSI = 0;
- tk->TOK_RIV->r_sign = 1;
- if( np > &buf[NUMSIZE+1] ) {
- tk->TOK_REL = Salloc("0.0", 4);
- lexerror("floating constant too long");
- }
- else tk->TOK_REL = Salloc(buf, np - buf);
- 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*/
- }
|