(* Copyright (C) 1989, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* File: Scanner.m3                                            *)
(* Last modified on Tue Feb 20 23:01:28 1990 by muller         *)
(*      modified on Wed Feb 14 09:01:14 1990 by kalsow         *)



UNSAFE MODULE Scanner;

IMPORT Error, String, Token, Rd, UnsafeRd, Text;

CONST
  MaxFiles  = 100;
  MaxStack  = 40;
  MaxLines  = 100000;
  MaxString = 4095;
  EOFChar   = '\000';

TYPE
  CharSet = SET OF CHAR;
  TK = Token.T;

CONST
  WhiteSpace    = CharSet {' ', '\n', '\t', '\f'};
  AlphaNumerics = CharSet {'a'..'z', 'A'..'Z', '0'..'9', '_'};
  Digits        = CharSet {'0'..'9'};
  OctalDigits   = CharSet {'0'..'7'};
  HexAlpha      = CharSet {'a'..'f'};
  HexALPHA      = CharSet {'A'..'F'};

TYPE
  FileState = RECORD
    ch   : CHAR;
    offs : INTEGER;
    rd   : Rd.T;
    sym  : Symbol;
  END;

VAR
  input   : Rd.T;
  ch      : CHAR;
  missing : String.T;
  nFiles  : INTEGER;
  files   : ARRAY [0..MaxFiles] OF String.T;
  tos     : INTEGER;
  stack   : ARRAY [0..MaxStack] OF FileState;
  buf     : ARRAY [0..MaxString] OF CHAR;


PROCEDURE Initialize () =
  BEGIN
    missing := String.Add ("_missing_id_");
    input   := NIL;
    ch      := ' ';
    nFiles  := 0;
    tos     := 0;
  END Initialize;

PROCEDURE Push (name: String.T;  file: Rd.T) =
  BEGIN
    WITH z = stack[tos] DO
      z.ch   := ch;
      z.offs := offset;
      z.rd   := input;
      z.sym  := cur;
    END;
    INC (tos);
    files [nFiles] := name;
    offset := nFiles * MaxLines + 1;
    input  := file;
    ch     := ' ';
    INC (nFiles);
    GetToken (); (* prime the input stream *)
  END Push;

PROCEDURE Pop () =
  BEGIN
    DEC (tos);
    WITH z = stack[tos] DO
      ch     := z.ch;
      offset := z.offs;
      input  := z.rd;
      cur    := z.sym;
    END;
  END Pop;

PROCEDURE Here (VAR file: String.T;  VAR line: INTEGER) =
  BEGIN
    file := files [offset DIV MaxLines];
    line := offset MOD MaxLines;
  END Here;

PROCEDURE Match (t: Token.T;  READONLY a, b: Token.Set) =
  VAR fail: Token.Set;
  BEGIN
    IF (cur.token = t) THEN
      GetToken ();
    ELSE
      fail := a + b + Token.Set {t};
      Fail ("missing \'" & String.ToText (Token.name [t]) & "\'", fail);
      IF (cur.token = t) THEN GetToken () END;
    END;
  END Match;

PROCEDURE MatchID (READONLY a, b: Token.Set): String.T =
  VAR id: String.T;
  BEGIN
    IF (cur.token = TK.tIDENT) THEN
      id := cur.string;
      GetToken ();
    ELSE
      Fail ("missing identifier", a + b + Token.Set {TK.tIDENT});
      IF (cur.token = TK.tIDENT)
        THEN  id := cur.string;  GetToken ();
        ELSE  id := missing;
      END;
    END;
    RETURN id;
  END MatchID;

PROCEDURE Fail (msg: Text.T;  READONLY stop: Token.Set) =
  VAR t: Text.T;
  BEGIN
    t := "syntax error: " & msg;
    CASE cur.token OF
    | TK.tIDENT, TK.tTEXTCONST, TK.tREALCONST, TK.tLONGREALCONST =>
        Error.Str (cur.string, t);
    | TK.tCARDCONST, TK.tCHARCONST =>
        Error.Int (cur.value, t);
    ELSE (* no extra info *)
        Error.Msg (t);
    END;
    WHILE  NOT (cur.token IN stop) DO GetToken () END;
  END Fail;

<*INLINE*> PROCEDURE GetCh () =
  BEGIN
    IF UnsafeRd.FastEOF (input)
      THEN ch := EOFChar;
      ELSE ch := UnsafeRd.FastGetChar (input);
    END;
  END GetCh;

PROCEDURE GetToken () =
  VAR i: INTEGER;
  BEGIN
    LOOP
      (* skip white space *)
      WHILE (ch IN WhiteSpace) DO
        IF (ch = '\n') THEN INC (offset) END;
        GetCh ();
      END;
      (* remember where this token starts *)
      cur.offset := offset;

      CASE ch OF

      | 'a'..'z', 'A'..'Z' =>
          (* scan an identifier *)
          i := 0;
          WHILE (ch IN AlphaNumerics) DO
            buf [i] := ch;  INC (i);
	    GetCh ();
          END;
          cur.string := String.FromStr (buf, i);
          cur.token  := VAL (String.GetClass (cur.string), TK);
          IF (cur.token < Token.First_Keyword) THEN cur.token := TK.tIDENT END;
          RETURN;

      | '0'..'9' => ScanNumber ();                             RETURN;
      | '\''     => ScanChar ();                               RETURN;
      | '\"'     => ScanText ();                               RETURN;
      | '+'      => cur.token := TK.tPLUS;       GetCh ();  RETURN;
      | '-'      => cur.token := TK.tMINUS;      GetCh ();  RETURN;
      | '/'      => cur.token := TK.tSLASH;      GetCh ();  RETURN;
      | '&'      => cur.token := TK.tAMPERSAND;  GetCh ();  RETURN;
      | ','      => cur.token := TK.tCOMMA;      GetCh ();  RETURN;
      | ';'      => cur.token := TK.tSEMI;       GetCh ();  RETURN;
      | '['      => cur.token := TK.tLBRACKET;   GetCh ();  RETURN;
      | '{'      => cur.token := TK.tLBRACE;     GetCh ();  RETURN;
      | '^'      => cur.token := TK.tARROW;      GetCh ();  RETURN;
      | '#'      => cur.token := TK.tSHARP;      GetCh ();  RETURN;
      | ')'      => cur.token := TK.tRPAREN;     GetCh ();  RETURN;
      | ']'      => cur.token := TK.tRBRACKET;   GetCh ();  RETURN;
      | '}'      => cur.token := TK.tRBRACE;     GetCh ();  RETURN;
      | '|'      => cur.token := TK.tBAR;        GetCh ();  RETURN;
      | EOFChar  => cur.token := TK.tEOF;                   RETURN;

      | '*' => (* '*>' '*' *)
	    GetCh ();
            IF (ch = '>')
	      THEN  cur.token := TK.tENDPRAGMA;  GetCh ();
              ELSE  cur.token := TK.tASTERISK;
            END;
            RETURN;
      | '=' => (*  '='  '=>'  *)
            GetCh ();
            IF (ch = '>')
	      THEN  cur.token := TK.tIMPLIES;  GetCh ();
              ELSE  cur.token := TK.tEQUAL;
            END;
            RETURN;
      | ':' => (*  ':'  ':='  *)
            GetCh ();
            IF (ch = '=')
	      THEN  cur.token := TK.tASSIGN;  GetCh ();
              ELSE  cur.token := TK.tCOLON;
            END;
            RETURN;
      | '.' => (*  '.'  '..'  *)
            GetCh ();
            IF (ch = '.')
	      THEN  cur.token := TK.tDOTDOT;  GetCh ();
              ELSE  cur.token := TK.tDOT;
            END;
            RETURN;
      | '(' => (*  '('*'  '('  *)
            GetCh ();
            IF (ch = '*')
	      THEN  ScanComment ();
              ELSE  cur.token := TK.tLPAREN;  RETURN;
            END;
      | '>' => (*  '>'  '>='  *)
            GetCh ();
            IF (ch = '=')
	      THEN  cur.token := TK.tGREQUAL;  GetCh ();
              ELSE  cur.token := TK.tGREATER;
            END;
            RETURN;
      | '<' => (*  '<'  '<='  '<:'  '<*' *)
            GetCh ();
            IF    (ch = '=') THEN  cur.token := TK.tLSEQUAL;  GetCh ();
            ELSIF (ch = ':') THEN  cur.token := TK.tSUBTYPE;  GetCh ();
            ELSIF (ch = '*') THEN  ScanPragma ();
            ELSE                   cur.token := TK.tLESS;
            END;
            RETURN;

      ELSE
        Error.Int (ORD (ch), "Illegal character");
        GetCh ();

      END; (*case*)
    END; (*loop*)
  END GetToken;

PROCEDURE ScanNumber () =
  CONST MaxInt = 16_07fffffff;  MaxDecimal = MaxInt DIV 10;
  VAR val, len, i, base, max, digit: INTEGER;
  BEGIN
    (* scan the decimal digits *)
    val := 0;
    i := 0;
    WHILE (ch IN Digits) DO
      buf[i] := ch;  INC (i);
      IF (val > MaxDecimal) THEN
        Error.Msg ("integer too large");
        val := val DIV 10;
      END;
      val := val * 10;
      digit := ORD (ch) - ORD ('0');
      IF (digit > MaxInt - val) THEN
        Error.Msg ("integer too large");
        digit := 0;
      END;
      INC (val, digit);
      GetCh ();
    END;

    IF (ch = '_') THEN
      (* scan a based integer *)
      base := val;
      IF (base < 2) OR (16 < base) THEN
        Error.Int (base, "illegal base for based literal, 10 used");
        base := 10;
      END;
      val := 0;
      len := 0;
      max := MaxInt DIV base;
      LOOP
        GetCh ();
        IF    (ch IN Digits)   THEN  digit := ORD (ch) - ORD ('0');
        ELSIF (ch IN HexALPHA) THEN  digit := ORD (ch) - ORD ('A') + 10;
        ELSIF (ch IN HexAlpha) THEN  digit := ORD (ch) - ORD ('a') + 10;
        ELSIF (len = 0) THEN Error.Msg("missing digits in based literal"); EXIT
        ELSE  EXIT;
        END;
        IF (digit > base) THEN
          Error.Int (digit, "illegal digit in based literal");
          EXIT;
        END;
        IF (val > max) THEN Error.Msg ("based value too large"); EXIT END;
        val := val * base;
        IF (digit > MaxInt - val) THEN
          Error.Msg ("based value too large");
          EXIT;
        END;
        INC (val, digit);
        INC (len);
      END;
      cur.token := TK.tCARDCONST;
      cur.value := val;

    ELSIF (ch = '.') THEN
      (* scan a floating point number *)
      buf[i] := '.';  INC (i);
      GetCh (); (* eat the '.' *)
      IF (ch = '.') THEN
        (* we saw  "dddd.." *)
        (*** Rd.UnGetChar (input, '.'); ****)
	Rd.UnGetChar (input);
        cur.token := TK.tCARDCONST;
        cur.value := val;
        RETURN;
      END;

      (* scan the fractional digits *)
      WHILE (ch IN Digits) DO  buf[i] := ch; INC (i); GetCh ()  END;
      IF (ch = 'e') OR (ch = 'E') THEN
        buf[i] := 'e';  INC (i);
        cur.token := TK.tREALCONST;
      ELSIF (ch = 'd') OR (ch = 'D') THEN
        buf[i] := 'e'(* NOT 'd' for C *);  INC (i);
        cur.token := TK.tLONGREALCONST;
      ELSE (* real constant with no exponent *)
        cur.token := TK.tREALCONST;
        cur.string := String.FromStr (buf, i);
        RETURN ;
      END;
      GetCh ();
      IF (ch = '+') THEN
        buf[i] := '+';  INC (i);
        GetCh ();
      ELSIF (ch = '-') THEN
        buf[i] := '-';  INC (i);
        GetCh ();
      ELSE
        buf[i] := '+';
      END;
      IF  NOT (ch IN Digits) THEN
        Error.Msg ("missing digits in real exponent");
        buf[i] := '0';  INC (i);
      END;
      WHILE (ch IN Digits) DO  buf[i] := ch; INC (i); GetCh ();  END;
      cur.string := String.FromStr (buf, i);

    ELSE
      (* already scanned a decimal integer *)
      cur.token := TK.tCARDCONST;
      cur.value := val;

    END;

  END ScanNumber;

PROCEDURE ScanChar () =
  BEGIN
    cur.token := TK.tCHARCONST;
    cur.value := 0;
    GetCh ();
    IF (ch = '\'') THEN
      Error.Msg ("missing character in character literal");
      GetCh ();
      RETURN;
    ELSIF (ch = '\n') OR (ch = '\r') OR (ch = '\f') THEN
      Error.Msg ("end-of-line encountered in character literal");
      RETURN;
    ELSIF (ch = '\\') THEN
      GetCh ();
      IF    (ch = 'n')  THEN  cur.value := ORD ('\n');   GetCh ();
      ELSIF (ch = 't')  THEN  cur.value := ORD ('\t');   GetCh ();
      ELSIF (ch = 'r')  THEN  cur.value := ORD ('\r');   GetCh ();
      ELSIF (ch = 'f')  THEN  cur.value := ORD ('\f');   GetCh ();
      ELSIF (ch = '\\') THEN  cur.value := ORD ('\\');   GetCh ();
      ELSIF (ch = '\'') THEN  cur.value := ORD ('\'');   GetCh ();
      ELSIF (ch = '\"') THEN  cur.value := ORD ('\"');   GetCh ();
      ELSIF (ch IN OctalDigits) THEN  cur.value := GetOctalChar ();
      ELSE  Error.Msg ("unknown escape sequence in character literal");
      END;
    ELSIF (ch = EOFChar) THEN
      Error.Msg ("EOF encountered in character literal");
      RETURN ;
    ELSIF (ch = '\"') THEN
      cur.value := ORD ('\"');
      GetCh ();
      Error.WarnNonStandard ("quote characters must be escaped with \'\\\'");
    ELSE (* a simple character literal *)
      cur.value := ORD (ch);
      GetCh ();
    END;
    IF (ch # '\'')
      THEN Error.Msg ("missing closing quote on character literal");
      ELSE GetCh ();
    END;
  END ScanChar;

PROCEDURE ScanText () =
  VAR i: INTEGER;
  BEGIN
    i := 0;
    cur.token := TK.tTEXTCONST;
    GetCh ();
    LOOP
      IF (ch = '\"') THEN
        GetCh ();
        EXIT;
      ELSIF (ch = '\n') OR (ch = '\r') OR (ch = '\f') THEN
        Error.Msg ("end-of-line encountered in text literal");
        EXIT;
      ELSIF (ch = '\\') THEN
        GetCh ();
        IF    (ch = 'n') THEN  buf[i] := '\n';  INC (i);  GetCh ();
        ELSIF (ch = 't') THEN  buf[i] := '\t';  INC (i);  GetCh ();
        ELSIF (ch = 'r') THEN  buf[i] := '\r';  INC (i);  GetCh ();
        ELSIF (ch = 'f') THEN  buf[i] := '\f';  INC (i);  GetCh ();
        ELSIF (ch = '\\') THEN buf[i] := '\\';  INC (i);  GetCh ();
        ELSIF (ch = '\'') THEN buf[i] := '\'';  INC (i);  GetCh ();
        ELSIF (ch = '\"') THEN buf[i] := '\"';  INC (i);  GetCh ();
        ELSIF (ch IN OctalDigits) THEN buf[i] := VAL (GetOctalChar (), CHAR);
          INC (i);
        ELSE Error.Msg ("unknown escape sequence in text literal");
        END;
      ELSIF (ch = EOFChar) THEN
        Error.Msg ("EOF encountered in text literal");
        EXIT;
      ELSIF (ch = '\'') THEN
        buf[i] := ch;
        INC (i);
        GetCh ();
        Error.WarnNonStandard ("quote characters must be escaped with \'\\\'");
      ELSE (* a simple character *)
        buf[i] := ch;
        INC (i);
        GetCh ();
      END;
    END;
    cur.string := String.FromStr (buf, i);
  END ScanText;

PROCEDURE GetOctalChar (): INTEGER =
  VAR value: INTEGER;
  BEGIN
    <* ASSERT ch IN OctalDigits *>
    value := ORD (ch) - ORD ('0');
    GetCh ();
    IF  NOT (ch IN OctalDigits) THEN BadOctal (); RETURN value END;
    value := value * 8 + ORD (ch) - ORD ('0');
    GetCh ();
    IF  NOT (ch IN OctalDigits) THEN BadOctal (); RETURN value END;
    value := value * 8 + ORD (ch) - ORD ('0');
    GetCh ();
    RETURN value;
  END GetOctalChar;

PROCEDURE BadOctal () =
  BEGIN
    Error.Msg ("octal character constant must have 3 digits");
  END BadOctal;

PROCEDURE ScanComment () =
  VAR nest, save: INTEGER; start: INTEGER;
  BEGIN
    start := cur.offset;
    GetCh ();
    nest := 1;
    WHILE (nest > 0) DO
      IF (ch = '*') THEN
        GetCh ();  IF (ch = ')') THEN DEC (nest); GetCh ();  END;
      ELSIF (ch = '(') THEN
        GetCh ();  IF (ch = '*') THEN INC (nest); GetCh ();  END;
      ELSIF (ch = EOFChar) THEN
        save := offset;
	offset := start;
        Error.Msg ("EOF encountered in comment");
	offset := save;
        nest := 0;
      ELSIF (ch = '\n') THEN
        INC (offset);
        GetCh ();
      ELSE
        GetCh ();
      END;
    END;
  END ScanComment;

PROCEDURE ScanPragma () =
  VAR nest, save, start, i: INTEGER;
  BEGIN
    start := cur.offset;
    GetCh();  (* '*' *)

    (* skip white space *)
    WHILE (ch IN WhiteSpace) DO
      IF (ch = '\n') THEN INC (offset) END;
      GetCh();
    END;

    i := 2;
    buf[0] := '<';
    buf[1] := '*';
    WHILE (ch IN AlphaNumerics) DO
      (* scan an identifier *)
      buf [i] := ch;  INC (i);
      GetCh ();
    END;
    cur.string := String.FromStr (buf, i);
    cur.token  := VAL (String.GetClass (cur.string), TK);

    IF (cur.token = TK.tNOWARN) THEN
      Error.IgnoreWarning (cur.offset);
      GetToken ();  (* *> *)
      IF (cur.token # TK.tENDPRAGMA) THEN
        Error.Msg ("missing \'*>\' on NOWARN pragma");
      END;
      GetToken (); (* fetch the next one *)
      RETURN;
    END;

    IF (Token.First_Pragma<=cur.token) AND (cur.token<=Token.Last_Pragma) THEN
      RETURN;
    END;

    Error.WarnStr (2, cur.string, "unrecognized pragma (ignored)");

    (* scan over and ignore the offending pragma *)
    nest := 1;
    WHILE (nest > 0) DO
      IF (ch = '*') THEN
        GetCh();  IF (ch = '>') THEN DEC(nest); GetCh(); END;
      ELSIF (ch = '<') THEN
        GetCh();  IF (ch = '*') THEN INC(nest); GetCh(); END;
      ELSIF (ch = EOFChar) THEN
        save := offset;
	offset := start;
        Error.Msg ("EOF encountered in pragma");
	offset := save;
	nest := 0;
      ELSIF (ch = '\n') THEN
        INC (offset);
	GetCh();
      ELSE
        GetCh();
      END;
    END;

    GetToken (); (* get the next token *)
  END ScanPragma;


BEGIN
END Scanner.