UNIT CRS;
(* Scanner generated by Coco/R (Pascal version) *)

INTERFACE

VAR
  src:         FILE;         (*source/list files. To be opened by the main pgm*)
  lst:         TEXT;
  directory:   STRING;       (*of source file*)
  line, col:   INTEGER;      (*line and column of current symbol*)
  len:         LONGINT;      (*length of current symbol*)
  pos:         LONGINT;      (*file position of current symbol*)
  nextLine:    INTEGER;      (*line of lookahead symbol*)
  nextCol:     INTEGER;      (*column of lookahead symbol*)
  nextLen:     LONGINT;      (*length of lookahead symbol*)
  nextPos:     LONGINT;      (*file position of lookahead symbol*)
  errors:      INTEGER;      (*number of detected errors*)
  Error:       PROCEDURE (nr, line, col: INTEGER; pos: LONGINT);

PROCEDURE Get (VAR sym: INTEGER);
(* Gets next symbol from source file *)

PROCEDURE GetString (pos: LONGINT; len: INTEGER; VAR s: STRING);
(* Retrieves exact string of max length len from position pos in source file *)

PROCEDURE GetName (pos: LONGINT; len: INTEGER; VAR s: STRING);
(* Retrieves name of symbol of length len at position pos in source file *)

FUNCTION CharAt (pos: LONGINT): CHAR;
(* Returns exact character at position pos in source file *)

PROCEDURE _Reset;
(* Reads and stores source file internally *)

IMPLEMENTATION

CONST
  noSym   = 44; (*error token code*)
  (* not only for errors but also for not finished states of scanner analysis *)
  eof   = #26; (*MS-DOS eof*)
  LF    = #10;
  CR    = #13;
  EF    = #0;
  EL    = CR;
  BlkSize = 16384;
TYPE
  BufBlock   = ARRAY [0 .. BlkSize-1] OF CHAR;
  Buffer     = ARRAY [0 .. 31] OF ^BufBlock;
  StartTable = ARRAY [0 .. 255] OF INTEGER;
  GetCH      = FUNCTION (pos: LONGINT) : CHAR;
VAR
  lastCh,
  ch:        CHAR;       (*current input character*)
  curLine:   INTEGER;    (*current input line (may be higher than line)*)
  lineStart: LONGINT;    (*start position of current line*)
  apx:       LONGINT;    (*length of appendix (CONTEXT phrase)*)
  oldEols:   INTEGER;    (*number of _EOLs in a comment*)
  bp, bp0:   LONGINT;    (*current position in buf
                           (bp0: position of current token)*)
  LBlkSize:  LONGINT;    (*BlkSize*)
  inputLen:  LONGINT;    (*source file size*)
  buf:       Buffer;     (*source buffer for low-level access*)
  start:     StartTable; (*start state for every character*)
  CurrentCh: GetCH;

PROCEDURE Err (nr, line, col: INTEGER; pos: LONGINT); FAR;
  BEGIN
    INC(errors)
  END;

PROCEDURE NextCh;
(* Return global variable ch *)
  BEGIN
    lastCh := ch; INC(bp); ch := CurrentCh(bp);
    IF (ch = EL) OR (ch = LF) AND (lastCh <> EL) THEN BEGIN
      INC(curLine); lineStart := bp
    END
  END;

FUNCTION Comment: BOOLEAN;
  LABEL
    999;
  VAR
    level, startLine: INTEGER;
    oldLineStart : LONGINT;
  BEGIN
    level := 1; startLine := curLine; oldLineStart := lineStart;
    IF (ch = '/') THEN BEGIN
      NextCh;
      IF (ch = '*') THEN BEGIN
        NextCh;
        WHILE TRUE DO BEGIN
          IF (ch = '*') THEN BEGIN
            NextCh;
            IF (ch = '/') THEN BEGIN
              DEC(level); NextCh;
              IF level = 0 THEN BEGIN Comment := TRUE; GOTO 999; END
            END
          END ELSE IF ch = EF THEN BEGIN Comment := FALSE; GOTO 999; END
          ELSE NextCh;
        END; (* WHILE TRUE *)
      END ELSE BEGIN
        IF (ch = CR) OR (ch = LF) THEN BEGIN
          DEC(curLine); lineStart := oldLineStart
        END;
        DEC(bp); ch := lastCh; Comment := FALSE;
      END;
    END;
    IF (ch = '(') THEN BEGIN
      NextCh;
      IF (ch = '*') THEN BEGIN
        NextCh;
        WHILE TRUE DO BEGIN
          IF (ch = '*') THEN BEGIN
            NextCh;
            IF (ch = ')') THEN BEGIN
              DEC(level); NextCh;
              IF level = 0 THEN BEGIN Comment := TRUE; GOTO 999; END
            END
          END ELSE IF (ch = '(') THEN BEGIN
            NextCh;
            IF (ch = '*') THEN BEGIN INC(level); NextCh END
          END ELSE IF ch = EF THEN BEGIN Comment := FALSE; GOTO 999; END
          ELSE NextCh;
        END; (* WHILE TRUE *)
      END ELSE BEGIN
        IF (ch = CR) OR (ch = LF) THEN BEGIN
          DEC(curLine); lineStart := oldLineStart
        END;
        DEC(bp); ch := lastCh; Comment := FALSE;
      END;
    END;
    Comment := FALSE;
    999:
  END;

PROCEDURE Get (VAR sym: INTEGER);
  VAR
    state: INTEGER;

  FUNCTION Equal (s: STRING): BOOLEAN;
    VAR
      i: INTEGER;
      q: LONGINT;
    BEGIN
      IF nextLen <> Length(s) THEN BEGIN Equal := FALSE; EXIT END;
      i := 1; q := bp0;
      WHILE i <= nextLen DO BEGIN
        IF CurrentCh(q) <> s[i] THEN BEGIN Equal := FALSE; EXIT END;
        INC(i); INC(q)
      END;
      Equal := TRUE
    END;

  PROCEDURE CheckLiteral;
    BEGIN
      CASE CurrentCh(bp0) OF
        'A': IF Equal('ANY') THEN BEGIN sym := 26; 
             END;
        'C': IF Equal('CASE') THEN BEGIN sym := 22; 
             END ELSE IF Equal('CHARACTERS') THEN BEGIN sym := 13; 
             END ELSE IF Equal('CHR') THEN BEGIN sym := 27; 
             END ELSE IF Equal('COMMENTS') THEN BEGIN sym := 17; 
             END ELSE IF Equal('COMPILER') THEN BEGIN sym := 5; 
             END ELSE IF Equal('CONTEXT') THEN BEGIN sym := 37; 
             END;
        'E': IF Equal('END') THEN BEGIN sym := 12; 
             END;
        'F': IF Equal('FROM') THEN BEGIN sym := 18; 
             END;
        'I': IF Equal('IGNORE') THEN BEGIN sym := 21; 
             END;
        'N': IF Equal('NAMES') THEN BEGIN sym := 15; 
             END ELSE IF Equal('NESTED') THEN BEGIN sym := 20; 
             END;
        'P': IF Equal('PRAGMAS') THEN BEGIN sym := 16; 
             END ELSE IF Equal('PRODUCTIONS') THEN BEGIN sym := 9; 
             END;
        'S': IF Equal('SYNC') THEN BEGIN sym := 36; 
             END;
        'T': IF Equal('TO') THEN BEGIN sym := 19; 
             END ELSE IF Equal('TOKENS') THEN BEGIN sym := 14; 
             END;
        'U': IF Equal('USES') THEN BEGIN sym := 6; 
             END;
        'W': IF Equal('WEAK') THEN BEGIN sym := 31; 
             END;
      ELSE BEGIN END
      END
    END;

  BEGIN (*Get*)
    WHILE (ch = ' ') OR
          (ch >= CHR(9)) AND (ch <= CHR(10)) OR
          (ch = CHR(13)) DO NextCh;
    IF ((ch = '/') OR (ch = '(')) AND Comment THEN BEGIN Get(sym); EXIT; END;
    pos := nextPos;   nextPos := bp;