[Oberon] Dynamically sized allocation with NEW()

[Tomas Kral]

On Thu, 2 Aug 2018 19:38:10 +0200
Jörg <joerg.straube at iaeth.ch> wrote:

> This is obviously not a recipe for all cases, but it shows that you
> can live with NEW without size...

Hi,

I maintain this self allocating bitmap example, as referred `NEW with
size' (becomes obsession of mine, sort of..), I have revisited after
`ORP' recent update. It is not perfect and possibly stands to be
corrected, improved or made simple.

MODULE BM; (*TK 20.9.2017 / 3.8.2018  variable size bitmap example*)
  IMPORT SYSTEM, Kernel, Texts, Oberon;

  TYPE
    Tag = POINTER TO TypeDesc;
    TypeDesc = RECORD 
      size: INTEGER;
      ext: ARRAY 3 OF INTEGER;
      ptr: INTEGER;
      next: Tag
    END; (* see Project Oberon, figure 8.8 *)

    (*Address = POINTER TO RECORD END; (* this pointer will be
    redefined by TypeTag *)*)
  
    Bitmap* = POINTER TO BitmapDesc;
    BitmapDesc = RECORD
      tag: TypeDesc; (* type descriptor of the pointer "base" *)
      mk: INTEGER; (* mark used by GC *)
      base: INTEGER; (* Address *)
      width, height: INTEGER
    END;

  VAR 
     W: Texts.Writer; B*: Bitmap;
     first: Tag; (* first in tag list *)

  PROCEDURE New(w, h: INTEGER): Bitmap;
    VAR b: Bitmap; t: Tag;
  BEGIN
    NEW(b); IF b # NIL THEN
      b.width := w; b.height := h;

      (* the following code defines bitmap type tag *)

      b.tag.size := (w+7) DIV 8 * h; (* bitmap size in bytes *)
      b.tag.size := (b.tag.size+31) DIV 32 * 32; (* allocate multiple
      of 32 byte blocks *)
      b.tag.ext[0] := -1; b.tag.ext[1] := -1; b.tag.ext[2] := -1;
      b.tag.ptr := -1; (* type has no pointers, important for GC *)
      b.mk := 0; (* unmark, GC marks for collection when it stops being
      referenced *)

      (* allocate memory and define its type *)
      Kernel.New(b.base, SYSTEM.ADR(b.tag));

      (* link new bitmap tag to list *)
      b.tag.next := first; first := SYSTEM.VAL(Tag, SYSTEM.ADR(b.tag));

      IF b.base = 0 (*Address = NIL*) THEN b := NIL
      ELSE (* report allocatted size and address *)
        Texts.WriteInt(W, b.tag.size, 6); Texts.WriteInt(W, b.base, 8);
        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
      END

    END (* b # NIL *)
  RETURN b END New;

  PROCEDURE Create*;
    VAR w, h:INTEGER; S: Texts.Scanner;
  BEGIN
    Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
  Texts.Scan(S);
    IF S.class = Texts.Int THEN
      w := S.i; Texts.Scan(S);
      IF S.class = Texts.Int THEN h := S.i END
    END;
    B := New(w, h)
  END Create;

BEGIN Texts.OpenWriter(W); first := NIL
END BM.


Test allocating various block sizes, [width] x [height] in pixels
BM.Create 1 1 ~ this is a dot!
BM.Create 32 1 ~
BM.Create 32 32 ~
BM.Create 256 256 ~
BM.Create 256 1024 ~
BM.Create 1024 1024 ~

And watch system heap
System.Watch  System.Collect  System.Free BM ~

-- 
Tomas Kral <thomas.kral at email.cz>