Когда-то давно эти функции входили в мою библиотеку Mt, которую мы потом сняли с публикации.
Дать однозначно рекомендации по тому "хороший стиль это или нет" - использовать релокацию массивов, не знаю...
В своё время я перестал использовать и распространять этот модуль в силу соображений, что он завязан на внутренние соглашения ядра ББ, которое может меняться разработчикам (так, что релокация станет, допустим, невозможной вообще).
Сейчас, однако, с переходом ББ в развитие сообществом(ами), этот фактор уже некритичен.
Так что, если хотите, пользуйтесь.
Код:
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.