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

(* Last modified on Thu Nov  7 08:51:04 PST 1991 by kalsow    *)
(*      modified on Sat Mar  9 01:34:26 1991 by muller        *)
(*      modified on Thu Nov  8 14:21:56 PST 1990 by crelier   *)

UNSAFE MODULE PklRead EXPORTS Pkl, PklRep;

IMPORT RTHeap, RTType, RTTypeFP, RTProc, Rd, Text, Thread;

TYPE
  State = REF RECORD
    rd          : Rd.T;
    nObjects    : INTEGER;
    objectsSize : INTEGER;
    specsSize   : INTEGER;
    nSpecs      : INTEGER;
    nTypes      : INTEGER;
    nProcs      : INTEGER;
    rootIndex   : INTEGER;
    locToTc     : REF ARRAY OF INTEGER;
    objRef      : REF ARRAY OF REFANY;
    procAdr     : REF ARRAY OF ADDRESS;
  END;

PROCEDURE Read (rd: Rd.T): REFANY RAISES {Rd.Failure, Thread.Alerted, Error} =
  VAR s := NEW (State);  objectsPos, endPos: CARDINAL;
  BEGIN
    Init ();
    s.rd := rd;
    ReadHeader (s);
    IF s.rootIndex = -1 THEN RETURN NIL END;
    objectsPos := Rd.Index (s.rd);
    Rd.Seek (s.rd, objectsPos + s.objectsSize + s.specsSize);
    ReadTypes (s);
    ReadProcs (s);
    endPos := Rd.Index (s.rd);
    Rd.Seek (s.rd, objectsPos);
    RTHeap.DisableCollection ();
    TRY
      ReadObjects (s);
      ReadSpecs (s);
      Rd.Seek (s.rd, endPos);
      FixupRefsAndProcs (s);
    FINALLY
      RTHeap.EnableCollection ();
    END;
    ApplyConv (s);
    RETURN s.objRef[s.rootIndex]
  END Read;
    
PROCEDURE ReadHeader (s: State) RAISES {Rd.Failure, Thread.Alerted, Error} =
  VAR t: TEXT;  version: INTEGER;
  BEGIN
    t := Rd.GetText(s.rd, 4);
    version := GetInt (s);
    IF NOT Text.Equal(t, "PPkl") OR (version # Version) THEN
      RAISE Error(Code.BadVersion)
    END;
    s.nObjects    := GetInt (s);
    s.objectsSize := GetInt (s);
    s.nSpecs      := GetInt (s);
    s.specsSize   := GetInt (s);
    s.nTypes      := GetInt (s);
    s.nProcs      := GetInt (s);
    s.rootIndex   := GetInt (s);
  END ReadHeader;

PROCEDURE ReadTypes (s: State) RAISES {Rd.Failure, Thread.Alerted, Error} =
  VAR fp: RTTypeFP.Fingerprint;  tc: RTType.Typecode;
  BEGIN
    s.locToTc := NEW(REF ARRAY OF INTEGER, s.nTypes);
    FOR ltc := 0 TO s.nTypes-1 DO
      FOR i := FIRST(fp) TO LAST(fp) DO  fp[i] := GetInt (s)  END;
      tc := RTTypeFP.FromFingerprint(fp);
      IF tc = RTType.NoSuchType THEN RAISE Error(Code.UnknownType) END;
      s.locToTc[ltc] := tc
    END;
  END ReadTypes;

PROCEDURE ReadProcs (s: State) RAISES {Rd.Failure, Thread.Alerted, Error} =
  VAR fp: RTProc.Fingerprint;  val: ADDRESS;
  BEGIN
    s.procAdr := NEW(REF ARRAY OF ADDRESS, s.nProcs);
    FOR i := 0 TO s.nProcs-1 DO
      FOR j := FIRST(fp) TO LAST(fp) DO  fp[j] := GetInt (s)  END;
      val := RTProc.FromFingerprint(fp);
      IF val = NIL THEN RAISE Error(Code.UnknownProc) END;
      s.procAdr[i] := val
    END
  END ReadProcs;
  
PROCEDURE ReadObjects (s: State) RAISES {Rd.Failure, Thread.Alerted} =
  VAR ltc, ndim: INTEGER;  tc: RTType.Typecode;  r: REFANY;
      shape: ARRAY [0..999] OF INTEGER;
  BEGIN
    s.objRef := NEW(REF ARRAY OF REFANY, s.nObjects + s.nSpecs);
    FOR i := 0 TO s.nObjects-1 DO
      ltc := GetInt (s);
      tc := s.locToTc[ltc];
      ndim := RTHeap.GetNDimensions(tc);
      IF ndim > 0 THEN
        EVAL Rd.GetSub(s.rd, SUBARRAY(LOOPHOLE(ADR(shape), ToChars)^, 0,
          BYTESIZE(INTEGER)*ndim));
        r := RTHeap.FastAllocateOpenArray(tc, SUBARRAY(shape, 0, ndim))
      ELSE
        r := RTHeap.FastAllocate(tc)
      END;
      s.objRef[i] := r;
      EVAL Rd.GetSub(s.rd, SUBARRAY(
        LOOPHOLE(RTHeap.GetDataAdr(r), ToChars)^, 0, RTHeap.GetDataSize(r)))
    END
  END ReadObjects;

PROCEDURE ReadSpecs (s: State) RAISES {Error, Rd.Failure, Thread.Alerted} =
  VAR i, len: INTEGER;
      tc, ltc: RTType.Typecode;
      r: REFANY;
      rdp: ReadBytesProc;
      bytes := NEW(REF ARRAY OF CHAR, s.specsSize);
  BEGIN
    EVAL Rd.GetSub(s.rd, bytes^);
    i := 0;
    FOR index := 0 TO s.nSpecs-1 DO
      ltc := LOOPHOLE(ADR(bytes[i]), REF INTEGER)^;
      len := LOOPHOLE(ADR(bytes[i+BYTESIZE(INTEGER)]), REF INTEGER)^;
      tc := s.locToTc[ltc];
      rdp := procs[tc].rdbytes;
      IF rdp = NIL THEN
        RAISE Error(Code.NoReadBytesProc)
      END;
      r := rdp(SUBARRAY(bytes^, i+2*BYTESIZE(INTEGER), len));
      s.objRef[index + s.nObjects] := r;
      IF NOT RTType.IsSubtype(TYPECODE(r), tc) THEN
        RAISE Error(Code.WrongType);
      END;
      INC(i, len + 2*BYTESIZE(INTEGER));
    END;
  END ReadSpecs;

PROCEDURE FixupRefsAndProcs (s: State) =
  CONST Mask = RTType.RefTypeSet{RTType.RefType.Traced, RTType.RefType.Proc};
  BEGIN
    FOR i := 0 TO s.nObjects-1 DO
      <*FATAL ANY*> BEGIN
        RTType.Visit (s, s.objRef[i], Fixup, Mask);
      END;
    END;
  END FixupRefsAndProcs;

PROCEDURE Fixup(arg     : REFANY;
                fldadr  : ADDRESS;
     <*UNUSED*> objadr  : ADDRESS;
                fldtype : RTType.RefType) =
  VAR s: State := arg;  fld: INTEGER;
  BEGIN
    fld := LOOPHOLE(fldadr, REF INTEGER)^;
    IF fld # LOOPHOLE(NIL, INTEGER) THEN
      IF fldtype = RTType.RefType.Traced THEN
        IF fld < FirstSpec THEN
          LOOPHOLE(fldadr, REF REFANY)^ := s.objRef[fld - FirstObj]
        ELSE
          LOOPHOLE(fldadr, REF REFANY)^ :=
                                         s.objRef[fld - FirstSpec + s.nObjects]
        END
      ELSE (* fldtype = RTType.RefType.Proc *)
        LOOPHOLE(fldadr, REF ADDRESS)^ := s.procAdr[fld - FirstProc]
      END
    END
  END Fixup;

PROCEDURE ApplyConv (s: State) =
  VAR r: REFANY;  conv: ConvertList;
  BEGIN
    FOR i := s.nObjects+s.nSpecs-1 TO 0 BY -1 DO
      r := s.objRef[i];
      conv := procs[TYPECODE(r)].first;
      WHILE conv # NIL DO
        procs[conv.tc].rdconv(r);
        conv := conv.next
      END
    END
  END ApplyConv;

PROCEDURE GetInt (s: State): INTEGER  RAISES {Rd.Failure, Thread.Alerted} =
  VAR len: INTEGER;  val: Integer;
  BEGIN
    len := Rd.GetSub (s.rd, val);
    <* ASSERT len = BYTESIZE (INTEGER) *>
    RETURN LOOPHOLE (val, INTEGER);
  END GetInt;

BEGIN
END PklRead.