OberonCore

newArray: POINTER TO ARRAY OF REAL;
...
NEW(newArray, 10);
...
Занесли данные в массив
...
Возникла необходимость добавить новые данные в массив

MODULE OmcDynAr;
   IMPORT Kernel, S := SYSTEM;
   
   (* TODO: должен быть резерв по-умолчанию. И сейчас SetReserve вызывает релокацию, лишнюю.
      Сделать процедуры копирования участков дин. массивов. *)

   CONST
      reserveOff = FALSE;

   TYPE
      Block = POINTER TO RECORD [untagged]
         tag: Kernel.Type;
         last: INTEGER;      (* arrays: last element *)
         actual: INTEGER;   (* arrays: used during mark phase *)
         first: INTEGER;      (* arrays: first element *)
         len: ARRAY 16 OF INTEGER
      END;
   
   PROCEDURE ^ SetReserve* (VAR array: S.PTR; count: INTEGER);

   PROCEDURE SetLength* (VAR array: S.PTR; len: INTEGER);
      VAR old: INTEGER; (* Old array address *)
            tag: INTEGER; (* Old array tag *)
            type: Kernel.Type; (* Elem type *)
            oldBlock: Block; (* Old array block *)
            dim: INTEGER; (* Dimension of array *)
            oldSize, oldLen: INTEGER; (* Size of array block (in elem count), array actual len *)
            reserve: INTEGER; (* If array has been resized with Reserve proc, it's reserved count *)
            (* For new array *)
            new: INTEGER;
            newSize: INTEGER;
            newBlock: Block;
            i, j: INTEGER;
   BEGIN
      (* Parsing array params *)
      ASSERT(len >= 0, 20);
      S.GET(S.ADR(array), old);
      ASSERT(old # 0, 21);

      S.GET(old-SIZE(INTEGER), tag);
      ASSERT(1 IN BITS(tag), 22); (* Check array mark *)
      type := S.VAL(Kernel.Type, tag-2);
      oldBlock := S.VAL(Block, old-SIZE(INTEGER));
      dim := (oldBlock.first - old - 3*SIZE(INTEGER)) DIV 4;
      ASSERT(dim = 1, 23);

      oldSize := (oldBlock.last - oldBlock.first) DIV type.size + 1;
      S.GET(old + 3*SIZE(INTEGER), oldLen);
      
      reserve := oldSize - oldLen;
      ASSERT(0 <= reserve, 24);
      
      IF len <= oldSize THEN
         S.PUT(old + 3*SIZE(INTEGER), len);
         IF len < oldLen THEN
            (* FillMemory(oldBlock.first + oldLen * type.size, (len - oldLen) * type.size, 0) *)
               j := oldBlock.first + oldLen * type.size;
               FOR i := 0 TO (len - oldLen) * type.size -1 DO
                  S.PUT(j + i, S.VAL(BYTE, 0))
               END
         END
      ELSE
         newSize := len + reserve;
         new := Kernel.NewArr(S.VAL(INTEGER, type), newSize, 1);
         newBlock := S.VAL(Block, new-SIZE(INTEGER));
         S.PUT(new + 3*SIZE(INTEGER), len);
         S.MOVE(oldBlock.first, newBlock.first, MIN(oldLen, len) * type.size);
         S.PUT(S.ADR(array), new)
      END
   END SetLength;

   PROCEDURE BaseType (type: Kernel.Type): INTEGER;
   BEGIN
      IF (type.mod.name = "Kernel") & (type.fields.num = 1) THEN
         RETURN S.VAL(INTEGER, type.fields.obj[0].struct)
      ELSE
         RETURN S.VAL(INTEGER, type)
      END
   END BaseType;

   PROCEDURE SetReserve* (VAR array: S.PTR; count: INTEGER);
      VAR old: INTEGER; (* Old array address *)
            tag: INTEGER; (* Old array tag *)
            type: Kernel.Type; (* Elem type *)
            oldBlock: Block; (* Old array block *)
            dim: INTEGER; (* Dimension of array *)
            oldSize, oldLen: INTEGER; (* Size of array block (in elem count), array actual len *)
            reserve: INTEGER; (* If array has been resized with Reserve proc, it's reserved count *)
            (* For new array *)
            new: INTEGER;
            newSize: INTEGER;
            newBlock: Block;
            i, j: INTEGER;
   BEGIN
      IF reserveOff & (count # 0) THEN RETURN END;
      (* Parsing array params *)
      ASSERT(count >= 0, 20);
      S.GET(S.ADR(array), old);
      ASSERT(old # 0, 21);

      S.GET(old-SIZE(INTEGER), tag);
      ASSERT(1 IN BITS(tag), 22); (* Check array mark *)
      type := S.VAL(Kernel.Type, tag-2);
      
      oldBlock := S.VAL(Block, old-SIZE(INTEGER));
      dim := (oldBlock.first - old - 3*SIZE(INTEGER)) DIV 4;
      ASSERT(dim = 1, 23); (* Array is dynamic one-dimensional *)

      oldSize := (oldBlock.last - oldBlock.first) DIV type.size + 1;
      S.GET(old + 3*SIZE(INTEGER), oldLen);

      IF oldLen < oldSize THEN (* If array has been resised... *)
         S.GET(oldBlock.last, reserve)  (* lookup mark by Reserve proc *)
      ELSE
         reserve := 0
      END;

      IF (reserve = count + 1) OR ((reserve = 0) & (count = 0)) THEN RETURN END;

      (* Calc new array size (in elem count) *)
      IF count = 0 THEN
         newSize := oldLen
      ELSE
         newSize := oldLen + count + 1
      END;

      (* Cteating new array *)
      new := Kernel.NewArr(S.VAL(INTEGER, type), newSize, 1);
      newBlock := S.VAL(Block, new-SIZE(INTEGER));
      IF (count > 0) & (BaseType(type) # 13) THEN
         S.PUT(newBlock.last, count + 1) (* set reserve mark for non-pointer arrays *)
      END;
      S.PUT(new + 3*SIZE(INTEGER), oldLen);
      (* Copying old array *)
      S.MOVE(oldBlock.first, newBlock.first, oldLen * type.size);
      S.PUT(S.ADR(array), new)
   END SetReserve;
   
END OmcDynAr.