gcc/m2/gm2-libs-iso/RTentity.mod

(* RTentity.mod implements a grouping of different opaque types.

Copyright (C) 2008-2023 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE RTentity ;

FROM libc IMPORT malloc, free ;
FROM M2RTS IMPORT Halt ;
FROM RTco IMPORT init, initSemaphore, wait, signal ;

TYPE
   Group = POINTER TO RECORD
                         left, right:  Group ;
                         entity     :  SYSTEM.ADDRESS ;
                         entityKey  :  CARDINAL ;
                      END ;


PROCEDURE InitGroup () : Group ;
VAR
   g: Group ;
BEGIN
   checkInitialized ;
   wait (mutex) ;
   g := malloc (SIZE (g^)) ;
   WITH g^ DO
      left := NIL ;
      right := NIL ;
      entity := NIL ;
      entityKey := 0
   END ;
   signal (mutex) ;
   RETURN g
END InitGroup ;


(*
   killGroup -
*)

PROCEDURE killGroup (g: Group) : Group ;
BEGIN
   IF g # NIL
   THEN
      WITH g^ DO
         left := killGroup (left) ;
         right := killGroup (right)
      END ;
      free (g)
   END ;
   RETURN NIL
END killGroup ;



PROCEDURE KillGroup (g: Group) : Group ;
BEGIN
   wait (mutex) ;
   g := killGroup (g) ;
   signal (mutex) ;
   RETURN g
END KillGroup ;


PROCEDURE GetKey (g: Group; a: SYSTEM.ADDRESS) : CARDINAL ;
VAR
   parent,
   child : Group ;
BEGIN
   assert (initialized) ;
   wait (mutex) ;
   findChildAndParent (g, a, child, parent) ;
   signal (mutex) ;
   IF child = NIL
   THEN
      RETURN 0
   ELSE
      RETURN child^.entityKey
   END
END GetKey ;


PROCEDURE PutKey (g: Group; a: SYSTEM.ADDRESS; key: CARDINAL) ;
VAR
   parent,
   child : Group ;
BEGIN
   assert (initialized) ;
   wait (mutex) ;
   findChildAndParent (g, a, child, parent) ;
   IF child = NIL
   THEN
      (* no child found, now is, a, less than parent or greater? *)
      IF parent = g
      THEN
         (* empty tree, add it to the left branch of t *)
         child := malloc (SIZE (child^)) ;
         parent^.left := child
      ELSE
         (* parent is a leaf node *)
         IF a < parent^.entity
         THEN
            child := malloc (SIZE (child^)) ;
            parent^.left := child
         ELSIF a > parent^.entity
         THEN
            child := malloc (SIZE (child^)) ;
            parent^.right := child
         END
      END ;
      WITH child^ DO
         right     := NIL ;
         left      := NIL ;
         entity    := a ;
         entityKey := key
      END
   ELSE
      Halt ('internal runtime error, entity already stored',
            __FILE__, __FUNCTION__, __LINE__)
   END ;
   signal (mutex)
END PutKey ;


PROCEDURE IsIn (g: Group; a: SYSTEM.ADDRESS) : BOOLEAN ;
VAR
   child, parent: Group ;
BEGIN
   assert (initialized) ;
   wait (mutex) ;
   findChildAndParent (g, a, child, parent) ;
   signal (mutex) ;
   RETURN child # NIL
END IsIn ;


(*
   DelKey - deletes an entry in the binary tree.

            NB in order for this to work we must
            ensure that the InitGroup sets
            both left and right to NIL.
*)

PROCEDURE DelKey (g: Group; a: SYSTEM.ADDRESS) ;
VAR
   i, child, parent: Group ;
BEGIN
   assert (initialized) ;
   wait (mutex) ;
   (* find parent and child of the node *)
   findChildAndParent (g, a, child, parent) ;
   IF (child # NIL) AND (child^.entity = a)
   THEN
      (* Have found the node to be deleted *)
      IF parent^.right = child
      THEN
         (* Node is child and this is greater than the parent. *)
         (* Greater being on the right.                        *)
         (* Connect child^.left onto the parent^.right.        *)
         (* Connect child^.right onto the end of the right     *)
         (* most branch of child^.left.                        *)
         IF child^.left # NIL
         THEN
            (* Scan for right most node of child^.left *)
            i := child^.left ;
            WHILE i^.right # NIL DO
               i := i^.right
            END ;
            i^.right      := child^.right ;
            parent^.right := child^.left
         ELSE
            (* No child^.left node therefore link over child   *)
            (* (as in a single linked list) to child^.right    *)
            parent^.right := child^.right
         END ;
         free (child)
      ELSE
         (* assert that parent^.left=child will always be true *)
         (* Perform exactly the mirror image of the above code *)

         (* Connect child^.right onto the parent^.left.        *)
         (* Connect child^.left onto the end of the left most  *)
         (* branch of child^.right                             *)
         IF child^.right # NIL
         THEN
            (* Scan for left most node of child^.right *)
            i := child^.right ;
            WHILE i^.left # NIL DO
               i := i^.left
            END ;
            i^.left      := child^.left ;
            parent^.left := child^.right
         ELSE
            (* No child^.right node therefore link over c      *)
            (* (as in a single linked list) to child^.left.    *)
            parent^.left := child^.left
         END ;
         free (child)
      END
   ELSE
      Halt('internal runtime error, trying to delete an entity which is not in the tree',
           __FILE__, __FUNCTION__, __LINE__)
   END ;
   signal (mutex)
END DelKey ;


(*
   findChildAndParent - find a node, child, in a binary tree, t, with name
                        equal to n.  If an entry is found, parent is set
                        to the node above child.
*)

PROCEDURE findChildAndParent (t: Group; a: SYSTEM.ADDRESS;
                              VAR child, parent: Group) ;
BEGIN
   (* remember to skip the sentinal value and assign parent and child *)
   parent := t ;
   IF t = NIL
   THEN
      Halt ('internal runtime error, RTentity is either corrupt or the module storage has not been initialized yet',
            __FILE__, __FUNCTION__, __LINE__)
   END ;
   child := t^.left ;
   IF child # NIL
   THEN
      REPEAT
         IF a < child^.entity
         THEN
            parent := child ;
            child := child^.left
         ELSIF a > child^.entity
         THEN
            parent := child ;
            child := child^.right
         END
      UNTIL (child = NIL) OR (a = child^.entity)
   END
END findChildAndParent ;


(*
   assert - simple assertion procedure.
*)

PROCEDURE assert (condition: BOOLEAN) ;
BEGIN
   IF NOT condition
   THEN
      Halt ('internal runtime error, RTentity is either corrupt or the module storage has not been initialized yet',
            __FILE__, __FUNCTION__, __LINE__)
   END
END assert ;


(*
   checkInitialized -
*)

PROCEDURE checkInitialized ;
VAR
   result: INTEGER ;
BEGIN
   IF NOT initialized
   THEN
      initialized := TRUE ;
      result := init () ;
      mutex := initSemaphore (1)
   END
END checkInitialized ;


VAR
   initialized: BOOLEAN ;  (* Set to FALSE when the bss is created.  *)
   mutex      : INTEGER ;

END RTentity.