user/a60/a60-scan.c

   1 /*
   2  * Copyright (C) 1991,1992 Erik Schoenfelder (schoenfr@ibr.cs.tu-bs.de)
   3  *
   4  * This file is part of NASE A60.
   5  *
   6  * NASE A60 is free software; you can redistribute it and/or modify it
   7  * under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2, or (at your option)
   9  * any later version.
  10  *
  11  * NASE A60 is distributed in the hope that it will be useful, but
  12  * WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14  * General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with NASE A60; see the file COPYING.  If not, write to the Free
  18  * Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19  *
  20  * a60-scan.c:                                          oct '90
  21  *
  22  * Erik Schoenfelder (schoenfr@ibr.cs.tu-bs.de)
  23  *
  24  * The Algol 60 scanner.
  25  *
  26  * a big hack includes the scanning of non quoted keywords:
  27  *              begin  vprint ("nase")  end
  28  * this cannot be used within identifiers with white spaces:
  29  *      bad:    begin  integer foo bar; end
  30  *      ok:     begin  integer foobar; end
  31  *
  32  * so scan_strict is set, if a60_strict is set, or if a quoted begin
  33  * is found.
  34  */
  35
  36 #include "comm.h"
  37 #include "a60.h"
  38 #include "util.h"
  39 #include "a60-ptab.h"
  40 #include "a60-scan.h"
  41
  42
  43 /*
  44  * the linenumber of the scanner; reported as lineno is the last seen
  45  * line; (delay for the look-ahead-token)
  46  */
  47
  48 static int scan_lineno;
  49
  50
  51 /*
  52  * character test and conversion.
  53  */
  54 #define mischar(c)      (((c) >= 'a' && (c) <= 'z') \
  55                          || ((c) >= 'A' && (c) <= 'Z'))
  56 #define misdigit(c)     ((c) >= '0' && (c) <= '9')
  57 #define misupper(c)     ((c) >= 'A' && (c) <= 'Z')
  58 #define mtolower(c)     (misupper(c) ? (c) - 'A' + 'a' : (c))
  59 #define mprintable(c)   ((c) >= 32 && (c) <= 126)
  60
  61
  62 /*
  63  *  forwards:
  64  */
  65 static int scan_exp ();
  66 static void skip_following_comment ();
  67 static void skip_end_comment ();
  68 static void skip_over_whites ();
  69 static int s_getchar ();
  70 static void s_unput ();
  71
  72
  73 /*
  74  * error reporting:
  75  */
  76 static char *yytext;
  77 static int yylen;
  78 static int yyidx;
  79
  80
  81 /*
  82  * translate a string into a readable ascii form:
  83  */
  84
  85 static char *
  86 asc_str (s, len)
  87 char *s;
  88 int len;
  89 {
  90         static char *buf = (char *) 0;
  91         char *ptr;
  92
  93         if (len < 0)
  94                 len = strlen (s);
  95
  96         if (buf) {
  97                 xfree (buf);
  98                 buf = (char *) 0;
  99         }
 100
 101         if (! s || ! *s)
 102                 return "EOF";
 103
 104         /* maximum is a two char escape-sequence for one input char: */
 105         buf = xmalloc ((long) (2 * strlen (s) + 1));
 106
 107         for (ptr = buf; len > 0; s++, ptr++, len--) {
 108
 109                 if (*s == '\n')
 110                         *ptr++ = '\\', *ptr = 'n';
 111                 else if (*s == '\r')
 112                         *ptr++ = '\\', *ptr = 'r';
 113                 else if (mprintable (*s))
 114                         *ptr = *s;
 115                 else if (*s == '\0')
 116                         *ptr++ = '^', *ptr = '@';
 117                 else if (*s >= 1 && *s <= 26)
 118                         *ptr++ = '^', *ptr = 'A' + *s - 1;
 119                 else
 120                         *ptr = '.';
 121         }
 122
 123         *ptr = 0;
 124
 125         return buf;
 126 }
 127
 128 /*
 129  * return a printable string for a single char:
 130  */
 131
 132 static char *
 133 ch_str (ch)
 134 int ch;
 135 {
 136         char tmp [1];
 137
 138         tmp [0] = ch;
 139
 140         return asc_str (tmp, 1);
 141 }
 142
 143
 144 /*
 145  * give a readable string of the scanned input.
 146  */
 147
 148 static char *
 149 s_text (yytext)
 150 char *yytext;
 151 {
 152         static char *rval = (char *) 0;
 153
 154         if (rval) {
 155                 xfree (rval);
 156                 rval = (char *) 0;
 157         }
 158
 159         rval = xstrdup (asc_str (yytext, -1));
 160
 161         return rval;
 162 }
 163
 164
 165 void
 166 yyerror(s)
 167 char *s;
 168 {
 169         nerrors++;
 170         /*
 171          * if there is a ``parse error'' or a ``syntax error''
 172          * reported from the skeleton, print the scanned string too.
 173          */
 174         if (! strcmp (s, "parse error")
 175             || ! strcmp (s, "syntax error")) {
 176                 yytext [yyidx] = 0;
 177                 a60_error (infname, lineno, "%s (scanned: %s)\n",
 178                            s, s_text (yytext));
 179                 return;
 180         }
 181         a60_error (infname, lineno, "%s\n", s);
 182 }
 183
 184 void
 185 yywarning (s)
 186 char *s;
 187 {
 188         a60_error (infname, lineno, "warning: %s\n", s);
 189 }
 190
 191
 192 /*
 193  * the keywords. (they are expected to be enclosed in ').
 194  */
 195
 196 #define fstrcmp(a, b) \
 197         (*(a) != *(b) || strcmp (a, b))
 198
 199
 200 static KEYWORD
 201 keywords[] = {
 202
 203         { "10",                 TTEN },
 204         { "and",                TAND },
 205         { "array",              TARRAY },
 206         { "begin",              TBEGIN },
 207         { "boolean",            TBOOL },
 208         { "code",               TCODE },
 209 /***    { "comment",            TCOMMENT }, ***/
 210         { "div",                TDIV },
 211         { "do",                 TDO },
 212         { "else",               TELSE },
 213         { "end",                TEND },
 214         { "equal",              TEQUAL },
 215         { "equiv",              TEQUIV },
 216         { "false",              TFALSE },
 217         { "for",                TFOR },
 218         { "goto",               TGOTO },
 219         { "greater",            TGREATER },
 220         { "if",                 TIF },
 221         { "impl",               TIMPL },
 222         { "integer",            TINTEGER },
 223         { "label",              TLABEL },
 224         { "less",               TLESS },
 225         { "not",                TNOT },
 226         { "notequal",           TNOTEQUAL },
 227         { "notgreater",         TNOTGREATER },
 228         { "notless",            TNOTLESS },
 229         { "or",                 TOR },
 230         { "own",                TOWN },
 231         { "pow",                TPOW },
 232         { "procedure",          TPROC },
 233         { "real",               TREAL },
 234         { "step",               TSTEP },
 235         { "string",             TSTRING },
 236         { "switch",             TSWITCH },
 237         { "then",               TTHEN },
 238         { "true",               TTRUE },
 239         { "until",              TUNTIL },
 240         { "value",              TVALUE },
 241         { "while",              TWHILE },
 242         { "",                   0 }
 243 };
 244
 245
 246 /*
 247  * look for a keyword in the keyword table; if found, return the token,
 248  * if not found return 0.
 249  */
 250
 251 static int
 252 get_keyword (s)
 253 char *s;
 254 {
 255         KEYWORD *kp;
 256         char *lower_str;
 257         int i;
 258
 259         lower_str = xmalloc ((long) strlen (s) + 1);
 260         for (i = 0; i < strlen (s); i++)
 261                 lower_str [i] = mtolower(s[i]);
 262
 263         lower_str [i] = 0;
 264
 265         for (kp = keywords; kp->name && *kp->name; kp++)
 266                 if (! fstrcmp (lower_str, kp->name))
 267                         break;
 268
 269         xfree (lower_str);
 270
 271         return kp->token;
 272 }
 273
 274
 275 /*
 276  * the special strings; short constant strings, but no (real) keywords.
 277  */
 278
 279 #define MAX_SPEC        2       /* maximum length of a special */
 280
 281 static KEYWORD
 282 special [] = {
 283
 284         { "+",  '+' },  { "-",  '-' },
 285         { "*",  '*' },  { "/",  '/' },
 286         { ",",  ',' },  { ".",  '.' },
 287         { ";",  ';' },  { "(",  '(' },
 288         { ")",  ')' },  { ":",  ':' },
 289         { "[",  '[' },  { "]",  ']' },
 290         { "..", ':' },  { "(/", '[' },
 291         { "/)", ']' },
 292         { ">",          TGREATER },
 293         { ">=",         TNOTLESS },
 294         { "<",          TLESS },
 295         { "<=",         TNOTGREATER },
 296         { "=",          TEQUAL },
 297         { "!=",         TNOTEQUAL },
 298         { ":=",         TASSIGN },
 299         { ".=",         TASSIGN },
 300         { "**",         TPOW },
 301         { "^",          TPOW },
 302         { "",           0 }
 303 };
 304
 305 /*
 306  * skip white spaces:
 307  */
 308
 309 static int skip_white;
 310
 311 /*
 312  * current linenumber.
 313  */
 314
 315 int lineno;
 316
 317 /*
 318  * the input buffer:
 319  */
 320
 321 static char *inbuf, *ib_ptr;
 322 static int ib_max, ib_len, ib_eof;
 323
 324 /*
 325  * character test (and conversion).
 326  */
 327
 328 static int
 329 is_char (c)
 330 int c;
 331 {
 332         return mischar(c);
 333 }
 334
 335 static int
 336 is_digit (c)
 337 int c;
 338 {
 339         return misdigit(c);
 340 }
 341
 342 static int
 343 is_white (c)
 344 int c;
 345 {
 346         if (c == ' ' || c == '\t' || c == '\r' || c == '\n')
 347                 return 1;
 348
 349         return 0;
 350 }
 351
 352
 353 /*
 354  * case insensitive strncmp:
 355  */
 356
 357 static int
 358 ci_strncmp (s1, s2, n)
 359 char *s1, *s2;
 360 int n;
 361 {
 362         if (! s1 && ! s2)
 363                 return 0;
 364         if (! s1 || ! s2)
 365                 return 1;
 366         if (n <= 0)
 367                 return 0;
 368
 369         for (; n > 0; s1++, s2++, n--) {
 370
 371                 if (mtolower(*s1) != mtolower(*s2))
 372                         return 1;
 373         }
 374
 375         return 0;
 376 }
 377
 378
 379 /*
 380  * return 10 power n:
 381  */
 382
 383 double
 384 pow10 (n)
 385 int n;
 386 {
 387         int rev = 0;
 388         double result = 1.0;
 389
 390         if (n < 0) {
 391                 rev = 1;
 392                 n = - n;
 393         }
 394
 395         /* hmmmmm - what to do ... */
 396         if (n > 10000)
 397                 n = 10000;
 398
 399         while (n > 0) {
 400                 result *= 10.0;
 401                 n = n - 1;
 402         }
 403
 404         if (rev)
 405                 return 1.0 / result;
 406         else
 407                 return result;
 408 }
 409
 410
 411 /*
 412  * called one time for initialisation.
 413  */
 414
 415 void
 416 init_lex ()
 417 {
 418         int c;
 419
 420         /*
 421          * allocate the input buffer and the error-text buffer (yytext):
 422          */
 423
 424         ib_max = 100;
 425         inbuf = xmalloc ((long) ib_max);
 426         ib_len = 0;
 427         ib_ptr = inbuf;
 428         ib_eof = 0;
 429
 430         yytext = xmalloc ((long) 100);
 431         yylen = 100;
 432         yyidx = 0;
 433
 434         scan_lineno = lineno = 1;
 435
 436         /*
 437          * skip leading whites; the following quote decides...
 438          */
 439
 440         c = s_getchar ();
 441         skip_over_whites (c);
 442
 443         c = s_getchar ();
 444         if (c == '\'') {
 445                 if (verbose)
 446                         fprintf (stderr, "will scan in strict a60 manner.\n");
 447                 scan_strict = 1;
 448         }
 449
 450         s_unput (c);            /* flush back */
 451
 452         skip_white = scan_strict;
 453 }
 454
 455
 456 static void
 457 expand_inbuf (n)
 458 int n;
 459 {
 460         int ib_offset = (int) (ib_ptr - inbuf);         /* offset into inbuf */
 461
 462         ib_max += n;
 463 #ifdef DEBUG
 464         if (do_debug)
 465                 printf ("++ inbuf expanded to %ld bytes.\n", (long) ib_max);
 466 #endif /* DEBUG */
 467         inbuf = xrealloc (inbuf, (long) ib_max);
 468
 469         ib_ptr = inbuf + ib_offset;
 470 }
 471
 472
 473 static void
 474 fill_inbuf (n)
 475 int n;
 476 {
 477         int c, i;
 478         char *fill_ptr;
 479
 480         if (ib_eof)
 481                 return;
 482
 483         if (ib_ptr != inbuf) {
 484                 /*
 485                  * cleanup buffer ptr:
 486                  */
 487
 488                 for (i = 0; i < ib_len; i++)
 489                         inbuf [i] = ib_ptr [i];
 490                 ib_ptr = inbuf;
 491         }
 492
 493         fill_ptr = ib_ptr + ib_len;
 494
 495         for (i = 0; i < n; i++) {
 496
 497                 if (ib_ptr + ib_len + 2 >= inbuf + ib_max)
 498                         expand_inbuf (n + 10);
 499
 500                 c = fgetc (infile);
 501
 502                 if (c == EOF) {
 503                         ib_eof = 1;
 504                         break;
 505                 }
 506                 else {
 507                         *fill_ptr++ = c;
 508                         ib_len++;
 509                 }
 510         }
 511 }
 512
 513
 514 /*
 515  * return the next input character; return 0 at eof.
 516  * skip whites, if skip_white == 1;
 517  */
 518
 519 static int
 520 s_getchar ()
 521 {
 522         int c = 0;
 523
 524         for (;;) {
 525
 526                 if (! ib_eof && ib_len == 0)
 527                         fill_inbuf (1);
 528
 529                 if (ib_eof && ib_len == 0)
 530                         return 0;
 531
 532                 ib_len--;
 533                 c = *ib_ptr;
 534                 ib_ptr++;
 535
 536                 if (is_white (c)) {
 537                         if (c == '\n')
 538                                 scan_lineno++;
 539                         if (! skip_white)
 540                                 break;
 541                 }
 542                 else
 543                         break;
 544         }
 545
 546         if (yyidx + 2 >= yylen) {
 547                 yylen += 100;
 548                 yytext = xrealloc (yytext, (long) yylen);
 549         }
 550         yytext [yyidx++] = c;
 551
 552 #ifdef DEBUG
 553         if (do_debug) {
 554                 printf ("++ s_getchar: next one: `%s'   (scan_lineno %d)\n",
 555                         ch_str (c), scan_lineno);
 556         }
 557 #endif
 558
 559         return c;
 560 }
 561
 562
 563 static void
 564 s_unput (c)
 565 int c;
 566 {
 567         int i;
 568
 569         /* expand about 2 or 3 characters ... (don't care)
 570            one for the unget char and one for a trailing '\0'
 571            (better for debugging) */
 572
 573         if (ib_ptr + ib_len + 3 >= inbuf + ib_max)
 574                 expand_inbuf (3);
 575
 576         if (ib_ptr == inbuf) {
 577                 /*
 578                  * shift one char to right.
 579                  * (the + 1 is for a trailing 0)
 580                  */
 581                 for (i = ib_len + 1; i > 0; i--)
 582                         inbuf [i] = inbuf [i-1];
 583                 ib_ptr++;
 584         }
 585
 586         ib_len++; ib_ptr--;
 587         *ib_ptr = c;
 588
 589         if (yyidx > 0)
 590                 yyidx--;
 591
 592         if (c == '\n')
 593                 scan_lineno--;
 594
 595 #ifdef DEBUG
 596         if (do_debug) {
 597                 printf ("++ s_unput (%c): ib_len %d ; ib now `", c, ib_len);
 598                 for (i = 0; i < ib_len; i++)
 599                         printf ("%c", ib_ptr [i]);
 600                 printf ("' - honk.\n");
 601         }
 602 #endif /* DEBUG */
 603 }
 604
 605
 606 /*
 607  * scan a whitespace;
 608  */
 609
 610 static int
 611 scan_white (c)
 612 int c;
 613 {
 614         return is_white (c);
 615 }
 616
 617
 618 /*
 619  * skip over whites;
 620  */
 621
 622 static void
 623 skip_over_whites (c)
 624 int c;
 625 {
 626         while (is_white (c))
 627                 c = s_getchar ();
 628
 629         s_unput (c);
 630 }
 631
 632
 633 /*
 634  * still scanned a quote ('); look for keyword.
 635  * no keyword is longer than 10 chars ('notgreater'). lets scan max
 636  * 20 chars for some context in the yytext string.
 637  */
 638
 639 static int
 640 scan_keyword ()
 641 {
 642 #define KW_MAX  20
 643         char keyw [KW_MAX];
 644         int kw_len = 0, kwt, c;
 645
 646 #ifdef DEBUG
 647         if (do_debug)
 648                 printf ("++ looking for keyword ...\n");
 649 #endif /* DEBUG */
 650
 651         while ((c = s_getchar ()) != 0) {
 652
 653                 if (scan_white (c))
 654                         continue;
 655
 656                 if (c == '\'')
 657                         break;
 658
 659                 if (kw_len + 2 >= KW_MAX)
 660                         break;
 661
 662                 keyw [kw_len++] = c;
 663         }
 664
 665         keyw [kw_len] = 0;
 666
 667         kwt = get_keyword (keyw);
 668
 669         /*
 670          * reported (hopefully) by parser-module:
 671          *
 672          * if (! kwt) {
 673          *      yyerror ("unknown keyword");
 674          * }
 675          */
 676
 677 #ifdef DEBUG
 678         if (do_debug)
 679                 printf ("++ got %d from `%s'\n", kwt, keyw);
 680 #endif /* DEBUG */
 681
 682         if (kwt == TBEGIN)
 683                 skip_following_comment ();
 684
 685         if (kwt == TEND)
 686                 skip_end_comment (1);                   /* quotes active */
 687
 688         return kwt;
 689 }
 690
 691
 692 static int
 693 scan_string ()
 694 {
 695         static int st_max = 0;
 696         static char *str;
 697         int st_len = 0, c, level = 1, krach = 0;
 698
 699 #ifdef DEBUG
 700         if (do_debug)
 701                 printf ("++ looking for string ...\n");
 702 #endif /* DEBUG */
 703
 704         skip_white = 0;
 705
 706         while ((c = s_getchar ()) != 0) {
 707
 708                 if (! krach && (c == '\'' || c == '"'))
 709                         level--;
 710                 else if (! krach && c == '`')
 711                         level++;
 712
 713                 if (! level)
 714                         break;
 715
 716                 if (st_len + 2 >= st_max) {
 717                         st_max += 10;
 718                         if (! str)
 719                                 str = xmalloc ((long) st_max);
 720                         else
 721                                 str = xrealloc (str, (long) st_max);
 722                 }
 723                 if (krach) {
 724                         if (c == 'n')           c = '\n';
 725                         else if (c == 't')      c = '\t';
 726                         else if (c == '"')      c = '"';
 727                         else if (c == '\'')     c = '\'';
 728                         else if (c == '`')      c = '`';
 729                         str [st_len++] = c;
 730                         krach = 0;
 731                 }
 732                 else if (c == '\\')
 733                         krach = 1;
 734                 else
 735                         str [st_len++] = c;
 736         }
 737
 738         str [st_len] = 0;
 739
 740 #ifdef DEBUG
 741         if (do_debug)
 742                 printf ("++ found `%s'.\n", str);
 743 #endif /* DEBUG */
 744
 745         skip_white = scan_strict;
 746
 747         yylval.str = xstrdup (str);
 748
 749         return STRING;
 750 }
 751
 752
 753 static int
 754 scan_identifier (ch)
 755 int ch;
 756 {
 757         static int id_max = 0;
 758         static char *ident;
 759         int id_len = 0, c;
 760
 761 #ifdef DEBUG
 762         if (do_debug)
 763                 printf ("++ looking for identifier ...\n");
 764 #endif /* DEBUG */
 765
 766         s_unput (ch);
 767
 768         while ((c = s_getchar ()) != 0) {
 769
 770                 if (is_white (c)) {
 771                         if (skip_white)
 772                                 continue;
 773                         else {
 774                                 skip_over_whites (c);
 775                                 break;
 776                         }
 777                 }
 778                 if (! is_char (c) && ! is_digit (c)) {
 779                         s_unput (c);
 780                         break;
 781                 }
 782
 783                 if (id_len + 2 >= id_max) {
 784                         id_max += 10;
 785                         if (! ident)
 786                                 ident = xmalloc ((long) id_max);
 787                         else
 788                                 ident = xrealloc (ident, (long) id_max);
 789                 }
 790                 ident [id_len++] = c;
 791         }
 792
 793         ident [id_len] = 0;
 794
 795 #ifdef DEBUG
 796         if (do_debug)
 797                 printf ("++ found `%s'.\n", ident);
 798 #endif /* DEBUG */
 799
 800         if (! scan_strict) {
 801                 /* how to parse:  begin integer a nase; end */
 802
 803                 /*
 804                  * if the string is a keyword, then return the keyword-token
 805                  */
 806
 807                 int kwt = get_keyword (ident);
 808                 if (kwt) {
 809
 810                         if (kwt == TBEGIN)
 811                                 skip_following_comment ();
 812
 813                         if (kwt == TEND)
 814                                 skip_end_comment (0);
 815
 816                         return kwt;
 817                 }
 818         }
 819
 820         /* found an identifier: */
 821
 822         yylval.str = xstrdup (ident);
 823
 824         return NAME;
 825 }
 826
 827
 828 /*
 829  * scan the fractional part; num is the full (sp?) part.
 830  */
 831
 832 static int
 833 scan_frac (num)
 834 long num;
 835 {
 836         double rval = num;
 837         double frac = 0, pot = 10;
 838         int c;
 839
 840         while (is_digit (c = s_getchar ())) {
 841                 frac = frac + (c - '0') / pot;
 842                 pot = pot * 10;
 843         }
 844
 845         if (c == 'e' || c == 'E')
 846                 return scan_exp (rval + frac);
 847
 848
 849         /* ok - still scanned a real value: */
 850
 851 #ifdef DEBUG
 852         if (do_debug)
 853                 printf ("++ got real %e\n", (double) rval + frac);
 854 #endif /* DEBUG */
 855
 856         s_unput (c);
 857
 858         yylval.rtype = rval + frac;
 859
 860         return RNUM;
 861 }
 862
 863
 864 /*
 865  * scan the exponential part; if it is expressed as X '10' Y its done in
 866  * a60-parse.y; here a additional form X e Y (or X E Y) is scanned.
 867  */
 868
 869 static int
 870 scan_exp (num)
 871 double num;
 872 {
 873         double rval = num;
 874         int rsign = 1;
 875         int exp_val = 0, c;
 876
 877         c = s_getchar ();
 878
 879         if (c == '+') {
 880                 c = s_getchar ();
 881         }
 882         else if (c == '-') {
 883                 rsign = -1;
 884                 c = s_getchar ();
 885         }
 886
 887         if (! is_digit (c)) {
 888                 a60_error (infname, lineno, "malformed exponent.\n");
 889         }
 890         else {
 891                 /* scan the exponent : */
 892
 893                 do {
 894                         exp_val = 10 * exp_val + c - '0';
 895                 } while (is_digit (c = s_getchar ()));
 896
 897                 rval = rval * pow10 (rsign * exp_val);
 898         }
 899
 900
 901 #ifdef DEBUG
 902         if (do_debug)
 903                 printf ("++ got real %e\n", (double) rval);
 904 #endif /* DEBUG */
 905
 906         s_unput (c);
 907
 908         yylval.rtype = rval;
 909
 910         return RNUM;
 911 }
 912
 913
 914 /*
 915  * here we have a dot or a digit:
 916  */
 917
 918 static int
 919 scan_number (ch)
 920 int ch;
 921 {
 922         int c;
 923         long ival = 0;
 924
 925 #ifdef DEBUG
 926         if (do_debug)
 927                 printf ("++ looking for number...\n");
 928 #endif /* DEBUG */
 929
 930         if (ch == '.')
 931                 return scan_frac ((long) 0);
 932
 933         s_unput (ch);
 934
 935         while (is_digit (c = s_getchar ()))
 936                 ival = 10 * ival + c - '0';
 937
 938         if (c == '.')
 939                 return scan_frac ((long) ival);
 940
 941         if (c == 'e' || c == 'E')
 942                 return scan_exp ((double) ival);
 943
 944         /* ok - still scanned a integer value: */
 945
 946 #ifdef DEBUG
 947         if (do_debug)
 948                 printf ("++ got integer %ld\n", (long) ival);
 949 #endif /* DEBUG */
 950
 951         s_unput (c);
 952
 953         yylval.itype = ival;
 954
 955         return INUM;
 956 }
 957
 958
 959
 960 /*
 961  * handle this unknown char; skip input til end-of-line.
 962  */
 963
 964 void
 965 skip_unknown (ch)
 966 int ch;
 967 {
 968         static int last_line = -1;
 969
 970         if (last_line == lineno)
 971                 return;
 972         else
 973                 last_line = lineno;
 974
 975 #if 0
 976         if (yyidx)
 977                 yytext [yyidx] = 0;
 978
 979         if (mprintable(ch)) {
 980
 981                 if (yyidx)
 982                         a60_error (infname, lineno,
 983                                 "unknown char `%c' found (scanned: %s).\n",
 984                                 ch, yytext);
 985                 else
 986                         a60_error (infname, lineno,
 987                                 "unknown char `%c' found.\n", ch);
 988         }
 989         else {
 990                 if (yyidx)
 991                         a60_error (infname, lineno,
 992                                 "unknown char 0x%02x found (scanned: %s).\n",
 993                                 ch, yytext);
 994                 else
 995                         a60_error (infname, lineno,
 996                                 "unknown char 0x%02x found.\n", ch);
 997         }
 998 #else
 999         yyerror ("syntax error");
1000 #endif
1001         a60_error (infname, lineno, "  [ skipping to next line ]\n");
1002
1003         nerrors++;
1004
1005         skip_white = 0;
1006
1007         do {
1008                 ch = s_getchar ();
1009         } while (ch && ch != '\n');
1010
1011         skip_white = scan_strict;
1012 }
1013
1014
1015 /*
1016  * we've found a ';' or a 'begin'; now look about a following comment
1017  * and skip, if found, to the next semicolon.
1018  */
1019
1020 static void
1021 skip_following_comment ()
1022 {
1023         char *str = xmalloc ((long) 100);
1024         long str_max = 100;
1025         int str_len = 0, quoted_comment = 0;
1026         int c;
1027
1028 #ifdef DEBUG
1029         if (do_debug)
1030                 printf ("++ looking for 'comment'...\n");
1031 #endif /* DEBUG */
1032
1033         c = s_getchar ();
1034
1035         if (! scan_strict) {
1036                 skip_over_whites (c);
1037                 c = s_getchar ();
1038         }
1039
1040         quoted_comment = (c == '\'');
1041
1042         if (scan_strict && ! quoted_comment) {
1043 #ifdef DEBUG
1044                 if (do_debug)
1045                         printf ("++ no 'comment'.\n");
1046 #endif /* DEBUG */
1047                 s_unput (c);
1048                 return;
1049         }
1050
1051         do {
1052                 if (str_len + 2 >= str_max) {
1053                         str_max += 100;
1054                         str = xrealloc (str, str_max);
1055                 }
1056                 str [str_len++] = c; /*** mtolower (c); ***/
1057                 c = s_getchar ();
1058
1059                 if (! c)
1060                         break;
1061
1062         } while ((quoted_comment && c != '\'')
1063                  || (! quoted_comment && c != 't'
1064                      && str_len != 6 && ci_strncmp ("commen", str, 6)));
1065
1066         str [str_len++] = c;
1067         str [str_len] = '\0';
1068
1069 #ifdef DEBUG
1070         if (do_debug)
1071                 printf ("++ examining `%s'...\n", asc_str (str, -1));
1072 #endif /* DEBUG */
1073
1074         if ((quoted_comment && ! ci_strncmp (str+1, "comment", 7))
1075             || ! ci_strncmp ("comment", str, 7)) {
1076                 /*
1077                  * well done; skip anything til a ';':
1078                  */
1079 #ifdef DEBUG
1080                 if (do_debug)
1081                         printf ("++ skipping 'comment': `");
1082 #endif /* DEBUG */
1083                 while ((c = s_getchar ()) != ';') {
1084 #ifdef DEBUG
1085                         if (do_debug)
1086                                 printf ("%s", ch_str (c));
1087 #else /* ! DEBUG */
1088                         continue;
1089 #endif /* ! DEBUG */
1090                 }
1091
1092 #ifdef DEBUG
1093                 if (do_debug)
1094                         printf ("' skipped.\n");
1095 #endif /* DEBUG */
1096
1097                 /*
1098                  * now do this again...
1099                  */
1100                 xfree (str);
1101                 skip_following_comment ();
1102                 return;
1103         }
1104         else {
1105                 /*
1106                  * no comment; unget and forget:
1107                  */
1108 #ifdef DEBUG
1109                 if (do_debug)
1110                         printf ("++ forgetting `%s'...\n",
1111                                 asc_str (str, str_len));
1112 #endif /* DEBUG */
1113                 while (str_len > 0)
1114                         s_unput (str [--str_len]);
1115
1116                 xfree (str);
1117         }
1118 }
1119
1120
1121 /*
1122  * scan the end of the string for and 'end' delimiter: 'end' or 'else'
1123  * or ';'; return an ptr to the first char.
1124  */
1125
1126 static char *
1127 end_delim (str, str_len, quoted_comment)
1128 char *str;
1129 int str_len;
1130 int quoted_comment;
1131 {
1132         static char *e_delim [4];
1133         char **ptr, *str_ptr;
1134
1135         e_delim [0] = ";";
1136         if (quoted_comment)
1137                 e_delim [1] = "'end'",  e_delim [2] = "'else'";
1138         else
1139                 e_delim [1] = "end",    e_delim [2] = "else";
1140         e_delim [3] = "";
1141
1142 #ifdef DEBUG
1143         if (do_debug)
1144                 printf ("++ looking for end_delim in `%s': ", str);
1145 #endif /* DEBUG */
1146
1147         for (ptr = e_delim; ptr && *ptr && **ptr; ptr++) {
1148                 str_ptr = str + str_len - strlen (*ptr);
1149                 if (str_ptr >= str &&
1150                     ! strncmp (str_ptr, *ptr, strlen (*ptr))) {
1151 #ifdef DEBUG
1152                         if (do_debug)
1153                                 printf (" found %s.\n", *ptr);
1154 #endif /* DEBUG */
1155                         return str_ptr;
1156                 }
1157         }
1158
1159 #ifdef DEBUG
1160         if (do_debug)
1161                 printf (" not found.\n");
1162 #endif /* DEBUG */
1163
1164         return (char *) 0;
1165 }
1166
1167
1168 /*
1169  * got a 'end'; now skip anything until 'end' or 'else' or ';':
1170  */
1171
1172 static void
1173 skip_end_comment (quoted_comment)
1174 int quoted_comment;
1175 {
1176         char *str = xmalloc ((long) 10);
1177         long str_max = 10;
1178         int str_len = 0;
1179         char *end_str = str, *ptr;
1180         int c;
1181
1182 #ifdef DEBUG
1183         if (do_debug)
1184                 printf ("++ looking for 'end' comment...\n");
1185 #endif /* DEBUG */
1186
1187         while ((c = s_getchar ()) != 0) {
1188
1189                 if (str_len + 2 >= str_max) {
1190                         str_max += 10;
1191                         str = xrealloc (str, str_max);
1192                 }
1193                 str [str_len++] = mtolower (c);
1194                 str [str_len] = 0;
1195
1196                 end_str = end_delim (str, str_len, quoted_comment);
1197                 if (end_str)
1198                         break;
1199         }
1200
1201 #if 0
1202         if (! c && str_len > 0) {
1203                 yyerror ("EOF reached within 'end' ...");
1204         }
1205         else
1206 #endif
1207         {
1208                 str [str_len] = 0;
1209
1210                 if (end_str) {
1211 #ifdef DEBUG
1212                         if (do_debug)
1213                                 printf ("++ found behind 'end': `%s'\n",
1214                                         asc_str (str, str_len));
1215 #endif /* DEBUG */
1216                         for (ptr = str+str_len-1; ptr >= end_str; ptr--)
1217                                 s_unput (*ptr);
1218                 }
1219         }
1220 }
1221
1222
1223 /*
1224  * scan a special; two or one char long.
1225  */
1226
1227 static int
1228 scan_special (ch)
1229 int ch;
1230 {
1231         KEYWORD *kw;
1232         char str [MAX_SPEC+1];
1233         int i, tok, max_spec_len;
1234
1235         str [0] = ch;
1236
1237         for (i=1; i<MAX_SPEC; i++) {
1238                 str [i] = s_getchar ();
1239                 if (is_white (str [i])) {
1240                         s_unput (str [i]);
1241                         break;
1242                 }
1243         }
1244         str [i] = '\0';
1245         max_spec_len = i;
1246
1247 #ifdef DEBUG
1248         if (do_debug)
1249                 printf ("++ looking for special `%s'...\n", str);
1250 #endif /* DEBUG */
1251
1252         for (i = max_spec_len; i > 0; i--) {
1253                 for (kw = special; kw->name && *kw->name; kw++) {
1254                         if (! strncmp (kw->name, str, i)) {
1255                                 tok = kw->token;
1256 #ifdef DEBUG
1257                                 if (do_debug)
1258                                         printf ("++ got special %d\n", tok);
1259 #endif /* DEBUG */
1260                                 if (tok == ';')
1261                                         skip_following_comment ();
1262                                 return tok;
1263                         }
1264                 }
1265                 if (i > 1)
1266                         s_unput (str [i-1]);
1267         }
1268
1269         /* Oops - what to do... */
1270
1271         if (! str [0])
1272                 return 0;
1273
1274         skip_unknown (str[0]);
1275
1276         return yylex ();
1277 }
1278
1279
1280 /*
1281  * the common yylex entry;
1282  * return's the token number or 0 on end of file
1283  */
1284
1285 int
1286 yylex ()
1287 {
1288         static int last_scan_lineno = 1;
1289         int ch, tok;
1290
1291         yyidx = 0;
1292
1293         if (ib_eof && ib_len == 0) {
1294 #ifdef DEBUG
1295                 if (do_debug)
1296                         printf ("+++ EOF reached...\n");
1297 #endif /* DEBUG */
1298                 return 0;
1299         }
1300
1301         ch = s_getchar ();
1302
1303         if (! scan_strict) {
1304                 skip_over_whites (ch);
1305                 ch = s_getchar ();
1306         }
1307
1308         if (ch == '\'')
1309                 tok = scan_keyword ();
1310         else if (ch == '`' || ch == '"')
1311                 tok = scan_string ();
1312         else if (is_char (ch))
1313                 tok = scan_identifier (ch);
1314         else if (is_digit (ch) || ch == '.')
1315                 tok = scan_number (ch);
1316         else if (ch)
1317                 tok = scan_special (ch);
1318         else
1319                 tok = 0;
1320
1321 #ifdef DEBUG
1322         if (do_debug) {
1323                 if (tok >= 0 && tok <= 256)
1324                         printf ("+++ yylex: returnig token %d (`%s')\n",
1325                                 tok, ch_str (tok));
1326                 else
1327                         printf ("+++ yylex: returnig token %d\n", tok);
1328         }
1329 #endif /* DEBUG */
1330
1331         lineno = last_scan_lineno;
1332         last_scan_lineno = scan_lineno;
1333
1334         return tok;
1335 }
1336
1337 /* end of a60-scan.c */
1338