MODULE HeapStream;

(***************************************************************************)
(*                      Copyright (C) Olivetti 1989                        *)
(*                          All Rights reserved                            *)
(*                                                                         *)
(* Use and copy of this software and preparation of derivative works based *)
(* upon this software are permitted to any person, provided this same      *)
(* copyright notice and the following Olivetti warranty disclaimer are     *) 
(* included in any copy of the software or any modification thereof or     *)
(* derivative work therefrom made by any person.                           *)
(*                                                                         *)
(* This software is made available AS IS and Olivetti disclaims all        *)
(* warranties with respect to this software, whether expressed or implied  *)
(* under any law, including all implied warranties of merchantibility and  *)
(* fitness for any purpose. In no event shall Olivetti be liable for any   *)
(* damages whatsoever resulting from loss of use, data or profits or       *)
(* otherwise arising out of or in connection with the use or performance   *)
(* of this software.                                                       *)
(***************************************************************************)

IMPORT IO, IO_impl;

CONST
  BlockSize = 1024;


TYPE
  HeapBlockRef = REF RECORD
    next, prev: HeapBlockRef;
    offset: CARDINAL;
    buffer: ARRAY [0..BlockSize - 1] OF CHAR;
  END;

  HeapStream = IO.Stream OBJECT
    first, current, last: HeapBlockRef := NIL;
    offset: CARDINAL := 0; (* offset in current block *)
  OVERRIDES
    implFlush := Flush;
    implFill := Fill;
    implSeek := Seek;
    implTruncate := Truncate;
  END;


PROCEDURE NewBlock(s: HeapStream): HeapBlockRef RAISES {} =
  VAR
    b := NEW(HeapBlockRef);
  BEGIN
    b.next := NIL;
    b.prev := s.last;
    IF s.last = NIL THEN
      b.offset := 0;
      s.first := b;
    ELSE
      b.offset := s.last.offset + BlockSize;
      s.last.next := b;
    END;
    s.last := b;
    RETURN b;
  END NewBlock;


PROCEDURE Flush(
    s: HeapStream;
    READONLY chars: ARRAY OF CHAR)
    : BOOLEAN
    RAISES {} =
  VAR
    number := NUMBER(chars);
    pos: CARDINAL := 0;
  BEGIN
    WITH current = s.current DO
      (* Note any flushes of 'BlockSize' or greater are guaranteed to
       be block aligned *)
      WHILE pos + BlockSize <= number DO
        IF current = NIL THEN current := NewBlock(s) END;
        current.buffer := SUBARRAY(chars, pos, BlockSize);
        current := current.next;
        INC(pos, BlockSize);
      END;
      (* Flush any partial blocks; may not be block aligned and we may
       become aligned after the flush *)
      WITH remainder = number - pos DO
        IF remainder > 0 THEN
          IF current = NIL THEN current := NewBlock(s) END;
          SUBARRAY(current.buffer, s.offset, remainder) :=
              SUBARRAY(chars, pos, remainder);
          INC(s.offset, remainder);
          IF s.offset = BlockSize THEN
            current := current.next;
            s.offset := 0;
          END;
        END;
      END;
    END;
    RETURN TRUE;
  END Flush;


PROCEDURE Fill(s: HeapStream; VAR chars: ARRAY OF CHAR): INTEGER RAISES {} =
  VAR
    number := NUMBER(chars);
    pos: CARDINAL := 0;
  BEGIN
    (* assert: 's.offset' guaranteed to be zero before 'Fill' called *)
    WITH current = s.current DO
      WHILE pos + BlockSize <= number DO
        SUBARRAY(chars, pos, BlockSize) := current.buffer;
        INC(pos, BlockSize);
        current := current.next;
      END;
      WITH remainder = number - pos DO
        IF remainder > 0 THEN
          SUBARRAY(chars, pos, remainder) :=
              SUBARRAY(current.buffer, 0, remainder);
          s.offset := remainder;
        END;
      END;
    END;
    RETURN number;
  END Fill;


PROCEDURE Seek(s: HeapStream; pos: CARDINAL): BOOLEAN RAISES {} =
  VAR
    high := s.last;
    low := s.first;
    b := s.current;
  BEGIN
    (* assert: 's.first' and 's.last' are not NIL; if they were it would imply
     a zero length stream, in which case 'Seek' would not be called *)
    IF pos >= high.offset THEN
      IF pos < high.offset + BlockSize THEN b := high ELSE b := NIL END;
    ELSE
      IF b # NIL THEN
        IF b.offset > pos THEN high := b ELSE low := b END;
      END;
      IF high.offset - pos < pos - (low.offset + BlockSize) THEN
        b := high;
        REPEAT b := b.prev UNTIL b.offset <= pos;
      ELSE
        b := low;
        WHILE b.offset + BlockSize <= pos DO b := b.next END;
      END;
    END;
    s.current := b;
    s.offset := pos MOD BlockSize;
    RETURN TRUE;
  END Seek;


PROCEDURE Truncate(s: HeapStream; length: CARDINAL): BOOLEAN RAISES {}=
  BEGIN
    IF length = 0 THEN
      s.first := NIL; s.last := NIL; s.current := NIL;
    ELSE
      (* current length must be greater than 'length' and hence greater than 0;
       therefore 's.last' is non NIL and there exists a block for which
       'offset < length'. Current position is guaranteed to be less than
       'length' so 's.current' is not invalidated unless we are truncating
       to the block boundary at the start of 's.current'  *)
      VAR
        b := s.last;
      BEGIN
        WHILE b.offset >= length DO b := b.prev END;
        IF s.current = b.next THEN s.current := NIL END;
        b.next := NIL;
        s.last := b;
      END;
    END;
    RETURN TRUE;
  END Truncate;


PROCEDURE Open(name := "heap"): IO.Stream RAISES {} =
  VAR
    s := NEW(HeapStream);
  BEGIN
    IO_impl.Init(s, NEW(REF ARRAY OF CHAR, BlockSize),
        0, name := name, blockSize := BlockSize); <* UNEXPECTED IO.Error *>
    RETURN s;
  END Open;


BEGIN
END HeapStream.