123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675 |
- /*
- * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
- * See the copyright notice in the ACK home directory, in the file "Copyright".
- *
- * Author: Ceriel J.H. Jacobs
- */
- /* L E X I C A L A N A L Y S E R F O R M O D U L A - 2 */
- /* $Id$ */
- #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 "assert.h"
- #include "LLlex.h"
- #include "input.h"
- #include "f_info.h"
- #include "Lpars.h"
- #include "class.h"
- #include "idf.h"
- #include "def.h"
- #include "type.h"
- #include "warning.h"
- #include "errout.h"
- extern char *getwdir();
- t_token dot,
- aside;
- t_type *toktype;
- int idfsize = IDFSIZE;
- int ForeignFlag;
- #ifdef DEBUG
- extern int cntlines;
- #endif
- int token_nmb = 0;
- int tk_nmb_at_last_syn_err = -ERR_SHADOW;
- extern char options[];
- extern int flt_status;
- STATIC
- SkipComment()
- {
- /* Skip Modula-2 comments (* ... *).
- Note that comments may be nested (par. 3.5).
- */
- register int ch, c;
- register int CommentLevel = 0;
- LoadChar(ch);
- if (ch == '$') {
- LoadChar(ch);
- switch(ch) {
- case 'F':
- /* Foreign; This definition module has an
- implementation in another language.
- In this case, don't generate prefixes in front
- of the names. Also, don't generate call to
- initialization routine.
- */
- ForeignFlag = D_FOREIGN;
- break;
- case 'U':
- inidf['_'] = 1;
- break;
- case 'A': /* Extra array bound checks, on or off */
- case 'R': /* Range checks, on or off */
- {
- int on_on_minus = ch == 'R';
- LoadChar(c);
- if (c == '-') {
- options[ch] = on_on_minus;
- break;
- }
- if (c == '+') {
- options[ch] = !on_on_minus;
- break;
- }
- ch = c;
- }
- /* fall through */
- default:
- break;
- }
- }
- for (;;) {
- if (!(ch & 0200) && class(ch) == STNL) {
- LineNumber++;
- #ifdef DEBUG
- cntlines++;
- #endif
- }
- else if (ch == '(') {
- LoadChar(ch);
- if (ch == '*') CommentLevel++;
- else continue;
- }
- else if (ch == '*') {
- LoadChar(ch);
- if (ch == ')') {
- CommentLevel--;
- if (CommentLevel < 0) break;
- }
- else continue;
- }
- else if (ch == EOI) {
- lexerror("unterminated comment");
- PushBack();
- break;
- }
- LoadChar(ch);
- }
- }
- STATIC struct string *
- GetString(upto)
- {
- /* Read a Modula-2 string, delimited by the character "upto".
- */
- register int ch;
- register struct string *str = (struct string *)
- Malloc((unsigned) sizeof(struct string));
- register char *p;
- register int len;
-
- len = ISTRSIZE;
- str->s_str = p = Malloc((unsigned int) ISTRSIZE);
- while (LoadChar(ch), ch != upto) {
- if (!(ch & 0200) && class(ch) == STNL) {
- lexerror("newline in string");
- LineNumber++;
- #ifdef DEBUG
- cntlines++;
- #endif
- break;
- }
- if (ch == EOI) {
- lexerror("end-of-file in string");
- break;
- }
- *p++ = ch;
- if (p - str->s_str == len) {
- str->s_str = Realloc(str->s_str,
- (unsigned int) len + RSTRSIZE);
- p = str->s_str + len;
- len += RSTRSIZE;
- }
- }
- str->s_length = p - str->s_str;
- len = (str->s_length+(int)word_size) & ~((int)word_size-1);
- while (p - str->s_str < len) {
- *p++ = '\0';
- }
- str->s_str = Realloc(str->s_str, (unsigned) len);
- if (str->s_length == 0) str->s_length = 1;
- /* ??? string length at least 1 ??? */
- return str;
- }
- static char *s_error = "illegal line directive";
- STATIC int
- getch()
- {
- register int ch;
- while (LoadChar(ch), (ch & 0200) && ch != EOI) {
- error("non-ascii '\\%03o' read", ch & 0377);
- }
- return ch;
- }
- CheckForLineDirective()
- {
- register int ch = getch();
- register int i = 0;
- char buf[IDFSIZE];
- register char *c = buf;
- if (ch != '#') {
- PushBack();
- return;
- }
- do { /*
- * Skip to next digit
- * Do not skip newlines
- */
- ch = getch();
- if (class(ch) == STNL || class(ch) == STEOI) {
- LineNumber++;
- error(s_error);
- return;
- }
- } while (class(ch) != STNUM);
- while (class(ch) == STNUM) {
- i = i*10 + (ch - '0');
- ch = getch();
- }
- while (ch != '"' && class(ch) != STNL && class(ch) != STEOI)
- ch = getch();
- if (ch == '"') {
- c = buf;
- do {
- ch = getch();
- if (c < &buf[IDFSIZE]) *c++ = ch;
- if (class(ch) == STNL || class(ch) == STEOI) {
- LineNumber++;
- error(s_error);
- return;
- }
- } while (ch != '"');
- *--c = '\0';
- do {
- ch = getch();
- } while (class(ch) != STNL && class(ch) != STEOI);
- /*
- * Remember the file name
- */
- if (class(ch) == STNL && strcmp(FileName,buf)) {
- FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
- WorkingDir = getwdir(FileName);
- }
- }
- if (class(ch) == STEOI) {
- error(s_error);
- return;
- }
- LineNumber = i;
- }
- STATIC
- CheckForLet()
- {
- register int ch;
- LoadChar(ch);
- if (ch != EOI) {
- if (class(ch) == STIDF) {
- lexerror("token separator required between identifier and number");
- }
- PushBack();
- }
- }
- int
- LLlex()
- {
- /* LLlex() is the Lexical Analyzer.
- The putting aside of tokens is taken into account.
- */
- register t_token *tk = ˙
- char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
- register int ch, nch;
- toktype = error_type;
- if (ASIDE) { /* a token is put aside */
- *tk = aside;
- ASIDE = 0;
- return tk->tk_symb;
- }
- token_nmb++;
- again:
- ch = getch();
- tk->tk_lineno = LineNumber;
- switch (class(ch)) {
- case STNL:
- LineNumber++;
- #ifdef DEBUG
- cntlines++;
- #endif
- CheckForLineDirective();
- goto again;
- case STSKIP:
- goto again;
- case STGARB:
- if ((unsigned) ch - 040 < 0137) {
- lexerror("garbage char %c", ch);
- }
- else lexerror("garbage char \\%03o", ch);
- goto again;
- case STSIMP:
- if (ch == '(') {
- LoadChar(nch);
- if (nch == '*') {
- SkipComment();
- goto again;
- }
- PushBack();
- }
- if (ch == '&') return tk->tk_symb = AND;
- if (ch == '~') return tk->tk_symb = NOT;
- return tk->tk_symb = ch;
- case STCOMP:
- LoadChar(nch);
- switch (ch) {
- case '.':
- if (nch == '.') {
- return tk->tk_symb = UPTO;
- }
- break;
- case ':':
- if (nch == '=') {
- return tk->tk_symb = BECOMES;
- }
- break;
- case '<':
- if (nch == '=') {
- return tk->tk_symb = LESSEQUAL;
- }
- if (nch == '>') {
- return tk->tk_symb = '#';
- }
- break;
- case '>':
- if (nch == '=') {
- return tk->tk_symb = GREATEREQUAL;
- }
- break;
- default :
- crash("(LLlex, STCOMP)");
- }
- PushBack();
- return tk->tk_symb = ch;
- case STIDF:
- {
- register char *tag = &buf[0];
- register t_idf *id;
- do {
- if (tag - buf < idfsize) *tag++ = ch;
- LoadChar(ch);
- if (ch == '_' && *(tag-1) == '_') {
- lexerror("an identifier may not contain two consecutive underscores");
- }
- } while(in_idf(ch));
- PushBack();
- *tag = '\0';
- if (*(tag - 1) == '_') {
- lexerror("last character of an identifier may not be an underscore");
- }
- 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) {
- tk->TOK_INT = *(str->s_str) & 0377;
- toktype = char_type;
- free(str->s_str);
- free((char *) str);
- }
- else {
- tk->tk_data.tk_str = str;
- if (! fit((arith)(str->s_length), (int) word_size)) {
- lexerror("string too long");
- }
- toktype = standard_type(T_STRING, 1, (arith)(str->s_length));
- }
- return tk->tk_symb = STRING;
- }
- case STNUM:
- {
- /* The problem arising with the "parsing" of a number
- is that we don't know the base in advance so we
- have to read the number with the help of a rather
- complex finite automaton.
- */
- enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
- register enum statetp state;
- register int base = 8;
- register char *np = &buf[0];
- *np++ = ch;
- state = is_oct(ch) ? Oct : Dec;
- LoadChar(ch);
- for (;;) {
- switch(state) {
- case Oct:
- while (is_oct(ch)) {
- if (np < &buf[NUMSIZE]) *np++ = ch;
- LoadChar(ch);
- }
- if (ch == 'B' || ch == 'C') {
- state = OctEndOrHex;
- break;
- }
- /* Fall Through */
- case Dec:
- base = 10;
- while (is_dig(ch)) {
- if (np < &buf[NUMSIZE]) {
- *np++ = ch;
- }
- LoadChar(ch);
- }
- if (ch == 'D') state = OptHex;
- else if (is_hex(ch)) state = Hex;
- else if (ch == '.') state = OptReal;
- else {
- state = End;
- if (ch == 'H') base = 16;
- else PushBack();
- }
- break;
- case OptHex:
- LoadChar(ch);
- if (is_hex(ch)) {
- if (np < &buf[NUMSIZE]) *np++ = 'D';
- state = Hex;
- }
- else {
- state = End;
- ch = 'D';
- PushBack();
- }
- break;
- case Hex:
- while (is_hex(ch)) {
- if (np < &buf[NUMSIZE]) *np++ = ch;
- LoadChar(ch);
- }
- base = 16;
- state = End;
- if (ch != 'H') {
- lexerror("H expected after hex number");
- PushBack();
- }
- break;
- case OctEndOrHex:
- if (np < &buf[NUMSIZE]) *np++ = ch;
- LoadChar(ch);
- if (ch == 'H') {
- base = 16;
- state = End;
- break;
- }
- if (is_hex(ch)) {
- state = Hex;
- break;
- }
- PushBack();
- ch = *--np;
- *np++ = '\0';
- /* Fall through */
-
- case End: {
- int ovfl = 0;
- *np = '\0';
- if (np >= &buf[NUMSIZE]) {
- tk->TOK_INT = 1;
- lexerror("constant too long");
- }
- else {
- /* The upperbound will be the same as
- when computed with something like
- max(unsigned long) / base (when base
- is even). The problem is that
- unsigned long or unsigned arith is
- not accepted by all compilers
- */
- arith ubound = max_int[sizeof(arith)]
- / (base >> 1);
- np = &buf[0];
- while (*np == '0') np++;
- tk->TOK_INT = 0;
- while (*np) {
- int c;
- if (is_dig(*np)) {
- c = *np++ - '0';
- }
- else {
- assert(is_hex(*np));
- c = *np++ - 'A' + 10;
- }
- if (tk->TOK_INT < 0 ||
- tk->TOK_INT > ubound) {
- ovfl++;
- }
- tk->TOK_INT = tk->TOK_INT*base;
- if (tk->TOK_INT < 0 &&
- tk->TOK_INT + c >= 0) {
- ovfl++;
- }
- tk->TOK_INT += c;
- }
- }
- toktype = card_type;
- if (ch == 'C' && base == 8) {
- toktype = char_type;
- if (ovfl != 0 || tk->TOK_INT>255 ||
- tk->TOK_INT < 0) {
- lexwarning(W_ORDINARY, "character constant out of range");
- }
- CheckForLet();
- return tk->tk_symb = INTEGER;
- }
- if (options['l']) {
- if (base != 10) {
- LoadChar(ch);
- if (ch != 'D') {
- PushBack();
- }
- }
- }
- if (ch == 'D' && (options['l'] || base == 10)) {
- if (options['l']) {
- /* Local extension: LONGCARD exists,
- so internally also longintorcard_type
- exists.
- */
- toktype = longcard_type;
- if (ovfl == 0 && tk->TOK_INT >= 0 &&
- tk->TOK_INT<=max_int[(int)long_size]) {
- toktype = longintorcard_type;
- }
- else if (! chk_bounds(tk->TOK_INT,
- full_mask[(int)long_size],
- T_CARDINAL)) {
- ovfl = 1;
- }
- }
- else {
- if (ovfl != 0 ||
- tk->TOK_INT > max_int[(int)long_size] ||
- tk->TOK_INT < 0) {
- ovfl = 1;
- }
- toktype = longint_type;
- }
- }
- else if (ovfl == 0 && tk->TOK_INT >= 0 &&
- tk->TOK_INT<=max_int[(int)int_size]) {
- toktype = intorcard_type;
- }
- else if (! chk_bounds(tk->TOK_INT,
- full_mask[(int)int_size],
- T_CARDINAL)) {
- ovfl = 1;
- }
- if (ovfl)
- lexwarning(W_ORDINARY, "overflow in constant");
- CheckForLet();
- return tk->tk_symb = INTEGER;
- }
- case OptReal:
- /* The '.' could be the first of the '..'
- token. At this point, we need a
- look-ahead of two characters.
- */
- LoadChar(ch);
- if (ch == '.') {
- /* Indeed the '..' token
- */
- PushBack();
- PushBack();
- state = End;
- base = 10;
- break;
- }
- state = Real;
- break;
- }
- if (state == Real) break;
- }
- /* a real real constant */
- if (np < &buf[NUMSIZE]) *np++ = '.';
- toktype = real_type;
- while (is_dig(ch)) {
- /* Fractional part
- */
- if (np < &buf[NUMSIZE]) *np++ = ch;
- LoadChar(ch);
- }
- if (ch == 'D') {
- toktype = longreal_type;
- LoadChar(ch);
- if (ch == '+' || ch == '-' || is_dig(ch)) {
- ch = 'E';
- PushBack();
- }
- }
- if (ch == 'E') {
- /* Scale factor
- */
- if (np < &buf[NUMSIZE]) *np++ = ch;
- LoadChar(ch);
- if (ch == '+' || ch == '-') {
- /* Signed scalefactor
- */
- 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));
- }
- else {
- lexerror("bad scale factor");
- }
- }
- *np++ = '\0';
- PushBack();
- tk->tk_data.tk_real = new_real();
- if (np >= &buf[NUMSIZE]) {
- tk->TOK_RSTR = Salloc("0.0", 4);
- lexerror("real constant too long");
- }
- else tk->TOK_RSTR = Salloc(buf, (unsigned) (np - buf));
- CheckForLet();
- flt_str2flt(tk->TOK_RSTR, &(tk->TOK_RVAL));
- if (flt_status == FLT_OVFL) {
- lexwarning(W_ORDINARY, "overflow in floating point constant");
- }
- return tk->tk_symb = REAL;
- /*NOTREACHED*/
- }
- case STEOI:
- return tk->tk_symb = -1;
- case STCHAR:
- default:
- crash("(LLlex) Impossible character class");
- /*NOTREACHED*/
- }
- /*NOTREACHED*/
- }
|