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

(* File: M3LinkerRd.m3                                         *)
(* Last Modified On Wed Sep  2 10:27:25 PDT 1992 By rustan         *)
(*      Modified On Fri Feb 14 11:28:28 PST 1992 By kalsow         *)

MODULE M3LinkerRd EXPORTS M3Linker, M3LinkerRep;

IMPORT Text, Rd, Wr, Fmt, M3LinkAtom, Word, Thread;
<*FATAL Wr.Failure, Thread.Alerted*>

CONST
  End_of_buffer = '\000';
  Buffer_size   = 1024;
  N_stop_chars  = 5;  (* SPACE, NEWLINE, '*', EOB, QUOTE *)

TYPE
  State = RECORD
    cmd       : CHAR;
    rd        : Rd.T          := NIL;
    errors    : Wr.T          := NIL;
    nErrors   : INTEGER       := 0;
    units     : UnitList      := NIL;
    cur_file  : File          := NIL;
    cur_unit  : Unit          := NIL;
    cur_type  : Type          := NIL;
    cur_utype : UndefinedType := NIL;
    vsMap     : VSMap         := NIL;
    typeMap   : TypeMap       := NIL;
    utypeMap  : UTypeMap      := NIL;
    buf_ptr   : CARDINAL      := 0;
    buf_len   : CARDINAL      := 0;
    buf       : ARRAY [0..Buffer_size + N_stop_chars - 1] OF CHAR;
  END;

TYPE
  VSMap    = REF ARRAY OF VersionStamp;
  TypeMap  = REF ARRAY OF Type;
  UTypeMap = REF ARRAY OF UndefinedType;

TYPE
  CmdProc = PROCEDURE (VAR s: State): BOOLEAN;

EXCEPTION
  SyntaxError;

VAR
  HexDigit : ARRAY CHAR OF [0..16];
  CmdMap   : ARRAY CHAR OF CmdProc;

(*------------------------------------------------------------------------*)

PROCEDURE ReadUnits (input    : Rd.T;
                     filename : TEXT;
                     imported : BOOLEAN;
                     errors   : Wr.T): UnitList =
  VAR s: State;
  BEGIN
    s.rd       := input;
    s.errors   := errors;
    s.cur_file := NEW (File, name := filename, imported := imported);

    TRY
      ReadLinkFile (s);
    EXCEPT
    | Rd.Failure    => Error (s, "unexpected Rd.Failure");
    | Rd.EndOfFile  => Error (s, "unexpected EOF");
    | SyntaxError   => Error (s, "malformed linker file");
    END;

    IF (s.nErrors > 0)
      THEN RETURN NIL
      ELSE RETURN s.units;
    END;
  END ReadUnits;

(*------------------------------------------------------------------------*)

PROCEDURE ReadLinkFile (VAR s: State) RAISES {SyntaxError} =
  BEGIN
    RefillBuffer (s);
    ReadMagic (s);
    LOOP
      s.cmd := s.buf [s.buf_ptr];
      INC (s.buf_ptr);
      IF CmdMap [s.cmd] (s) THEN EXIT END;
    END;
  END ReadLinkFile;

PROCEDURE ReadMagic (VAR s: State) RAISES {SyntaxError} =
  BEGIN
    FOR i := 0 TO Text.Length (LinkerMagic) - 1 DO
      Match (s, Text.GetChar (LinkerMagic, i));
    END;
    Match (s, '\n');
  END ReadMagic;

PROCEDURE Match (VAR s: State;  ch: CHAR) RAISES {SyntaxError} =
  VAR c2 := GetC (s);
  BEGIN
    IF (ch # c2) THEN
      Error (s, "bad linkfile (unrecognized header)");
      RAISE SyntaxError;
    END;
  END Match;

PROCEDURE EndBuffer (VAR s: State): BOOLEAN =
  BEGIN
    IF EOF (s) THEN RETURN TRUE END;
    RefillBuffer (s);
    RETURN FALSE;
  END EndBuffer;

PROCEDURE BadChar (VAR s: State): BOOLEAN =
  BEGIN
    Error (s, "unrecognized linker command: ", CharName (s.cmd));
    RETURN TRUE;
  END BadChar;

PROCEDURE ReadFileMagic (VAR s: State): BOOLEAN =
  (* Zn  --- set file magic to 'n'  *)
  VAR name: Name;
  BEGIN
    GetName (s, name, '\n');
    s.cur_file.magic := name.text;
    RETURN FALSE;
  END ReadFileMagic;

PROCEDURE ReadUnit (VAR s: State): BOOLEAN =
  (* In  --- Interface 'n'  *)
  (* Mn  --- Module 'n'     *)
  VAR intf := (s.cmd = 'I');
  VAR unit := NEW (Unit, file := s.cur_file, interface := intf);
  VAR node := NEW (UnitList, unit := unit, next := s.units);
  BEGIN
    GetName (s, unit.name, '\n');
    s.units     := node;
    s.cur_unit  := unit;
    s.cur_type  := NIL;
    s.cur_utype := NIL;
    RETURN FALSE;
  END ReadUnit;

PROCEDURE ReadPort (VAR s: State): BOOLEAN =
  (* Am    --- exports module m *)
  (* Bm    --- imports module m *)
  VAR export := (s.cmd = 'A');
  VAR node := NEW (NameList);
  VAR unit := s.cur_unit;
  BEGIN
    GetName (s, node.name, '\n');
    IF (unit = NIL) THEN
      Error (s, "import/export while current unit not defined!");
    ELSIF (export) THEN
      node.next := unit.exported_units;
      unit.exported_units := node;
    ELSE (* import *)
      node.next := unit.imported_units;
      unit.imported_units := node;
    END;
    RETURN FALSE;
  END ReadPort;

PROCEDURE ReadGeneric (VAR s: State): BOOLEAN =
  (* gm    --- imports generic unit m *)
  VAR node := NEW (NameList);
  VAR unit := s.cur_unit;
  BEGIN
    GetName (s, node.name, '\n');
    IF (unit = NIL) THEN
      Error (s, "generic import while current unit not defined!");
    ELSE
      node.next := unit.imported_generics;
      unit.imported_generics := node;
    END;
    RETURN FALSE;
  END ReadGeneric;

PROCEDURE ReadVersionStamp (VAR s: State): BOOLEAN =
  (* in x  --- import symbol 'n' with version stamp 'x' *)
  (* en x  --- export symbol 'n' with version stamp 'x' *)
  VAR import := (s.cmd = 'i');
  VAR sym  := NEW (VersionStamp, export := NOT import);
  VAR unit := s.cur_unit;
  BEGIN
    GetName  (s, sym.symbol, ' ');
    GetStamp (s, sym.stamp, '\n');
    IF (unit = NIL) THEN
      Error (s, "version stamps while current unit not defined!");
    ELSIF (import) THEN
      sym.next := unit.imported_symbols;
      unit.imported_symbols := sym;
    ELSE
      sym.next := unit.exported_symbols;
      unit.exported_symbols := sym;
    END;
    RETURN FALSE;
  END ReadVersionStamp;

PROCEDURE ReadNumberedVersionStamp (VAR s: State): BOOLEAN =
  (* Km n x  --- import symbol 'n' with verison stamp 'x', node # = m *)
  (* Vm n x  --- export symbol 'n' with verison stamp 'x', node # = m *)
  CONST Map = ARRAY BOOLEAN OF CHAR { 'e', 'i' };
  VAR import := (s.cmd = 'K');
  VAR id   := GetInteger (s, ' ');
  VAR unit := s.cur_unit;
  BEGIN
    s.cmd := Map [import];
    EVAL ReadVersionStamp (s);
    IF (unit # NIL) THEN
      WHILE (s.vsMap = NIL) OR (LAST (s.vsMap^) < id) DO ExpandVSMap (s) END;
      IF (import)
        THEN s.vsMap [id] := unit.imported_symbols;
        ELSE s.vsMap [id] := unit.exported_symbols;
      END;
    END;
    RETURN FALSE;
  END ReadNumberedVersionStamp;

PROCEDURE ExpandVSMap (VAR s: State) =
  VAR new: VSMap;
  BEGIN
    IF (s.vsMap = NIL) THEN
      new := NEW (VSMap, 4000);
    ELSE
      new := NEW (VSMap, 2 * NUMBER (s.vsMap^));
      FOR i := 0 TO LAST (s.vsMap^) DO new[i] := s.vsMap[i] END;
    END;
    s.vsMap := new;
  END ExpandVSMap;

PROCEDURE ReadCopiedVersionStamp (VAR s: State): BOOLEAN =
  (* Gm      --- import copy of symbol with node # = m *)
  (* Vm      --- export copy of symbol with node # = m *)
  VAR import := (s.cmd = 'G');
  VAR id   := GetInteger (s, '\n');
  VAR unit := s.cur_unit;
  VAR new  := NEW (VersionStamp);
  BEGIN
    IF (s.vsMap = NIL) OR (LAST (s.vsMap^) < id) THEN
      Error (s, "missing numbered version stamp!");
    ELSIF (unit = NIL) THEN
      Error (s, "copied version stamps while current unit not defined!");
    ELSIF (import) THEN
      new^ := s.vsMap[id]^;
      new.export := NOT import;
      new.next := unit.imported_symbols;
      unit.imported_symbols := new;
    ELSE
      new^ := s.vsMap[id]^;
      new.export := NOT import;
      new.next := unit.exported_symbols;
      unit.exported_symbols := new;
    END;
    RETURN FALSE;
  END ReadCopiedVersionStamp;

PROCEDURE ReadRevelation (VAR s: State): BOOLEAN =
  (* Rx y    --- export REVEAL 'x' = 'y'  from current unit *)
  (* Xx y    --- export REVEAL 'x' <: 'y' from current unit *)
  (* rm x y  --- import REVEAL 'x' = 'y'  from 'm' *)
  (* xm x y  --- import REVEAL 'x' <: 'y' from 'm' *)
  VAR export  := (s.cmd = 'R') OR (s.cmd = 'X');
  VAR partial := (s.cmd = 'x') OR (s.cmd = 'X');
  VAR r       := NEW (Revelation, export := export, partial := partial);
  VAR unit    := s.cur_unit;
  BEGIN
    IF (NOT export) THEN GetName (s, r.unit, ' ') END;
    GetName (s, r.lhs, ' ');
    GetName (s, r.rhs, '\n');
    IF (unit = NIL) THEN
      Error (s, "revelations while current unit not defined!");
    ELSE
      r.next := unit.revelations;     unit.revelations := r;
      IF (export) THEN r.unit := unit.name END;
    END;
    RETURN FALSE;
  END ReadRevelation;

PROCEDURE ReadUndefinedType (VAR s: State): BOOLEAN =
  (* ux c  --- set current type = 'x' (leave it undefined) *)
  VAR type := NEW (UndefinedType);
  VAR unit := s.cur_unit;
  BEGIN
    GetName (s, type.uid, ' ');
    type.class := VAL (GetInteger (s, '\n'), TypeClass);
    IF (unit = NIL) THEN
      OutsideTypeDeclError (s, "undefined type specified")
    ELSE
      type.next := unit.undefined_types;
      unit.undefined_types := type;
      s.cur_utype := type;
      s.cur_type  := NIL;
    END;
    RETURN FALSE;
  END ReadUndefinedType;

PROCEDURE ReadNumberedUType (VAR s: State): BOOLEAN =
  (* Jm x c  --- set current type = 'x', leave it undefined, node # = m *)
  VAR id   := GetInteger (s, ' ');
  VAR unit := s.cur_unit;
  BEGIN
    EVAL ReadUndefinedType (s);
    IF (unit # NIL) THEN
      WHILE (s.utypeMap = NIL) OR (LAST (s.utypeMap^) < id) DO
        ExpandUTypeMap (s);
      END;
      s.utypeMap [id] := s.cur_utype;
    END;
    RETURN FALSE;
  END ReadNumberedUType;

PROCEDURE ExpandUTypeMap (VAR s: State) =
  VAR new: UTypeMap;
  BEGIN
    IF (s.utypeMap = NIL) THEN
      new := NEW (UTypeMap, 2000);
    ELSE
      new := NEW (UTypeMap, 2 * NUMBER (s.utypeMap^));
      FOR i := 0 TO LAST (s.utypeMap^) DO new[i] := s.utypeMap[i] END;
    END;
    s.utypeMap := new;
  END ExpandUTypeMap;

PROCEDURE ReadCopiedUType (VAR s: State): BOOLEAN =
  (* Um      --- set current type to a copy of undefined type w/node # m *)
  VAR id   := GetInteger (s, '\n');
  VAR unit := s.cur_unit;
  VAR new  := NEW (UndefinedType);
  BEGIN
    IF (s.utypeMap = NIL) OR (LAST (s.utypeMap^) < id) THEN
      Error (s, "missing numbered, undefined type!");
    ELSIF (unit = NIL) THEN
      Error (s, "copied undefined type while current unit not defined!");
    ELSE
      new^ := s.utypeMap[id]^;
      new.next := unit.undefined_types;
      unit.undefined_types := new;
      s.cur_utype := new;
      s.cur_type  := NIL;
    END;
    RETURN FALSE;
  END ReadCopiedUType;

PROCEDURE ReadType (VAR s: State): BOOLEAN =
  (* tx c  --- set current type = 'x' *)
  VAR unit := s.cur_unit;
  VAR type := NEW (Type, unit := unit);
  BEGIN
    GetName (s, type.uid, ' ');
    type.class := VAL (GetInteger (s, '\n'), TypeClass);
    IF (unit = NIL) THEN
      OutsideTypeDeclError (s, "type specified")
    ELSE
      type.next := unit.defined_types;
      unit.defined_types := type;
      s.cur_type  := type;
      s.cur_utype := NIL;
    END;
    RETURN FALSE;
  END ReadType;

PROCEDURE ReadNumberedType (VAR s: State): BOOLEAN =
  (* Hm x c  --- set current type = 'x', node # = m *)
  VAR id   := GetInteger (s, ' ');
  VAR unit := s.cur_unit;
  BEGIN
    EVAL ReadType (s);
    IF (unit # NIL) THEN
      WHILE (s.typeMap = NIL) OR (LAST (s.typeMap^) < id) DO
        ExpandTypeMap (s);
      END;
      s.typeMap [id] := s.cur_type;
    END;
    RETURN FALSE;
  END ReadNumberedType;

PROCEDURE ExpandTypeMap (VAR s: State) =
  VAR new: TypeMap;
  BEGIN
    IF (s.typeMap = NIL) THEN
      new := NEW (TypeMap, 3000);
    ELSE
      new := NEW (TypeMap, 2 * NUMBER (s.typeMap^));
      FOR i := 0 TO LAST (s.typeMap^) DO new[i] := s.typeMap[i] END;
    END;
    s.typeMap := new;
  END ExpandTypeMap;

PROCEDURE ReadCopiedType (VAR s: State): BOOLEAN =
  (* Qm      --- set current type to a copy of type w/node # m *)
  VAR id   := GetInteger (s, '\n');
  VAR unit := s.cur_unit;
  VAR new  := NEW (Type);
  BEGIN
    IF (LAST (s.typeMap^) < id) THEN
      Error (s, "missing numbered, defined type!");
    ELSIF (unit = NIL) THEN
      Error (s, "copied undefined type while current unit not defined!");
    ELSE
      new^ := s.typeMap[id]^;
      new.unit := unit;
      new.next := unit.defined_types;
      unit.defined_types := new;
      s.cur_type  := new;
      s.cur_utype := NIL;
    END;
    RETURN FALSE;
  END ReadCopiedType;

PROCEDURE ReadTypeDependency (VAR s: State): BOOLEAN =
  (* dx    --- current type depends on type 'x' *)
  VAR node := NEW (NameList);
  VAR type := s.cur_type;
  BEGIN
    GetName (s, node.name, '\n');
    IF (type = NIL) THEN
      OutsideTypeDeclError (s, "type dependency")
    ELSE
      node.next := type.depends;
      type.depends := node;
    END;
    RETURN FALSE;
  END ReadTypeDependency;

PROCEDURE ReadPreDecl (VAR s: State): BOOLEAN =
  (* D     --- C pre-declaration for current type follows *)
  CONST ZZ = "C type pre-declaration";
  VAR decl := GetMultiLine (s);
  VAR type := s.cur_type;
  BEGIN
    IF (type = NIL) THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF type.preDecl # NIL THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.preDecl := decl;
    END;
    RETURN FALSE;
  END ReadPreDecl;

PROCEDURE ReadDecl (VAR s: State): BOOLEAN =
  (* C     --- C declaration for current type follows *)
  CONST ZZ = "C type declaration";
  VAR decl := GetMultiLine (s);
  VAR type := s.cur_type;
  BEGIN
    IF (type = NIL) THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF type.decl # NIL THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.decl := decl;
    END;
    RETURN FALSE;
  END ReadDecl;

PROCEDURE ReadTypeMethodDecl (VAR s: State): BOOLEAN =
  (* O     --- C declaration for current type's methods follows *)
  CONST ZZ = "C method type declaration";
  VAR decl := GetMultiLine (s);
  VAR type := s.cur_type;
  BEGIN
    IF (type = NIL) THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF (type.methodDecl # NIL) THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.methodDecl := decl;
    END;
    RETURN FALSE;
  END ReadTypeMethodDecl;

PROCEDURE ReadSupertype (VAR s: State): BOOLEAN =
  (* Sx    --- super type of current type is 'x' *)
  CONST ZZ = "supertype";
  VAR name : Name;
  VAR type := s.cur_type;
  BEGIN
    GetName (s, name, '\n');
    IF (type = NIL) THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF (type.super.text # NIL) THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.super := name;
    END;
    RETURN FALSE;
  END ReadSupertype;

PROCEDURE ReadTypeName (VAR s: State): BOOLEAN =
  (* Nn    --- user-sensible name for current type is 'n' *)
  VAR n: Name;
  BEGIN
    GetName (s, n, '\n');
    IF (s.cur_type # NIL) THEN
      s.cur_type.name := n.text;
    ELSIF (s.cur_utype # NIL) THEN
      s.cur_utype.name := n.text;
    ELSE
      OutsideTypeDeclError (s, "type name")
    END;
    RETURN FALSE;
  END ReadTypeName;

(* new KRML *)
PROCEDURE ReadTraced (VAR s: State): BOOLEAN =
  (* kb s a m d e
             --- 'b' indicates whether or not current type is traced
                 's' is the dataSize
                 'a' is the alignment
                 'm' is the number of new methods (0 for REF types)
                 'd' is the number of open dimensions (0 for OBJECT types)
                 'e' is the element size of each open array element
                      (0 for OBJECT types)
  *)
  CONST ZZ = "isTraced";
  VAR isTraced := GetInteger (s, ' ');
      dataSize := GetInteger (s, ' ');
      dataAlignment := GetInteger (s, ' ');
      nMethods := GetInteger (s, ' ');
      nDimensions := GetInteger (s, ' ');
      elementSize := GetInteger (s, '\n');
  VAR type := s.cur_type;
  BEGIN
    IF type = NIL THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF type.isTraced # 2 THEN
      MultipleInTypeError (s, ZZ, type)
    ELSIF isTraced = 2 THEN
      Error (s, "isTraced = 2!" )
    ELSIF nMethods # 0 AND (nDimensions # 0 OR elementSize # 0) THEN
      Error (s, "nMethods and nDimensions/elementSize are mutually exclusive" )
    ELSE
      type.isTraced := isTraced;
      type.dataSize := dataSize;
      type.dataAlignment := dataAlignment;
      type.nMethods := nMethods;
      type.nDimensions := nDimensions;
      type.elementSize := elementSize
    END;
    RETURN FALSE
  END ReadTraced;

PROCEDURE ReadBrand (VAR s: State): BOOLEAN =
  (* lb      --- 'b' is the brand of the current type *)
  CONST ZZ = "brand";
  VAR type := s.cur_type;
  VAR brand : Name;
  BEGIN
    GetName (s, brand, '\n');
    IF type = NIL THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF type.brand.text # NIL THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.brand := brand
    END;
    RETURN FALSE
  END ReadBrand;

PROCEDURE ReadInitProcName (VAR s: State): BOOLEAN =
  (* np      --- 'p' is the init proc of the current type *)
  CONST ZZ = "initProc";
  VAR type := s.cur_type;
  VAR initProc : Name;
  BEGIN
    GetName (s, initProc, '\n');
    IF type = NIL THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF type.initProc.text # NIL THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.initProc := initProc
    END;
    RETURN FALSE
  END ReadInitProcName;

PROCEDURE ReadTracedOffsets (VAR s: State): BOOLEAN =
  (* bs      --- 's' is a string containing the sequence of traced
                 offsets of the current type *)
  CONST ZZ = "traced offsets sequence";
  VAR type := s.cur_type;
  VAR tracedOffsets : Name;
  BEGIN
    GetName (s, tracedOffsets, '\n');
    IF type = NIL THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF type.tracedOffs.text # NIL THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.tracedOffs := tracedOffsets
    END;
    RETURN FALSE
  END ReadTracedOffsets;

PROCEDURE ReadSigEncoding (VAR s: State): BOOLEAN =
  (* so e    --- 'e' is the signature encoding of the current type's
                 'o'th new method *)
  VAR node := NEW( SigCodeList );
      type := s.cur_type;
      name: Name;
  BEGIN
    node.offset := GetInteger( s, ' ' );
    GetName( s, name, '\n' );  node.encoding := name.text;
    IF (type = NIL) THEN
      OutsideTypeDeclError (s, "signature encoding")
    ELSE
      node.next := type.sigEncodings;
      type.sigEncodings := node
    END;
    RETURN FALSE
  END ReadSigEncoding;

PROCEDURE ReadMapProcName (VAR s: State): BOOLEAN =
  (* mp      --- 'p' is the map proc of the current type *)
  CONST ZZ = "mapProc";
  VAR type := s.cur_type;
  VAR mapProc : Name;
  BEGIN
    GetName (s, mapProc, '\n');
    IF type = NIL THEN
      OutsideTypeDeclError (s, ZZ)
    ELSIF type.mapProc.text # NIL THEN
      MultipleInTypeError (s, ZZ, type)
    ELSE
      type.mapProc := mapProc
    END;
    RETURN FALSE
  END ReadMapProcName;

PROCEDURE ReadOverride (VAR s: State): BOOLEAN =
  (* os f y   --- specifies the differences in the current type's method
                  suite as compared to that of the parent type's of
                  of the current type
                  In particular, the type's method suite will look
                  exactly like that of its parent's, where new methods
                  are NIL, *except* for those methods for which an
                  "os f y" triple is included.  The information specified
                  by this triple takes precedence over the said default
                  rule.  The triple is interpreted as:

                    's' is the uid of some supertype of the current type
                    (in particular, 's' may be the current type)

                    the method referred to is the one with offset 'f' into
                    's's new methods

                    'y' is the C name of the actual procedure

     Note, despite the name of this method and the OverrideList type,
     the methods specified are those specified in both the METHODS and
     OVERRIDES sections of an OBJECT type declaration.  One can think
     of the METHODS as 'overriding' the implicit defaults, which could
     be any value (including NIL) of the appropriate type.
  *)     
  VAR node := NEW (OverrideList);
  VAR type := s.cur_type;
  BEGIN
    GetName (s, node.supertype, ' ');
    node.offset := GetInteger (s, ' ');
    GetName (s, node.Cname, '\n');
    IF (type = NIL) THEN
      OutsideTypeDeclError (s, "method override")
    ELSE
      node.next := type.overrides;
      type.overrides := node;
    END;
    RETURN FALSE;
  END ReadOverride;
(* end KRML *)

PROCEDURE SkipComment (VAR s: State): BOOLEAN =
  VAR ch := '/';
  BEGIN
    WHILE (ch # '\n') DO ch := GetC (s) END;
    RETURN FALSE;
  END SkipComment;

PROCEDURE SkipBlank (<*UNUSED*> VAR s: State): BOOLEAN =
  BEGIN
    RETURN FALSE;
  END SkipBlank;

PROCEDURE GetInteger (VAR s: State;  term: CHAR): INTEGER =
  VAR n   := 0;
  VAR len := 0;
  VAR ch: CHAR;
  BEGIN
    LOOP
      ch := s.buf [s.buf_ptr];
      INC (s.buf_ptr);
      IF (ch < '0') OR ('9' < ch) THEN
        (* NOTE: none of the stop characters are legal digits *)
        IF (s.buf_ptr <= s.buf_len) THEN EXIT END;
        ch := GetC (s);
        IF (ch < '0') OR ('9' < ch) THEN EXIT END;
      END;
      n := 10 * n + (ORD (ch) - ORD ('0'));
      INC (len);
    END;
    IF (len <= 0)  THEN Error (s, "expected integer") END;
    IF (ch # term) THEN Error (s, "expecting separator after integer") END;
    RETURN n;
  END GetInteger;

PROCEDURE GetMultiLine (VAR s: State): Text.T =
  VAR result: Text.T := "";
  VAR start, len, column: CARDINAL;  stop: INTEGER;
  VAR ch: CHAR;
  BEGIN
    start := s.buf_ptr;
    LOOP
      WHILE (s.buf[start] # '\n') DO INC (start) END;
      IF (start < s.buf_len) THEN EXIT END;
      RefillBuffer (s);
      IF EOF (s) THEN RETURN result END;
      start := 0;
    END;

    (* scan for the terminating '*' *)
    INC (start); (* skip the newline *)
    column := 0;
    stop := start;
    LOOP
      ch := s.buf[stop];
      IF (ch = '*') AND (column = 0) THEN
        len := MAX (0, MIN (s.buf_len, stop) - start);
        result := result & Text.FromChars (SUBARRAY (s.buf, start, len));
        IF (stop < s.buf_len) THEN
          s.buf_ptr := stop + 1;
          RETURN result;
        END;
        ch := s.buf[s.buf_len-1];
        RefillBuffer (s);
        start := 0;
        stop := -1;
      END;
      INC (column); IF (ch = '\n') THEN column := 0 END;
      INC (stop);
    END;
  END GetMultiLine;

PROCEDURE GetName (VAR s: State;  VAR n: Name;  term: CHAR) =
(* Note: we don't need to check for array overruns since all calls
   to GetString include a terminating character that's in the "stop set"
   at the end of the buffer *)
  VAR stop, start, len: CARDINAL;  hash: INTEGER;  overflow: TEXT;  ch: CHAR;
  BEGIN
    start := s.buf_ptr;
    stop  := start;
    hash  := 0;
    LOOP
      ch := s.buf[stop];
      IF (ch = term) THEN EXIT END;
      hash := Word.Plus (Word.Times (hash, 17), ORD (ch));
      INC (stop)
    END;

    IF (stop < s.buf_len) THEN
      (* this is the simple case, the string's entirely in the buffer *)
      s.buf_ptr := stop + 1;
      n.hash := hash;
      n.text := M3LinkAtom.FromChars (SUBARRAY (s.buf,start,stop-start), hash);
      RETURN;
    END;

    overflow := "";
    LOOP
      (* we've overrun the end of the buffer *)
      (* save the current string & refill the buffer *)
      len := MAX (s.buf_len - start, 0);
      overflow := overflow & Text.FromChars (SUBARRAY (s.buf, start, len));
      RefillBuffer (s);
      start := 0;
      stop := 0;

      IF EOF (s) THEN
        n.hash := TextHash (overflow);
        n.text := M3LinkAtom.FromText (overflow, n.hash);
        RETURN;
      END;

      LOOP
        ch := s.buf[stop];
        IF (ch = term) THEN EXIT END;
        INC (stop)
      END;

      IF (stop < s.buf_len) THEN
        (* we terminated inside the buffer *)
        s.buf_ptr := stop + 1;
        len := stop - start;
        overflow := overflow & Text.FromChars (SUBARRAY (s.buf, start, len));
        n.hash := TextHash (overflow);
        n.text := M3LinkAtom.FromText (overflow, n.hash);
        RETURN;
      END;
    END;

  END GetName;

PROCEDURE TextHash (t: TEXT): INTEGER =
  VAR hash := 0;
  BEGIN
    FOR i := 0 TO Text.Length (t) - 1 DO
      hash := Word.Plus (Word.Times (hash, 17), ORD (Text.GetChar (t, i)));
    END;
    RETURN hash;
  END TextHash;

PROCEDURE GetStamp (VAR s: State;  VAR x: StampData;  term: CHAR) =
  VAR ch: CHAR;  buf: ARRAY [0..15] OF CHAR;  len: INTEGER := 0;
    val, digit: INTEGER;
  BEGIN
    LOOP
      ch := GetC (s);
      IF (ch = term) THEN EXIT END;
      IF (len = NUMBER (buf)) THEN
        Error (s, "version stamp too long!");
      ELSIF (len < NUMBER (buf)) THEN
        buf[len] := ch;
      END;
      INC (len);
    END;
    len := MIN (len, NUMBER (buf));

    (* convert the buffered characters into a pair of integers *)
    val := 0;
    FOR i := MAX (0, len-16) TO (len-9) DO
      digit := HexDigit [buf[i]];
      IF (digit > 15) THEN Error (s, "illegal hex digit in version stamp") END;
      val := Word.Plus (Word.Times (val, 16), digit);
    END;
    x[0] := val;

    val := 0;
    FOR i := MAX (0, len-8) TO (len-1) DO
      digit := HexDigit [buf[i]];
      IF (digit > 15) THEN Error (s, "illegal hex digit in version stamp") END;
      val := Word.Plus (Word.Times (val, 16), digit);
    END;
    x[1] := val;

  END GetStamp;

(*------------------------------------------------------------------------*)

PROCEDURE GetC (VAR s: State): CHAR =
  VAR c: CHAR;
  BEGIN
    IF (s.buf_ptr >= s.buf_len) THEN RefillBuffer (s) END;
    c := s.buf [s.buf_ptr];
    INC (s.buf_ptr);
    RETURN c;
  END GetC;

PROCEDURE EOF (VAR s: State): BOOLEAN =
  <*FATAL Rd.Failure*>
  BEGIN
    RETURN (s.buf_ptr >= s.buf_len) AND Rd.EOF (s.rd);
  END EOF;

PROCEDURE RefillBuffer (VAR s: State) =
  <*FATAL Rd.Failure*>
  BEGIN
    s.buf_len := Rd.GetSub (s.rd, SUBARRAY (s.buf, 0, Buffer_size));
    s.buf [s.buf_len + 0] := End_of_buffer;
    s.buf [s.buf_len + 1] := ' ';
    s.buf [s.buf_len + 2] := '\n';
    s.buf [s.buf_len + 3] := '*';
    s.buf [s.buf_len + 4] := '\"';
    s.buf_ptr := 0;
  END RefillBuffer;

(*------------------------------------------------------------------------*)

PROCEDURE OutsideTypeDeclError (VAR s: State;  a: Text.T) =
  BEGIN
    Error (s, a, " outside type declaration!")
  END OutsideTypeDeclError;

PROCEDURE MultipleInTypeError (VAR s: State;  a: Text.T;  type: Type) =
  BEGIN
    Error (s, "multiple ", a, "s for ", TypeName (type));
  END MultipleInTypeError;

PROCEDURE Error (VAR s: State;  a, b, c, d: Text.T := NIL) =
  BEGIN
    INC  (s.nErrors);
    IF (s.errors = NIL) THEN RETURN END;
    IF (s.cur_file # NIL) AND (s.cur_file.name # NIL) THEN
      Wr.PutText (s.errors, s.cur_file.name);
      IF (s.cur_unit # NIL) THEN
        Wr.PutText (s.errors, " (");
        IF ((s.cur_type # NIL) AND (s.cur_type.name = NIL))
          OR ((s.cur_utype # NIL) AND (s.cur_utype.name = NIL))
          OR ((s.cur_type = NIL) AND (s.cur_utype = NIL)) THEN
          Wr.PutText (s.errors, UnitName (s.cur_unit));
          IF (s.cur_type # NIL) OR (s.cur_utype # NIL) THEN
            Wr.PutText (s.errors, " in ");
          END;
        END;
        IF (s.cur_type # NIL) THEN
          Wr.PutText (s.errors, TypeName (s.cur_type));
        END;
        IF (s.cur_utype # NIL) THEN
          Wr.PutText (s.errors, UTypeName (s.cur_utype));
        END;
        Wr.PutText (s.errors, ")");
      END;
      Wr.PutText (s.errors, ": ");
    END;
    Wr.PutText (s.errors, "ERROR: ");
    IF (a # NIL) THEN Wr.PutText (s.errors, a); END;
    IF (b # NIL) THEN Wr.PutText (s.errors, b); END;
    IF (c # NIL) THEN Wr.PutText (s.errors, c); END;
    IF (d # NIL) THEN Wr.PutText (s.errors, d); END;
    Wr.PutText (s.errors, "\n");
  END Error;

PROCEDURE CharName (c: CHAR): Text.T =
  BEGIN
    IF (' ' <= c) AND (c <= '~')
      THEN RETURN "\'" & Text.FromChar (c) & "\'" ;
      ELSE RETURN "\'\\" & Fmt.Pad (Fmt.Int (ORD (c), 8), 3, '0') & "\'" ;
    END;
  END CharName;


PROCEDURE Init () =
  BEGIN
    FOR i := FIRST (HexDigit) TO LAST (HexDigit) DO HexDigit[i] := 16 END;
    FOR i := '0' TO '9' DO HexDigit [i] := ORD (i) - ORD ('0') END;
    FOR i := 'a' TO 'f' DO HexDigit [i] := ORD (i) - ORD ('a') + 10 END;
    FOR i := 'A' TO 'F' DO HexDigit [i] := ORD (i) - ORD ('A') + 10 END;

    FOR c := FIRST (CmdMap) TO LAST (CmdMap) DO CmdMap[c] := BadChar END;
    CmdMap ['Z'] := ReadFileMagic;
    CmdMap ['I'] := ReadUnit;
    CmdMap ['M'] := ReadUnit;
    CmdMap ['A'] := ReadPort;
    CmdMap ['B'] := ReadPort;
    CmdMap ['g'] := ReadGeneric;
    CmdMap ['i'] := ReadVersionStamp;
    CmdMap ['e'] := ReadVersionStamp;
    CmdMap ['K'] := ReadNumberedVersionStamp;
    CmdMap ['V'] := ReadNumberedVersionStamp;
    CmdMap ['G'] := ReadCopiedVersionStamp;
    CmdMap ['W'] := ReadCopiedVersionStamp;
    CmdMap ['R'] := ReadRevelation;
    CmdMap ['X'] := ReadRevelation;
    CmdMap ['r'] := ReadRevelation;
    CmdMap ['x'] := ReadRevelation;
    CmdMap ['t'] := ReadType;
    CmdMap ['H'] := ReadNumberedType;
    CmdMap ['Q'] := ReadCopiedType;
    CmdMap ['u'] := ReadUndefinedType;
    CmdMap ['J'] := ReadNumberedUType;
    CmdMap ['U'] := ReadCopiedUType;
    CmdMap ['d'] := ReadTypeDependency;
    CmdMap ['D'] := ReadPreDecl;
    CmdMap ['C'] := ReadDecl;
    CmdMap ['O'] := ReadTypeMethodDecl;
    CmdMap ['S'] := ReadSupertype;
    CmdMap ['N'] := ReadTypeName;
    CmdMap ['/'] := SkipComment;
    CmdMap [' '] := SkipBlank;
    CmdMap ['\t'] := SkipBlank;
    CmdMap ['\n'] := SkipBlank;
    CmdMap [End_of_buffer] := EndBuffer;
    (* new KRML *)
    CmdMap ['k'] := ReadTraced;
    CmdMap ['l'] := ReadBrand;
    CmdMap ['o'] := ReadOverride;
    CmdMap ['n'] := ReadInitProcName;
    CmdMap ['m'] := ReadMapProcName;
    CmdMap ['b'] := ReadTracedOffsets;
    CmdMap ['s'] := ReadSigEncoding;
    (* end KRML *)
  END Init;

BEGIN
  Init ();
END M3LinkerRd.