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

(* File: M3LinkerRd.m3                                         *)
(* Last 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
      Error (s, "undefined type specified outside type declaration!");
    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
      Error (s, "type specified outside type declaration!");
    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
      Error (s, "type dependency outside type declaration!");
    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
      Error (s, ZZ, " outside type declaration!");
    ELSIF type.preDecl # NIL THEN
      Error (s, "multiple ", ZZ, "s for ", TypeName (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
      Error (s, ZZ, " outside type declaration!");
    ELSIF type.decl # NIL THEN
      Error (s, "multiple ", ZZ, "s for ", TypeName (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
      Error (s, ZZ, " outside type declaration!");
    ELSIF (type.methodDecl # NIL) THEN
      Error (s, "multiple ", ZZ, "s for ", TypeName (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
      Error (s, ZZ, " outside type declaration!");
    ELSIF (type.super.text # NIL) THEN
      Error (s, "multiple ", ZZ, "s for ", TypeName (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
      Error (s, "type name outside type declaration!");
    END;
    RETURN FALSE;
  END ReadTypeName;

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 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;
  END Init;

BEGIN
  Init ();
END M3LinkerRd.