(* M2LexBuf.mod provides a buffer for m2.lex.

Copyright (C) 2001-2025 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE M2LexBuf ;

IMPORT m2flex ;
IMPORT FIO ;

FROM libc IMPORT strlen ;
FROM SYSTEM IMPORT ADDRESS, ADR ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM DynamicStrings IMPORT string, InitString, InitStringCharStar, Equal, Mark, KillString ;
FROM FormatStrings IMPORT Sprintf1 ;
FROM NameKey IMPORT NulName, Name, makekey, MakeKey, KeyToCharStar ;
FROM M2Reserved IMPORT toktype, tokToTok ;
FROM M2Printf IMPORT printf0, printf1, printf2, printf3 ;
FROM M2Debug IMPORT Assert ;
FROM NameKey IMPORT makekey ;
FROM NumberIO IMPORT CardToStr ;
FROM gcctypes IMPORT location_t ;
FROM m2linemap IMPORT GetLocationBinary ;
FROM M2Emit IMPORT UnknownLocation, BuiltinsLocation ;
FROM M2Error IMPORT WarnStringAt ;
FROM M2MetaError IMPORT MetaErrorT0 ;
FROM M2Options IMPORT GetDebugTraceToken ;
FROM M2LangDump IMPORT GetDumpFile ;

FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice,
                     KillIndex, ForeachIndiceInIndexDo,
                     LowIndice, HighIndice, IsEmpty, InBounds,
                     InitIndexTuned ;


CONST
   Tracing            = FALSE ;
   Debugging          = FALSE ;
   DebugRecover       = FALSE ;
   BadTokenNo         = 32579 ;
   InitialSourceToken = 2 ;   (* 0 is unknown, 1 is builtin.  *)

TYPE
   SourceList = POINTER TO RECORD
                              left,
                              right: SourceList ;
                              name : String ;
                              line : CARDINAL ;
                              col  : CARDINAL ;
                           END ;

   TokenDesc = POINTER TO RECORD
                  token : toktype ;
                  str   : Name ;          (* ident name or string literal.  *)
                  int   : INTEGER ;
                  line  : CARDINAL ;
                  col   : CARDINAL ;
                  file  : SourceList ;
                  loc   : location_t ;
                  insert: Index ;         (* Contains any inserted tokens.  *)
               END ;

VAR
   CurrentSource    : SourceList ;
   UseBufferedTokens,
   CurrentUsed      : BOOLEAN ;
   ListOfTokens     : Index ;
   CurrentTokNo     : CARDINAL ;
   InsertionIndex   : CARDINAL ;
   SeenEof          : BOOLEAN ;  (* Have we seen eof since the last call
                                    to OpenSource.  *)


PROCEDURE stop ;
END stop ;


(*
   InitTokenDesc - returns a TokenDesc filled in with the parameters and
                   the insert field set to NIL.
*)

PROCEDURE InitTokenDesc (token: toktype; str: Name; int: INTEGER;
                         line, col: CARDINAL;
                         file: SourceList; loc: location_t) : TokenDesc ;
VAR
   tokdesc: TokenDesc ;
BEGIN
   NEW (tokdesc) ;
   tokdesc^.token := token ;
   tokdesc^.str := str ;
   tokdesc^.int := int ;
   tokdesc^.line := line ;
   tokdesc^.col := col ;
   tokdesc^.file := file ;
   tokdesc^.loc := loc ;
   tokdesc^.insert := NIL ;
   RETURN tokdesc
END InitTokenDesc ;


(*
   DeleteTokenDesc - delete tokdesc and any sub indices.
*)

PROCEDURE DeleteTokenDesc (tokdesc: TokenDesc) ;
BEGIN
   IF tokdesc^.insert # NIL
   THEN
      ForeachIndiceInIndexDo (tokdesc^.insert, DeleteTokenDesc)
   END ;
   DISPOSE (tokdesc)
END DeleteTokenDesc ;


(*
   Append - appends tokdesc to the end of the list defined by index.
*)

PROCEDURE Append (index: Index; tokdesc: TokenDesc) ;
BEGIN
   IF IsEmpty (index)
   THEN
      PutIndice (index, LowIndice (index), tokdesc)
   ELSE
      PutIndice (index, HighIndice (index) +1, tokdesc)
   END
END Append ;


(*
   InitTokenList - creates an empty token list, which starts the first source token
                   at position 2.  This allows position 0 to be used for the unknown
                   location and position 1 for the builtin token.
*)

PROCEDURE InitTokenList ;
BEGIN
   (* 65K elements in the array and when it becomes full it will grow to 1M, 16M etc elements.  *)
   ListOfTokens := InitIndexTuned (0, 1024*1024 DIV 16, 16) ;
   Append (ListOfTokens, InitTokenDesc (eoftok, NulName, 0, 0, 0, NIL, UnknownLocation ())) ;
   Append (ListOfTokens, InitTokenDesc (eoftok, NulName, 0, 0, 0, NIL, BuiltinsLocation ()))
END InitTokenList ;


(*
   Init - initializes the token list and source list.
*)

PROCEDURE Init ;
BEGIN
   SeenEof := FALSE ;
   InsertionIndex := 0 ;
   currenttoken := eoftok ;
   CurrentTokNo := InitialSourceToken ;
   CurrentSource := NIL ;
   UseBufferedTokens := FALSE ;
   InitTokenList
END Init ;


(*
   AddTo - adds a new element to the end of SourceList, CurrentSource.
*)

PROCEDURE AddTo (l: SourceList) ;
BEGIN
   l^.right := CurrentSource ;
   l^.left  := CurrentSource^.left ;
   CurrentSource^.left^.right := l ;
   CurrentSource^.left := l ;
   WITH l^.left^ DO
      line := m2flex.GetLineNo() ;
      col  := m2flex.GetColumnNo()
   END
END AddTo ;


(*
   SubFrom - subtracts, l, from the source list.
*)

PROCEDURE SubFrom (l: SourceList) ;
BEGIN
   l^.left^.right := l^.right ;
   l^.right^.left := l^.left
END SubFrom ;


(*
   NewElement - returns a new SourceList
*)

PROCEDURE NewElement (s: ADDRESS) : SourceList ;
VAR
   l: SourceList ;
BEGIN
   NEW (l) ;
   IF l = NIL
   THEN
      HALT
   ELSE
      WITH l^ DO
         name  := InitStringCharStar(s) ;
         left  := NIL ;
         right := NIL
      END
   END ;
   RETURN l
END NewElement ;


(*
   NewList - initializes an empty list with the classic dummy header element.
*)

PROCEDURE NewList () : SourceList ;
VAR
   l: SourceList ;
BEGIN
   NEW (l) ;
   WITH l^ DO
      left  := l ;
      right := l ;
      name  := NIL
   END ;
   RETURN l
END NewList ;


(*
   CheckIfNeedToDuplicate - checks to see whether the CurrentSource has
                            been used, if it has then duplicate the list.
*)

PROCEDURE CheckIfNeedToDuplicate ;
VAR
   l, h: SourceList ;
BEGIN
   IF CurrentUsed
   THEN
      l := CurrentSource^.right ;
      h := CurrentSource ;
      CurrentSource := NewList() ;
      WHILE l#h DO
         AddTo (NewElement (l^.name)) ;
         l := l^.right
      END
   END
END CheckIfNeedToDuplicate ;


(*
   PushFile - indicates that, filename, has just been included.
*)

PROCEDURE PushFile (filename: ADDRESS) ;
VAR
   l: SourceList ;
BEGIN
   CheckIfNeedToDuplicate ;
   AddTo (NewElement (filename)) ;
   IF Debugging
   THEN
      IF CurrentSource^.right#CurrentSource
      THEN
         l := CurrentSource ;
         REPEAT
            printf3('name = %s, line = %d, col = %d\n', l^.name, l^.line, l^.col) ;
            l := l^.right
         UNTIL l=CurrentSource
      END
   END
END PushFile ;


(*
   PopFile - indicates that we are returning to, filename, having finished
             an include.
*)

PROCEDURE PopFile (filename: ADDRESS) ;
VAR
   l: SourceList ;
BEGIN
   CheckIfNeedToDuplicate ;
   IF (CurrentSource#NIL) AND (CurrentSource^.left#CurrentSource)
   THEN
      l := CurrentSource^.left ;  (* last element *)
      SubFrom (l) ;
      DISPOSE (l) ;
      IF (CurrentSource^.left#CurrentSource) AND
         (NOT Equal(CurrentSource^.name, Mark(InitStringCharStar(filename))))
      THEN
         (* mismatch in source file names after preprocessing files *)
      END
   ELSE
      (* source file list is empty, cannot pop an include.. *)
   END
END PopFile ;


(*
   KillList - kills the SourceList providing that it has not been used.
*)

PROCEDURE KillList ;
VAR
   l, k: SourceList ;
BEGIN
   IF (NOT CurrentUsed) AND (CurrentSource#NIL)
   THEN
      l := CurrentSource ;
      REPEAT
         k := l ;
         l := l^.right ;
         DISPOSE(k)
      UNTIL l=CurrentSource
   END
END KillList ;


(*
   ReInitialize - re-initialize the all the data structures.
*)

PROCEDURE ReInitialize ;
BEGIN
   ForeachIndiceInIndexDo (ListOfTokens, DeleteTokenDesc) ;
   CurrentUsed := FALSE ;
   KillList ;
   Init
END ReInitialize ;


(*
   SetFile - sets the current filename to, filename.
*)

PROCEDURE SetFile (filename: ADDRESS) ;
BEGIN
   KillList ;
   CurrentUsed   := FALSE ;
   CurrentSource := NewList () ;
   AddTo (NewElement (filename))
END SetFile ;


(*
   OpenSource - Attempts to open the source file, s.
                The success of the operation is returned.
*)

PROCEDURE OpenSource (s: String) : BOOLEAN ;
BEGIN
   tprintf1 ("OpenSource (%s)\n", s) ;
   SeenEof := FALSE ;
   IF UseBufferedTokens
   THEN
      GetToken ;
      RETURN TRUE
   ELSE
      IF m2flex.OpenSource (string (s))
      THEN
         SetFile (string (s)) ;
         GetToken ;
         IF IsLastTokenEof ()
         THEN
            MetaErrorT0 (GetTokenNo (), "source file is empty")
         END ;
         RETURN TRUE
      ELSE
         RETURN FALSE
      END
   END
END OpenSource ;


(*
   CloseSource - closes the current open file.
*)

PROCEDURE CloseSource ;
BEGIN
   tprintf0 ("CloseSource\n") ;
   IF UseBufferedTokens
   THEN
      WHILE currenttoken#eoftok DO
         GetToken
      END
   ELSE
      (* a subsequent call to m2flex.OpenSource will really close the file *)
   END
END CloseSource ;


(*
   ResetForNewPass - reset the buffer pointers to the beginning ready for
                     a new pass
*)

PROCEDURE ResetForNewPass ;
BEGIN
   InsertionIndex := 0 ;
   CurrentTokNo := InitialSourceToken ;
   UseBufferedTokens := TRUE
END ResetForNewPass ;


(*
   DisplayToken - display the token name using printf0 no newline is emitted.
*)

PROCEDURE DisplayToken (tok: toktype) ;
BEGIN
   CASE tok OF

   eoftok: printf0('eoftok') |
   plustok: printf0('plustok') |
   minustok: printf0('minustok') |
   timestok: printf0('timestok') |
   dividetok: printf0('dividetok') |
   becomestok: printf0('becomestok') |
   ambersandtok: printf0('ambersandtok') |
   periodtok: printf0('periodtok') |
   commatok: printf0('commatok') |
   semicolontok: printf0('semicolontok') |
   lparatok: printf0('lparatok') |
   rparatok: printf0('rparatok') |
   lsbratok: printf0('lsbratok') |
   rsbratok: printf0('rsbratok') |
   lcbratok: printf0('lcbratok') |
   rcbratok: printf0('rcbratok') |
   uparrowtok: printf0('uparrowtok') |
   singlequotetok: printf0('singlequotetok') |
   equaltok: printf0('equaltok') |
   hashtok: printf0('hashtok') |
   lesstok: printf0('lesstok') |
   greatertok: printf0('greatertok') |
   lessgreatertok: printf0('lessgreatertok') |
   lessequaltok: printf0('lessequaltok') |
   greaterequaltok: printf0('greaterequaltok') |
   periodperiodtok: printf0('periodperiodtok') |
   colontok: printf0('colontok') |
   doublequotestok: printf0('doublequotestok') |
   bartok: printf0('bartok') |
   andtok: printf0('andtok') |
   arraytok: printf0('arraytok') |
   begintok: printf0('begintok') |
   bytok: printf0('bytok') |
   casetok: printf0('casetok') |
   consttok: printf0('consttok') |
   definitiontok: printf0('definitiontok') |
   divtok: printf0('divtok') |
   dotok: printf0('dotok') |
   elsetok: printf0('elsetok') |
   elsiftok: printf0('elsiftok') |
   endtok: printf0('endtok') |
   exittok: printf0('exittok') |
   exporttok: printf0('exporttok') |
   fortok: printf0('fortok') |
   fromtok: printf0('fromtok') |
   iftok: printf0('iftok') |
   implementationtok: printf0('implementationtok') |
   importtok: printf0('importtok') |
   intok: printf0('intok') |
   looptok: printf0('looptok') |
   modtok: printf0('modtok') |
   moduletok: printf0('moduletok') |
   nottok: printf0('nottok') |
   oftok: printf0('oftok') |
   ortok: printf0('ortok') |
   pointertok: printf0('pointertok') |
   proceduretok: printf0('proceduretok') |
   qualifiedtok: printf0('qualifiedtok') |
   unqualifiedtok: printf0('unqualifiedtok') |
   recordtok: printf0('recordtok') |
   repeattok: printf0('repeattok') |
   returntok: printf0('returntok') |
   settok: printf0('settok') |
   thentok: printf0('thentok') |
   totok: printf0('totok') |
   typetok: printf0('typetok') |
   untiltok: printf0('untiltok') |
   vartok: printf0('vartok') |
   whiletok: printf0('whiletok') |
   withtok: printf0('withtok') |
   asmtok: printf0('asmtok') |
   volatiletok: printf0('volatiletok') |
   periodperiodperiodtok: printf0('periodperiodperiodtok') |
   datetok: printf0('datetok') |
   linetok: printf0('linetok') |
   filetok: printf0('filetok') |
   integertok: printf0('integertok') |
   identtok: printf0('identtok') |
   realtok: printf0('realtok') |
   stringtok: printf0('stringtok')

   ELSE
   END
END DisplayToken ;


VAR
   indent: CARDINAL ;


(*
   DumpToken -
*)

PROCEDURE DumpToken (tokdesc: TokenDesc) ;
VAR
   n: CARDINAL ;
BEGIN
   n := indent ;
   WHILE n > 0 DO
      printf0 (" ") ;
      DEC (n)
   END ;
   WITH tokdesc^ DO
      DisplayToken (token) ;
      IF str # NulName
      THEN
         printf1 (" %a", str)
      END ;
      IF insert # NIL
      THEN
         printf0 ("inserted error recovery tokens\n") ;
         INC (indent, 2) ;
         ForeachIndiceInIndexDo (insert, DumpToken) ;
         DEC (indent, 2)
      END
   END
END DumpToken ;


(*
   DumpTokens - displays all tokens.
*)

PROCEDURE DumpTokens ;
VAR
   high,
   ind : CARDINAL ;
BEGIN
   IF IsEmpty (ListOfTokens)
   THEN
      printf0 ("The token buffer is empty\n")
   ELSE
      ind := LowIndice (ListOfTokens) ;
      high := HighIndice (ListOfTokens) ;
      WHILE ind <= high DO
         printf1 ("%5d ", ind) ;
         DumpToken (GetIndice (ListOfTokens, ind)) ;
         INC (ind)
      END
   END
END DumpTokens ;


(*
   CopyOutCurrent - copies the token in buffer[index][insertion] into
                    then current token global variables.
*)

PROCEDURE CopyOutCurrent (buffer: Index; index, insertion: CARDINAL) ;
VAR
   tokdesc: TokenDesc ;
BEGIN
   tokdesc := GetIndice (buffer, index) ;
   IF insertion # 0
   THEN
      tokdesc := GetIndice (tokdesc^.insert, insertion)
   END ;
   WITH tokdesc^ DO
      currenttoken   := token ;
      currentstring  := KeyToCharStar (str) ;
      currentcolumn  := col ;
      currentinteger := int
   END
END CopyOutCurrent ;


(*
   UpdateToken - update the global current token variables from buffer[index]
                 using inserted tokens if directed by InsertionIndex.
*)

PROCEDURE UpdateToken (buffer: Index; index: CARDINAL) ;
VAR
   tokdesc: TokenDesc ;
BEGIN
   tokdesc := GetIndice (buffer, index) ;
   IF InsertionIndex > 0
   THEN
      (* We have an inserted token to use.  *)
      Assert (tokdesc^.insert # NIL) ;
      CopyOutCurrent (buffer, index, InsertionIndex) ;
      (* Move InsertionIndex to the next position.  *)
      INC (InsertionIndex) ;
      IF InsertionIndex > HighIndice (tokdesc^.insert)
      THEN
         (* We are done consuming the inserted tokens, so move
            onto the next original source token.  *)
         InsertionIndex := 0 ;
         INC (CurrentTokNo)
      END
   ELSIF (tokdesc^.insert # NIL) AND (InsertionIndex = 0)
   THEN
      (* This source token has extra tokens appended after it by the error recovery.
         Set the index ready for the next UpdateToken which will read the extra
         tokens.  *)
      InsertionIndex := 1 ;
      (* However this call must read the original token.  *)
      CopyOutCurrent (buffer, index, 0)
   ELSE
      CopyOutCurrent (buffer, index, 0) ;
      (* Move onto the next original source token.  *)
      INC (CurrentTokNo)
   END
END UpdateToken ;


(*
   GetTokenFiltered - providing that we have not already seen an eof for this source
                      file call m2flex.GetToken and GetToken if requested.
*)

PROCEDURE GetTokenFiltered (callGetToken: BOOLEAN) ;
BEGIN
   IF SeenEof
   THEN
      currenttoken := eoftok
   ELSE
      (* Call the lexical phase to place a new token into the last bucket.  *)
      m2flex.GetToken () ;
      IF callGetToken
      THEN
         GetToken
      END
   END
END GetTokenFiltered ;


(*
   GetToken - gets the next token into currenttoken.
*)

PROCEDURE GetToken ;
VAR
   buf: ARRAY [0..20] OF CHAR ;
BEGIN
   IF UseBufferedTokens
   THEN
      UpdateToken (ListOfTokens, CurrentTokNo) ;
      IF GetDebugTraceToken ()
      THEN
         CardToStr (CurrentTokNo, 0, buf) ;
         FIO.WriteString (GetDumpFile (), 'token: ') ;
         FIO.WriteString (GetDumpFile (), buf) ;
         FIO.WriteLine (GetDumpFile ())
      END
   ELSE
      IF NOT InBounds (ListOfTokens, CurrentTokNo)
      THEN
         GetTokenFiltered (FALSE)
      END ;
      UpdateToken (ListOfTokens, CurrentTokNo) ;
      IF GetDebugTraceToken ()
      THEN
         CardToStr (CurrentTokNo, 0, buf) ;
         m2flex.M2Error (ADR (buf))
      END
   END
END GetToken ;


(*
   AppendInsertToken -
*)

PROCEDURE AppendInsertToken (index: Index; tokdesc: TokenDesc) ;
BEGIN
   IF IsEmpty (index)
   THEN
      PutIndice (index, LowIndice (index), tokdesc)
   ELSE
      PutIndice (index, HighIndice (index) +1, tokdesc)
   END
END AppendInsertToken ;


(*
   DupTok - duplicate tokdesc and replaces the token field with token.
*)

PROCEDURE DupTok (tokdesc: TokenDesc; token: toktype) : TokenDesc ;
VAR
   dup: TokenDesc ;
BEGIN
   NEW (dup) ;
   Assert (dup # NIL) ;
   dup^ := tokdesc^ ;
   dup^.token := token ;
   RETURN dup
END DupTok ;


(*
   InsertToken - inserts a symbol token infront of the current token
                 ready for the next pass.
*)

PROCEDURE InsertToken (token: toktype) ;
VAR
   prev   : CARDINAL ;
   tokdesc: TokenDesc ;
BEGIN
   Assert (ListOfTokens # NIL) ;
   Assert (NOT IsEmpty (ListOfTokens)) ;
   prev := GetTokenNo () -1 ;
   tokdesc := GetIndice (ListOfTokens, prev) ;
   IF tokdesc^.insert = NIL
   THEN
      tokdesc^.insert := InitIndex (1)
   END ;
   AppendInsertToken (tokdesc^.insert, DupTok (tokdesc, token))
END InsertToken ;


(*
   InsertTokenAndRewind - inserts a symbol token infront of the current token
                          and then moves the token stream back onto the inserted
                          token.
*)

PROCEDURE InsertTokenAndRewind (token: toktype) ;
VAR
   position : CARDINAL ;
   tokdesc  : TokenDesc ;
BEGIN
   IF GetTokenNo () > 0
   THEN
      InsertToken (token) ;
      position := CurrentTokNo -2 ;
      tokdesc := GetIndice (ListOfTokens, position) ;
      IF tokdesc^.insert = NIL
      THEN
         tokdesc^.insert := InitIndex (1)
      END ;
      AppendInsertToken (tokdesc^.insert, DupTok (tokdesc, token)) ;
      InsertionIndex := HighIndice (tokdesc^.insert) ;
      DEC (CurrentTokNo, 2) ;
      GetToken
   END
END InsertTokenAndRewind ;


(*
   GetPreviousTokenLineNo - returns the line number of the previous token.
*)

PROCEDURE GetPreviousTokenLineNo () : CARDINAL ;
BEGIN
   RETURN GetLineNo ()
END GetPreviousTokenLineNo ;


(*
   GetLineNo - returns the current line number where the symbol occurs in
               the source file.
*)

PROCEDURE GetLineNo () : CARDINAL ;
BEGIN
   IF CurrentTokNo = 0
   THEN
      RETURN 0
   ELSE
      RETURN TokenToLineNo (GetTokenNo (), 0)
   END
END GetLineNo ;


(*
   GetColumnNo - returns the current column where the symbol occurs in
                 the source file.
*)

PROCEDURE GetColumnNo () : CARDINAL ;
BEGIN
   IF CurrentTokNo = 0
   THEN
      RETURN 0
   ELSE
      RETURN TokenToColumnNo (GetTokenNo (), 0)
   END
END GetColumnNo ;


(*
   GetTokenNo - returns the current token number.
*)

PROCEDURE GetTokenNo () : CARDINAL ;
BEGIN
   IF CurrentTokNo = 0
   THEN
      RETURN 0
   ELSE
      RETURN CurrentTokNo-1
   END
END GetTokenNo ;


(*
   GetTokenName - returns the token name given the tokenno.
*)

PROCEDURE GetTokenName (tokenno: CARDINAL) : Name ;
VAR
   tokdesc: TokenDesc ;
   name   : Name ;
BEGIN
   IF InBounds (ListOfTokens, tokenno)
   THEN
      tokdesc := GetIndice (ListOfTokens, tokenno) ;
      name := tokToTok (tokdesc^.token) ;
      IF name = NulName
      THEN
         RETURN tokdesc^.str
      ELSE
         RETURN name
      END
   END ;
   RETURN NulName
END GetTokenName ;


(*
   TokenToLineNo - returns the line number of the current file for the
                   tokenno. The depth refers to the include depth.
                   A depth of 0 is the current file, depth of 1 is the file
                   which included the current file. Zero is returned if the
                   depth exceeds the file nesting level.
*)

PROCEDURE TokenToLineNo (tokenno: CARDINAL; depth: CARDINAL) : CARDINAL ;
VAR
   tokdesc: TokenDesc ;
   level  : SourceList ;
 BEGIN
   IF (tokenno # UnknownTokenNo) AND (tokenno # BuiltinTokenNo)
   THEN
      IF InBounds (ListOfTokens, tokenno)
      THEN
         tokdesc := GetIndice (ListOfTokens, tokenno) ;
         IF depth = 0
         THEN
            RETURN tokdesc^.line
         ELSE
            level := tokdesc^.file^.left ;
            WHILE depth > 0 DO
               level := level^.left ;
               IF level = tokdesc^.file^.left
               THEN
                  RETURN 0
               END ;
               DEC (depth)
            END ;
            RETURN level^.line
         END
      END
   END ;
   RETURN 0
END TokenToLineNo ;


(*
   TokenToColumnNo - returns the column number of the current file for the
                     tokenno. The depth refers to the include depth.
                     A depth of 0 is the current file, depth of 1 is the file
                     which included the current file. Zero is returned if the
                     depth exceeds the file nesting level.
*)

PROCEDURE TokenToColumnNo (tokenno: CARDINAL; depth: CARDINAL) : CARDINAL ;
VAR
   tokdesc: TokenDesc ;
   level  : SourceList ;
BEGIN
   IF (tokenno # UnknownTokenNo) AND (tokenno # BuiltinTokenNo)
   THEN
      IF InBounds (ListOfTokens, tokenno)
      THEN
         tokdesc := GetIndice (ListOfTokens, tokenno) ;
         IF depth = 0
         THEN
            RETURN tokdesc^.col
         ELSE
            level := tokdesc^.file^.left ;
            WHILE depth > 0 DO
               level := level^.left ;
               IF level = tokdesc^.file^.left
               THEN
                  RETURN 0
               END ;
               DEC (depth)
            END ;
            RETURN level^.col
         END
      END
   END ;
   RETURN 0
END TokenToColumnNo ;


(*
   TokenToLocation - returns the location_t corresponding to tokenno.
*)

PROCEDURE TokenToLocation (tokenno: CARDINAL) : location_t ;
VAR
   tokdesc: TokenDesc ;
BEGIN
   IF tokenno = UnknownTokenNo
   THEN
      RETURN UnknownLocation ()
   ELSIF tokenno = BuiltinTokenNo
   THEN
      RETURN BuiltinsLocation ()
   ELSIF InBounds (ListOfTokens, tokenno)
   THEN
      tokdesc := GetIndice (ListOfTokens, tokenno) ;
      RETURN tokdesc^.loc
   END ;
   RETURN UnknownLocation ()
END TokenToLocation ;


(*
   FindFileNameFromToken - returns the complete FileName for the appropriate
                           source file yields the token number, TokenNo.
                           The, Depth, indicates the include level: 0..n
                           Level 0 is the current. NIL is returned if n+1
                           is requested.
*)

PROCEDURE FindFileNameFromToken (tokenno: CARDINAL; depth: CARDINAL) : String ;
VAR
   tokdesc: TokenDesc ;
   level  : SourceList ;
BEGIN
   IF (tokenno # UnknownTokenNo) AND (tokenno # BuiltinTokenNo)
   THEN
      IF InBounds (ListOfTokens, tokenno)
      THEN
         tokdesc := GetIndice (ListOfTokens, tokenno) ;
         level := tokdesc^.file^.left ;
         WHILE depth > 0 DO
            level := level^.left ;
            IF level = tokdesc^.file^.left
            THEN
               RETURN NIL
            END ;
            DEC (depth)
         END ;
         RETURN level^.name
      END
   END ;
   RETURN NIL
END FindFileNameFromToken ;


(*
   GetFileName - returns a String defining the current file.
*)

PROCEDURE GetFileName () : String ;
BEGIN
   RETURN FindFileNameFromToken (GetTokenNo (), 0)
END GetFileName ;


(*
   AddTokToList - adds a token to a dynamic list.
*)

PROCEDURE AddTokToList (token: toktype; str: Name;
                        int: INTEGER; line: CARDINAL; col: CARDINAL;
                        file: SourceList; location: location_t) ;
BEGIN
   Append (ListOfTokens, InitTokenDesc (token, str, int, line,
                                        col, file, location))
END AddTokToList ;


(*
   IsLastTokenEof - returns TRUE if the last token was an eoftok
*)

PROCEDURE IsLastTokenEof () : BOOLEAN ;
VAR
   tokdesc: TokenDesc ;
BEGIN
   IF IsEmpty (ListOfTokens)
   THEN
      RETURN FALSE
   ELSE
      tokdesc := GetIndice (ListOfTokens, HighIndice (ListOfTokens)) ;
      RETURN tokdesc^.token = eoftok
   END
END IsLastTokenEof ;


(*
   PrintTokenNo - displays token and the location of the token.
*)

PROCEDURE PrintTokenNo (tokenno: CARDINAL) ;
VAR
   s: String ;
BEGIN
   printf1 ("tokenno = %d, ", tokenno) ;
   s := InitStringCharStar (KeyToCharStar (GetTokenName (tokenno))) ;
   printf1 ("%s\n", s) ;
   s := KillString (s)
END PrintTokenNo ;


(*
   isSrcToken - returns TRUE if tokenno is associated with
                program source code.
*)

PROCEDURE isSrcToken (tokenno: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN (tokenno # UnknownTokenNo) AND (tokenno # BuiltinTokenNo)
END isSrcToken ;


(*
   MakeVirtualTok - providing caret, left, right are associated with a source file
                    and exist on the same src line then
                    create and return a new tokenno which is created from
                    tokenno left and right.  Otherwise return caret.
                    If caret is UnknownTokenNo then it is replaced with left or right
                    in sequence to avoid an UnknownTokenNo.
*)

PROCEDURE MakeVirtualTok (caret, left, right: CARDINAL) : CARDINAL ;
VAR
   descLeft, descRight: TokenDesc ;
   lc, ll, lr         : location_t ;
BEGIN
   IF caret = UnknownTokenNo
   THEN
      caret := left
   END ;
   IF caret = UnknownTokenNo
   THEN
      caret := right
   END ;
   IF isSrcToken (caret) AND isSrcToken (left) AND isSrcToken (right)
   THEN
      lc := TokenToLocation (caret) ;
      ll := TokenToLocation (left) ;
      lr := TokenToLocation (right) ;
      IF InBounds (ListOfTokens, left) AND InBounds (ListOfTokens, right)
      THEN
         descLeft := GetIndice (ListOfTokens, left) ;
         descRight := GetIndice (ListOfTokens, right) ;
         IF (descLeft^.line = descRight^.line) AND
            (descLeft^.file = descRight^.file)
         THEN
            (* On the same line, create a new token and location.  *)
            AddTokToList (virtualrangetok, NulName, 0,
                          descLeft^.line, descLeft^.col, descLeft^.file,
                          GetLocationBinary (lc, ll, lr)) ;
            caret := HighIndice (ListOfTokens)
         END
      END
   END ;
   IF caret = BadTokenNo
   THEN
      stop
   END ;
   RETURN caret
END MakeVirtualTok ;


(*
   MakeVirtual2Tok - creates and return a new tokenno which is created from
                     two tokens left and right.  It tries to avoid UnknownTokenNo
                     and will fall back to left or right if necessary.
*)

PROCEDURE MakeVirtual2Tok (left, right: CARDINAL) : CARDINAL ;
BEGIN
   IF left = UnknownTokenNo
   THEN
      left := right
   ELSIF right = UnknownTokenNo
   THEN
      right := left
   END ;
   RETURN MakeVirtualTok (left, left, right) ;
END MakeVirtual2Tok ;


(*
   tprintf0 -
*)

PROCEDURE tprintf0 (format: ARRAY OF CHAR) ;
BEGIN
   IF Tracing
   THEN
      printf0 (format)
   END
END tprintf0 ;


(*
   tprintf1 -
*)

PROCEDURE tprintf1 (format: ARRAY OF CHAR; str: String) ;
BEGIN
   IF Tracing
   THEN
      printf1 (format, str)
   END
END tprintf1 ;


(* ***********************************************************************
 *
 * These functions allow m2.flex to deliver tokens into the buffer
 *
 ************************************************************************* *)

(*
   AddTok - adds a token to the buffer.
*)

PROCEDURE AddTok (t: toktype) ;
VAR
   s: String ;
BEGIN
   IF Tracing
   THEN
      printf0 (" m2.flex -> AddTok ") ;
      DisplayToken (t) ;
      printf0 ("\n") ;
   END ;
   IF (t=eoftok) AND SeenEof
   THEN
      IF Debugging
      THEN
         printf0 ("extra eoftok ignored as buffer already contains eoftok\n")
      END
   ELSE
      IF Debugging
      THEN
         printf0 ("adding token: ") ; DisplayToken (t) ;
         printf0 ("\n")
      END ;
      AddTokToList(t, NulName, 0,
                   m2flex.GetLineNo(), m2flex.GetColumnNo(), CurrentSource,
                   m2flex.GetLocation()) ;
      CurrentUsed := TRUE ;
      IF Debugging
      THEN
         (* display each token as a warning.  *)
         s := InitStringCharStar (KeyToCharStar (GetTokenName (GetTokenNo ()))) ;
         WarnStringAt (s, GetTokenNo ())
      END ;
      IF t = eoftok
      THEN
         SeenEof := TRUE
      END
   END
END AddTok ;


(*
   AddTokCharStar - adds a token to the buffer and an additional string, s.
                    A copy of string, s, is made.
*)

PROCEDURE AddTokCharStar (t: toktype; s: ADDRESS) ;
VAR
   str: String ;
BEGIN
   Assert (t # eoftok) ;
   IF Tracing
   THEN
      printf0 (" m2.flex -> AddTokCharStar ") ;
      DisplayToken (t) ;
      str := InitStringCharStar (s) ;
      printf1 (" %s\n", str) ;
      str := KillString (str)
   END ;
   IF Debugging
   THEN
      printf0 ("AddTokCharStar: ") ; DisplayToken (t) ; printf0 ("\n")
   END ;
   AddTokToList(t, makekey(s), 0, m2flex.GetLineNo(),
                m2flex.GetColumnNo(), CurrentSource, m2flex.GetLocation()) ;
   CurrentUsed := TRUE
END AddTokCharStar ;


(*
   AddTokInteger - adds a token and an integer to the buffer.
*)

PROCEDURE AddTokInteger (t: toktype; i: INTEGER) ;
VAR
   s: String ;
   c,
   l: CARDINAL ;
BEGIN
   Assert (t # eoftok) ;
   IF Tracing
   THEN
      printf0 (" m2.flex -> AddTokInteger ") ;
      DisplayToken (t) ;
      printf1 (" %d\n", i) ;
   END ;
   l := m2flex.GetLineNo() ;
   c := m2flex.GetColumnNo() ;
   s := Sprintf1(Mark(InitString('%d')), i) ;
   AddTokToList(t, makekey(string(s)), i, l, c, CurrentSource, m2flex.GetLocation()) ;
   s := KillString(s) ;
   CurrentUsed := TRUE
END AddTokInteger ;


BEGIN
   Init
END M2LexBuf.