# Detection of circularities. Used by the printer and reader.

# ------------------------------ Specification --------------------------------

# get_circularities(obj,pr_array,pr_closure)
# Returns a table of all circularities of an object.
# A circularity is a sub-object, which can be reached from the given object
# through more than one path.
# > object obj: object
# > bool pr_array: if true, elements of arrays are considered sub-objects
#                     during the recursive traversal.
# > bool pr_closure: if true, elements of closures are considered sub-objects
#                       during the recursive traversal.
# < result: T on stack overflow,
#           NIL if there are no circularities,
#           #(0 ...) a vector of length (n+1), containing the integer 0 and
#                    the n circularities, n>0.
# can trigger GC
global object get_circularities (object obj, bool pr_array, bool pr_closure);

# subst_circ(ptr,alist)
# Resolves #n# references in the object *ptr, using the alist as a replacement
# table.
# > *ptr : object
# > alist : alist (read-label --> object to be substituted)
# < *ptr : object with resolved references
# < result : first invalid reference found, or nullobj if everything is OK
global object subst_circ (gcv_object_t* ptr, object alist);
# Note: This substitution must respect circularities, so that it can be
# applied to circular structures, such as values of #. (in particular
# #.(FIND-CLASS 'FOO)).

# ------------------------------ Implementation -------------------------------

# Common subroutines.

#ifdef MULTITHREAD

# Multi-level bit map, used as a hash set. This is a (slower, but reentrant)
# alternative to using the GC's mark bit.

# Subdividing an address into bit packets.
# Try to reduce the number of bit packets, thus reducing the number of
# indirections. But the first one can bit large (because at the end of the
# indirection chain, we have a single bit per sizeof(gcv_object_t), not a big
# pointer. The last ones (>= 22) can be big, because it's not a problem
# if the size of the bitmap grows linearly with process_size/4MB.
#if (oint_addr_len <= 32)
  #define mlb0 0
  #define mlb1 10
  #define mlb2 14
  #define mlb3 18
  #define mlb4 22
  #define mlb5 32
  #define mlb_levels 5
#else
  #define mlb0 0
  #define mlb1 10
  #define mlb2 14
  #define mlb3 18
  #define mlb4 22
  #define mlb5 33
  #define mlb6 64
  #define mlb_levels 6
#endif
#if (mlb_levels >= 5)
  #define mlbs0  (mlb1-mlb0)  # = 10
  #define mlbs1  (mlb2-mlb1)  # = 4
  #define mlbs2  (mlb3-mlb2)  # = 4
  #define mlbs3  (mlb4-mlb3)  # = 4
  #define mlbs4  (mlb5-mlb4)  # >= 10
  #if (mlb_levels >= 6)
    #define mlbs5  (mlb6-mlb5)  # >= 10
  #endif
#endif

# A multi-level bit map.
# It is a hash set providing one bit for every possible object. The index into
# the table is actually an aint which we begin by dividing by sizeof(gcv_object_t).
# (Since any object on heap has a size >= sizeof(gcv_object_t), distinct objects
# have addresses that differ by at least sizeof(gcv_object_t), this will be
# represented by different bits.)
  #if (mlb_levels == 5)
    typedef uintL***** mlbitmap_base_t;
  #endif
  #if (mlb_levels == 6)
    typedef uintL****** mlbitmap_base_t;
  #endif
  typedef struct {
    mlbitmap_base_t base; # start pointer = address of malloc()ed area
    uintL alloc_size;     # size of malloc()ed area
    uintL used_size;      # size of used part; the remainder of the area is zeroed
    jmp_buf oom_context;  # context to jump to in case of malloc/realloc failure
  } mlbitmap;

# Create a multi-level bit map.
# The caller must initialize bitmap->oom_context himself.
  local void mlb_alloc (mlbitmap* bitmap);

# Add an object to a bitmap.
# Returns true if the object was already present, else false.
  local bool mlb_add (mlbitmap* bitmap, object obj);

# Free a multi-level bit map.
  local void mlb_free (mlbitmap* bitmap);

  local void mlb_alloc(bitmap)
    var mlbitmap* bitmap;
    {
      bitmap->base = NULL;
      bitmap->alloc_size = 0;
      bitmap->used_size = 0;
    }

  # Expand a bitmap so that its alloc_size becomes >= newsize.
  local uintP mlb_expand (mlbitmap* bitmap, uintL newsize);
  local uintP mlb_expand(bitmap,newsize)
    var mlbitmap* bitmap;
    var uintL newsize;
    {
      if (newsize < 2*bitmap->alloc_size)
        newsize = 2*bitmap->alloc_size;
      begin_system_call();
      var char* newbase = (bitmap->base==NULL ? malloc(newsize) : realloc((char*)bitmap->base,newsize));
      end_system_call();
      if (newbase==NULL)
        longjmp(bitmap->oom_context,true);
      var uintP delta = (uintP)newbase - (uintP)bitmap->base;
      bzero(newbase+bitmap->alloc_size,newsize-bitmap->alloc_size);
      if (bitmap->base) {
        # Relocate the pointers inside the bitmap.
        # We know that they form a tree,
        # therefore a recursive descent reaches every pointer exactly once.
        if (!(delta == 0)) {
          #if (mlb_levels >= 6)
          uintL****** p5 = (mlbitmap_base_t)newbase;
          uintC count5 = bit(mlbs5);
          for (; count5 > 0; p5++, count5--) {
            uintL***** p4 = *p5;
            if (p4) {
              *p5 = p4 = (uintL*****)((uintP)p4 + delta);
          #else
            uintL***** p4 = (mlbitmap_base_t)newbase;
          #endif
            { uintC count4 = bit(mlbs4);
            for (; count4 > 0; p4++, count4--) {
              uintL**** p3 = *p4;
              if (p3) {
                *p4 = p3 = (uintL****)((uintP)p3 + delta);
                { uintC count3 = bit(mlbs3);
                for (; count3 > 0; p3++, count3--) {
                  uintL*** p2 = *p3;
                  if (p2) {
                    *p3 = p2 = (uintL***)((uintP)p2 + delta);
                    { uintC count2 = bit(mlbs2);
                    for (; count2 > 0; p2++, count2--) {
                      uintL** p1 = *p2;
                      if (p1) {
                        *p2 = p1 = (uintL**)((uintP)p1 + delta);
                        { uintC count1 = bit(mlbs1);
                        for (; count1 > 0; p1++, count1--) {
                          var uintL* p0 = *p1;
                          if (p0) {
                            *p1 = p0 = (uintL*)((uintP)p0 + delta);
                          }
                        }}
                      }
                    }}
                  }
                }}
              }
            }}
          #if (mlb_levels >= 6)
            }
          }
          #endif
        }
      }
      bitmap->base = (mlbitmap_base_t)newbase;
      bitmap->alloc_size = newsize;
      return delta;
    }

  local bool mlb_add(bitmap,obj)
    var mlbitmap* bitmap;
    var object obj;
    {
      aint addr = (aint)ThePointer(obj);
      #if (mlb_levels >= 6)
      uintL******* p6 = &bitmap->base;
      if (*p6) {
        uintL****** p5 = &(*p6)[(addr >> mlb5) & (bit(mlbs5)-1)];
      #else
        uintL****** p5 = &bitmap->base;
      #endif
        if (*p5) {
          uintL***** p4 = &(*p5)[(addr >> mlb4) & (bit(mlbs4)-1)];
          if (*p4) {
            uintL**** p3 = &(*p4)[(addr >> mlb3) & (bit(mlbs3)-1)];
            if (*p3) {
              uintL*** p2 = &(*p3)[(addr >> mlb2) & (bit(mlbs2)-1)];
              if (*p2) {
                uintL** p1 = &(*p2)[(addr >> mlb1) & (bit(mlbs1)-1)];
                if (*p1) {
                  uintL* p0 = &(*p1)[((addr >> mlb0)/(32*sizeof(gcv_object_t)))
                                     & ((bit(mlbs0)-1)/(32*sizeof(gcv_object_t)))];
                  uintL i0 = ((addr >> mlb0)/sizeof(gcv_object_t)) % 32;
                  if (*p0 & bit(i0))
                    return true;
                  *p0 |= bit(i0);
                    return false;
                }
                {const uintL need=bit(mlbs0)/(32*sizeof(gcv_object_t))*sizeof(uintL);
                if (bitmap->used_size + need > bitmap->alloc_size) {
                  var uintP delta = mlb_expand(bitmap,bitmap->used_size+need);
                  p1 = (uintL**)((char*)p1 + delta);
                }
                var char* room = (char*)bitmap->base+bitmap->used_size;
                *p1 = (uintL*)room;
                var uintL* p0 = &(*p1)[((addr >> mlb0)/(32*sizeof(gcv_object_t)))
                                       & ((bit(mlbs0)-1)/(32*sizeof(gcv_object_t)))];
                var uintL i0 = ((addr >> mlb0)/sizeof(gcv_object_t)) % 32;
                *p0 = bit(i0);
                bitmap->used_size += need;
                return false;
                }}
              { const uintL need = bit(mlbs1)*sizeof(uintL*)
                  + bit(mlbs0)/(32*sizeof(gcv_object_t))*sizeof(uintL);
              if (bitmap->used_size + need > bitmap->alloc_size) {
                var uintP delta = mlb_expand(bitmap,bitmap->used_size+need);
                p2 = (uintL***)((char*)p2 + delta);
              }
              var char* room = (char*)bitmap->base+bitmap->used_size;
              *p2 = (uintL**)room; room += bit(mlbs1)*sizeof(uintL*);
              var uintL** p1 = &(*p2)[(addr >> mlb1) & (bit(mlbs1)-1)];
              *p1 = (uintL*)room;
              var uintL* p0 = &(*p1)[((addr >> mlb0)/(32*sizeof(gcv_object_t)))
                                     & ((bit(mlbs0)-1)/(32*sizeof(gcv_object_t)))];
              var uintL i0 = ((addr >> mlb0)/sizeof(gcv_object_t)) % 32;
              *p0 = bit(i0);
              bitmap->used_size += need;
              return false;
            }}
            { const uintL need = bit(mlbs2)*sizeof(uintL**)
              + bit(mlbs1)*sizeof(uintL*)
              + bit(mlbs0)/(32*sizeof(gcv_object_t))*sizeof(uintL);
            if (bitmap->used_size + need > bitmap->alloc_size) {
              uintP delta = mlb_expand(bitmap,bitmap->used_size+need);
              p3 = (uintL****)((char*)p3 + delta);
            }
            { char* room = (char*)bitmap->base+bitmap->used_size;
            *p3 = (uintL***)room; room += bit(mlbs2)*sizeof(uintL**);
            { uintL*** p2 = &(*p3)[(addr >> mlb2) & (bit(mlbs2)-1)];
            *p2 = (uintL**)room; room += bit(mlbs1)*sizeof(uintL*);
            { uintL** p1 = &(*p2)[(addr >> mlb1) & (bit(mlbs1)-1)];
            *p1 = (uintL*)room;
            { uintL* p0 = &(*p1)[((addr >> mlb0)/(32*sizeof(gcv_object_t)))
                                  & ((bit(mlbs0)-1)/(32*sizeof(gcv_object_t)))];
            var uintL i0 = ((addr >> mlb0)/sizeof(gcv_object_t)) % 32;
            *p0 = bit(i0);
            bitmap->used_size += need;
            return false;
          }}}}}}
          { const uintL need = bit(mlbs3)*sizeof(uintL***)
              + bit(mlbs2)*sizeof(uintL**)
              + bit(mlbs1)*sizeof(uintL*)
              + bit(mlbs0)/(32*sizeof(gcv_object_t))*sizeof(uintL);
          if (bitmap->used_size + need > bitmap->alloc_size) {
            uintP delta = mlb_expand(bitmap,bitmap->used_size+need);
            p4 = (uintL*****)((char*)p4 + delta);
          }
          { char* room = (char*)bitmap->base+bitmap->used_size;
          *p4 = (uintL****)room; room += bit(mlbs3)*sizeof(uintL***);
          { uintL**** p3 = &(*p4)[(addr >> mlb3) & (bit(mlbs3)-1)];
          *p3 = (uintL***)room; room += bit(mlbs2)*sizeof(uintL**);
          { uintL*** p2 = &(*p3)[(addr >> mlb2) & (bit(mlbs2)-1)];
          *p2 = (uintL**)room; room += bit(mlbs1)*sizeof(uintL*);
          { uintL** p1 = &(*p2)[(addr >> mlb1) & (bit(mlbs1)-1)];
          *p1 = (uintL*)room;
          { uintL* p0 = &(*p1)[((addr >> mlb0)/(32*sizeof(gcv_object_t)))
                               & ((bit(mlbs0)-1)/(32*sizeof(gcv_object_t)))];
          uintL i0 = ((addr >> mlb0)/sizeof(gcv_object_t)) % 32;
          *p0 = bit(i0);
          bitmap->used_size += need;
          return false;
        }}}}}}}
        { const uintL need = bit(mlbs4)*sizeof(uintL****)
            + bit(mlbs3)*sizeof(uintL***)
            + bit(mlbs2)*sizeof(uintL**)
            + bit(mlbs1)*sizeof(uintL*)
            + bit(mlbs0)/(32*sizeof(gcv_object_t))*sizeof(uintL);
        if (bitmap->used_size + need > bitmap->alloc_size) {
          uintP delta = mlb_expand(bitmap,bitmap->used_size+need);
          #if (mlb_levels > 5)
          p5 = (uintL******)((char*)p5 + delta);
          #endif
        }
        { char* room = (char*)bitmap->base+bitmap->used_size;
        *p5 = (uintL*****)room; room += bit(mlbs4)*sizeof(uintL****);
        { uintL***** p4 = &(*p5)[(addr >> mlb4) & (bit(mlbs4)-1)];
        *p4 = (uintL****)room; room += bit(mlbs3)*sizeof(uintL***);
        { uintL**** p3 = &(*p4)[(addr >> mlb3) & (bit(mlbs3)-1)];
        *p3 = (uintL***)room; room += bit(mlbs2)*sizeof(uintL**);
        { uintL*** p2 = &(*p3)[(addr >> mlb2) & (bit(mlbs2)-1)];
        *p2 = (uintL**)room; room += bit(mlbs1)*sizeof(uintL*);
        { uintL** p1 = &(*p2)[(addr >> mlb1) & (bit(mlbs1)-1)];
        *p1 = (uintL*)room;
        { uintL* p0 = &(*p1)[((addr >> mlb0)/(32*sizeof(gcv_object_t)))
                              & ((bit(mlbs0)-1)/(32*sizeof(gcv_object_t)))];
        uintL i0 = ((addr >> mlb0)/sizeof(gcv_object_t)) % 32;
        *p0 = bit(i0);
        bitmap->used_size += need;
        return false;
        }}}}}}}
      #if (mlb_levels >= 6)
      }
      { const uintL need = bit(mlbs5)*sizeof(uintL*****)
          + bit(mlbs4)*sizeof(uintL****)
          + bit(mlbs3)*sizeof(uintL***)
          + bit(mlbs2)*sizeof(uintL**)
          + bit(mlbs1)*sizeof(uintL*)
          + bit(mlbs0)/(32*sizeof(gcv_object_t))*sizeof(uintL);
      if (bitmap->used_size + need > bitmap->alloc_size) {
        uintP delta = mlb_expand(bitmap,bitmap->used_size+need);
        #if (mlb_levels > 6)
        p6 = (uintL*******)((char*)p6 + delta);
        #endif
      }
      { char* room = (char*)bitmap->base+bitmap->used_size;
      *p6 = (uintL******)room; room += bit(mlbs5)*sizeof(uintL*****);
      { uintL****** p5 = &(*p6)[(addr >> mlb5) & (bit(mlbs5)-1)];
      *p5 = (uintL*****)room; room += bit(mlbs4)*sizeof(uintL****);
      { uintL***** p4 = &(*p5)[(addr >> mlb4) & (bit(mlbs4)-1)];
      *p4 = (uintL****)room; room += bit(mlbs3)*sizeof(uintL***);
      { uintL**** p3 = &(*p4)[(addr >> mlb3) & (bit(mlbs3)-1)];
      *p3 = (uintL***)room; room += bit(mlbs2)*sizeof(uintL**);
      { uintL*** p2 = &(*p3)[(addr >> mlb2) & (bit(mlbs2)-1)];
      *p2 = (uintL**)room; room += bit(mlbs1)*sizeof(uintL*);
      { uintL** p1 = &(*p2)[(addr >> mlb1) & (bit(mlbs1)-1)];
      *p1 = (uintL*)room;
      { uintL* p0 = &(*p1)[((addr >> mlb0)/(32*sizeof(gcv_object_t)))
                           & ((bit(mlbs0)-1)/(32*sizeof(gcv_object_t)))];
      { uintL i0 = ((addr >> mlb0)/sizeof(gcv_object_t)) % 32;
      *p0 = bit(i0);
      bitmap->used_size += need;
      return false;
      }}}}}}}}}
      #endif
    }

  local void mlb_free(bitmap)
    var mlbitmap* bitmap;
    {
      if (bitmap->base) {
        begin_system_call();
        free((char*)bitmap->base);
        end_system_call();
      }
    }

#endif


# Implementation of get_circularities.

#ifdef MULTITHREAD

# get_circularities(obj,pr_array,pr_closure)
# Method:
# Traverse the object recursively, noting in a hash set (a multi-level bit map)
# the sub-objects traversed. While doing this, push the circularities onto the
# STACK. Then release the bitmap.
# Allocate a vector for the circularities (this can trigger GC!), move the
# circularities from the STACK into the vector.

# Global variables during get_circularities.
  typedef struct {
    mlbitmap bitmap;
    bool pr_array;
    bool pr_closure;
    uintL counter;
    jmp_buf abbruch_context;
    gcv_object_t* abbruch_STACK;
  } get_circ_global;

# UP: marks the object obj, pushes occurring circularities on the STACK
# and counts them in env->counter.
  local void get_circ_mark(obj,env)
    var object obj;
    var get_circ_global* env;
    {
     entry:
      #ifdef TYPECODES
      switch (typecode(obj)) # according to type
      #else
      if (orecordp(obj)) {
        goto case_orecord;
      } elif (consp(obj)) {
        goto case_cons;
      } else {
        goto m_end;
      }
      switch (0)
      #endif
      {
        case_cons:
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          {
            var object obj_cdr = Cdr(obj); # components
            var object obj_car = Car(obj);
            if (SP_overflow()) # check SP-depth
              longjmp(env->abbruch_context,true); # abort
            get_circ_mark(obj_car,env); # mark CAR (recursive)
            obj = obj_cdr; goto entry; # mark CDR (tail-end-recursive)
          }
        case_symbol:
          if (mlb_add(&env->bitmap,obj)) # marked?
            if (nullp(Symbol_package(obj))) /* uninterned symbol? */
              goto m_schon_da; # yes -> was already there, memorize
            else
              goto m_end; # no -> was already there, but leave unconsidered
          goto m_end;
        case_bvector: # Bit-Vector
        case_b2vector: # 2Bit-Vector
        case_b4vector: # 4Bit-Vector
        case_b8vector: # 8Bit-Vector
        case_b16vector: # 16Bit-Vector
        case_b32vector: # 32Bit-Vector
        case_string: # String
        case_bignum: # Bignum
        #ifndef IMMEDIATE_FFLOAT
        case_ffloat: # Single-Float
        #endif
        case_dfloat: # Double-Float
        case_lfloat: # Long-Float
        case_ratio: # Ratio
        case_complex: # Complex
        case_snilvector: /* (VECTOR NIL) */
          # Object without components that are printed:
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          goto m_end;
        case_svector: # Simple-Vector
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          # so far unmarked
          if (env->pr_array) { # track components?
            var uintL count = Svector_length(obj);
            if (!(count==0)) {
              # mark count>0 components
              var gcv_object_t* ptr = &TheSvector(obj)->data[0];
              if (SP_overflow()) # check SP-depth
                longjmp(env->abbruch_context,true); # abort
              dotimespL(count,count, { get_circ_mark(*ptr++,env); } ); # mark components (recursive)
            }
          }
          goto m_end;
        case_mdarray: case_ovector: case_nilvector:
          # non-simple Array with components, that are objects:
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          # so far unmarked
          if (env->pr_array) { # track components?
            obj = TheIarray(obj)->data; goto entry; # mark data-vector (tail-end-recursive)
          } else
            goto m_end;
        case_closure: # Closure
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          # so far unmarked
          if (env->pr_closure) # track components?
            goto m_record_components; # all components are printed (see below)
          else { # only mark the name (tail-end-recursive)
            obj = TheClosure(obj)->clos_name; goto entry;
          }
        case_structure: # Structure
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          # so far unmarked
          goto m_record_components;
        case_stream: # Stream
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          # so far unmarked
          switch (TheStream(obj)->strmtype) {
            case strmtype_broad:
            case strmtype_concat:
              goto m_record_components;
            default:
              goto m_end;
          }
        case_instance: # CLOS-instance
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          # so far unmarked
          goto m_record_components;
        case_orecord: # mark other record:
          switch (Record_type(obj)) {
            #ifndef TYPECODES
            case_Rectype_Symbol_above;
            case_Rectype_bvector_above;
            case_Rectype_b2vector_above;
            case_Rectype_b4vector_above;
            case_Rectype_b8vector_above;
            case_Rectype_b16vector_above;
            case_Rectype_b32vector_above;
            case_Rectype_string_above;
            case_Rectype_Bignum_above;
            case_Rectype_Ffloat_above;
            case_Rectype_Dfloat_above;
            case_Rectype_Lfloat_above;
            case_Rectype_Ratio_above;
            case_Rectype_Complex_above;
            case_Rectype_Svector_above;
            case_Rectype_Snilvector_above;
            case_Rectype_nilvector_above;
            case_Rectype_mdarray_above;
            case_Rectype_ovector_above;
            #endif
            case_Rectype_Closure_above;
            case_Rectype_Structure_above;
            case_Rectype_Stream_above;
            case_Rectype_Instance_above;
            default: ;
          }
          if (mlb_add(&env->bitmap,obj)) goto m_schon_da; # marked?
          # so far unmarked
          switch (Record_type(obj)) {
            case Rectype_Hashtable:
              # Hash-Table: according to Array-Output-Flag
              if (env->pr_array) break; else goto m_end;
            case Rectype_Package:
              # Packages are not printed component-wise
              goto m_end;
            case Rectype_Readtable:
              # Readtables are not printed component-wise
              goto m_end;
            case Rectype_Weakpointer: /* only the value is printed! */
              get_circ_mark(TheWeakpointer(obj)->wp_value,env);
              goto m_end;
            default: break;
          }
          # Pathnames, Random-States, Bytes, Fsubrs, Loadtimeevals,
          # Symbol-Macros and poss. Hash-Tables are poss.
          # printed component-wise.
         m_record_components: # mark components of a Record:
          {
            var uintC count = Record_length(obj);
            if (!(count==0)) {
              # mark count>0 components
              var gcv_object_t* ptr = &TheRecord(obj)->recdata[0];
              if (SP_overflow()) # check SP-depth
                longjmp(env->abbruch_context,true); # abort
              dotimespC(count,count, { get_circ_mark(*ptr++,env); } ); # mark components (recursive)
            }
          }
          goto m_end;
         m_schon_da:
          # object was marked, but has already been marked.
          # It is a circularity.
          if (STACK_overflow()) # check STACK-depth
            longjmp(env->abbruch_context,true); # abort
          # store object in STACK:
          pushSTACK(obj);
          env->counter++; # and count
          goto m_end;
        #ifdef TYPECODES
        case_machine: # Machine Pointer
        case_char: # Character
        case_subr: # Subr
        case_system: # Frame-pointer, Read-label, system
        case_fixnum: # Fixnum
        case_sfloat: # Short-Float
        #ifdef IMMEDIATE_FFLOAT
        case_ffloat: # Single-Float
        #endif
        #endif
        default:
          # object cannot be marked -> finished
          goto m_end;
         m_end: ; # finished
      }
    }

  global object get_circularities(obj,pr_array,pr_closure)
    var object obj;
    var bool pr_array;
    var bool pr_closure;
    {
      var get_circ_global my_global; # counter and context (incl. STACK-value)
                                     # for the case of an abort
      set_break_sem_1(); # make Break impossible
      if (!setjmp(my_global.abbruch_context)) { # save context
        bcopy(my_global.abbruch_context,my_global.bitmap.oom_context,sizeof(jmp_buf));
        mlb_alloc(&my_global.bitmap); # allocate bitmap
        my_global.pr_array = pr_array;
        my_global.pr_closure = pr_closure;
        my_global.counter = 0; # counter := 0
        my_global.abbruch_STACK = STACK;
        # the context-backup my_global is now ready.
        get_circ_mark(obj,&my_global); # mark object, push multiple
                                       # structures on the STACK
                                       # count in my_global.counter
        mlb_free(&my_global.bitmap); # free Bitmap
        clr_break_sem_1(); # allow Break again
        var uintL n = my_global.counter; # number of objects on the STACK
        if (n==0) {
          return NIL; # none there -> return NIL and finished
        } else {
          var object vector = allocate_vector(n+1); # vector with n+1 elements
          # fill:
          var gcv_object_t* ptr = &TheSvector(vector)->data[0];
          *ptr++ = Fixnum_0; # first element = Fixnum 0
          # store remaining elements (at least one):
          dotimespL(n,n, { *ptr++ = popSTACK(); } );
          return vector; # vector as result
        }
      } else {
        # after abort because of SP- or STACK-overflow
        setSTACK(STACK = my_global.abbruch_STACK); # reset STACK again
        # the context is now reestablished.
        mlb_free(&my_global.bitmap); # free Bitmap
        clr_break_sem_1(); # Break again possible
        return T; # T as result
      }
    }

#else # !MULTITHREAD

# get_circularities(obj,pr_array,pr_closure)
# Method:
# Mark the object recursively, push the circularities on the STACK,
# unmark the object recursively,
# allocate a vector for the circularities (can trigger GC!),
# fill the circularities from the STACK into the vector.
  typedef struct {
    bool pr_array;
    bool pr_closure;
    uintL counter;
    jmp_buf abbruch_context;
    gcv_object_t* abbruch_STACK;
  } get_circ_global;
  # It has to be accessed from within the two local routines.
  local void get_circ_mark (object obj, get_circ_global* env);
  local void get_circ_unmark (object obj, get_circ_global* env);
  global object get_circularities(obj,pr_array,pr_closure)
    var object obj;
    var bool pr_array;
    var bool pr_closure;
    {
      var get_circ_global my_global; # counter and context (incl. STACK-value)
                                     # in case of an abort
      set_break_sem_1(); # make Break impossible
      if (!setjmp(my_global.abbruch_context)) { # save context
        my_global.pr_array = pr_array;
        my_global.pr_closure = pr_closure;
        my_global.counter = 0; # counter := 0
        my_global.abbruch_STACK = STACK;
        # the context-backup my_global is now ready.
        get_circ_mark(obj,&my_global); # mark object, push multiple
                                       # structures on the STACK
                                       # count in my_global.counter
        get_circ_unmark(obj,&my_global); # delete marks again
        clr_break_sem_1(); # make Break possible again
        var uintL n = my_global.counter; # number of objects on the STACK
        if (n==0) {
          return NIL; # none there -> return NIL and finished
        } else {
          var object vector = allocate_vector(n+1); # vector with n+1 elements
          # fill:
          var gcv_object_t* ptr = &TheSvector(vector)->data[0];
          *ptr++ = Fixnum_0; # first element = Fixnum 0
          # store remaining elements (at least one):
          dotimespL(n,n, { *ptr++ = popSTACK(); } );
          return vector; # vector as result
        }
      } else {
        # after abort because of SP- or STACK-overflow
        setSTACK(STACK = my_global.abbruch_STACK); # reset STACK again
        # the context is now reestablished.
        get_circ_unmark(obj,&my_global); # delete marks again
        clr_break_sem_1(); # Break is possible again
        return T; # T as result
      }
    }
# UP: marks the object obj, pushes occurring circularities on the STACK
# and counts them in env->counter.
  local void get_circ_mark(obj,env)
    var object obj;
    var get_circ_global* env;
    {
     entry:
      #ifdef TYPECODES
      switch (typecode(obj)) # according to type
      #else
      if (orecordp(obj)) {
        goto case_orecord;
      } elif (consp(obj)) {
        goto case_cons;
      } else {
        goto m_end;
      }
      switch (0)
      #endif
      {
        case_cons:
          if (marked(TheCons(obj))) goto m_schon_da; # marked?
          {
            var object obj_cdr = Cdr(obj); # components (without mark bit)
            var object obj_car = Car(obj);
            mark(TheCons(obj)); # mark
            if (SP_overflow()) # check SP-depth
              longjmp(env->abbruch_context,true); # abort
            get_circ_mark(obj_car,env); # mark CAR (recursive)
            obj = obj_cdr; goto entry; # mark CDR (tail-end-recursive)
          }
        case_symbol:
          if (marked(TheSymbol(obj))) { # marked?
            if (nullp(Symbol_package(obj))) /* uninterned symbol? */
              goto m_schon_da; # yes -> was already there, memorize
            else
              goto m_end; # no -> was already there, but leave unconsidered
          }
          # so far unmarked symbol
          mark(TheSymbol(obj)); # mark
          goto m_end;
        case_bvector: # Bit-Vector
        case_b2vector: # 2Bit-Vector
        case_b4vector: # 4Bit-Vector
        case_b8vector: # 8Bit-Vector
        case_b16vector: # 16Bit-Vector
        case_b32vector: # 32Bit-Vector
        case_string: # String
        case_bignum: # Bignum
        #ifndef IMMEDIATE_FFLOAT
        case_ffloat: # Single-Float
        #endif
        case_dfloat: # Double-Float
        case_lfloat: # Long-Float
        case_ratio: # Ratio
        case_complex: # Complex
        case_snilvector: /* (VECTOR NIL) */
          # object without components that are printed:
          if (marked(ThePointer(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(ThePointer(obj)); # marked
          goto m_end;
        case_svector: # Simple-Vector
          if (marked(TheSvector(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(TheSvector(obj)); # mark
         m_svector:
          if (env->pr_array) { # track components?
            var uintL count = Svector_length(obj);
            if (!(count==0)) {
              # mark count>0 components
              var gcv_object_t* ptr = &TheSvector(obj)->data[0];
              if (SP_overflow()) # check SP-depth
                longjmp(env->abbruch_context,true); # abort
              dotimespL(count,count, { get_circ_mark(*ptr++,env); } ); # mark components (recursive)
            }
          }
          goto m_end;
        case_mdarray: case_ovector: case_nilvector:
          # non-simple array with components that are objects:
          if (marked(TheIarray(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(TheIarray(obj)); # mark
         m_array:
          if (env->pr_array) { # track components?
            obj = TheIarray(obj)->data; goto entry; # mark data vector (tail-end-recursive)
          } else
            goto m_end;
        case_closure: # Closure
          if (marked(TheClosure(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(TheClosure(obj)); # mark
          if (env->pr_closure) # track components?
            goto m_record_components; # all components are printed (see below)
          else { # only mark the name (tail-end-recursive)
            obj = TheClosure(obj)->clos_name; goto entry;
          }
        case_structure: # Structure
          if (marked(TheStructure(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(TheStructure(obj)); # mark
          goto m_record_components;
        case_stream: # Stream
          if (marked(TheStream(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(TheStream(obj));
          switch (TheStream(obj)->strmtype) {
            case strmtype_broad:
            case strmtype_concat:
              goto m_record_components;
            default:
              goto m_end;
          }
        case_instance: # CLOS-instance
          if (marked(TheInstance(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(TheInstance(obj)); # mark
          goto m_record_components;
        case_orecord: # mark other record:
          switch (Record_type(obj)) {
            #ifndef TYPECODES
            case_Rectype_Symbol_above;
            case_Rectype_bvector_above;
            case_Rectype_b2vector_above;
            case_Rectype_b4vector_above;
            case_Rectype_b8vector_above;
            case_Rectype_b16vector_above;
            case_Rectype_b32vector_above;
            case_Rectype_string_above;
            case_Rectype_Bignum_above;
            case_Rectype_Ffloat_above;
            case_Rectype_Dfloat_above;
            case_Rectype_Lfloat_above;
            case_Rectype_Ratio_above;
            case_Rectype_Complex_above;
            case_Rectype_Svector_above;
            case_Rectype_Snilvector_above;
            case_Rectype_nilvector_above;
            case_Rectype_mdarray_above;
            case_Rectype_ovector_above;
            #endif
            case_Rectype_Closure_above;
            case_Rectype_Structure_above;
            case_Rectype_Stream_above;
            case_Rectype_Instance_above;
            default: ;
          }
          if (marked(TheRecord(obj))) goto m_schon_da; # marked?
          # so far unmarked
          mark(TheRecord(obj)); # mark
          switch (Record_type(obj)) {
            case Rectype_Hashtable:
              # Hash-Table: according to the Array-Print-Flag
              if (env->pr_array) break; else goto m_end;
            case Rectype_Package:
              # Packages are not printed component-wise
              goto m_end;
            case Rectype_Readtable:
              # Readtables are not printed component-wise
              goto m_end;
            case Rectype_Weakpointer: /* only the value is printed! */
              get_circ_mark(TheWeakpointer(obj)->wp_value,env);
              goto m_end;
            default: break;
          }
          # Pathnames, Random-States, Bytes, Fsubrs, Loadtimeevals,
          # Symbol-Macros and poss. Hash-Tables are poss.
          # printed component-wise.
         m_record_components: # mark the components of a Record:
          {
            var uintC count = Record_length(obj);
            if (!(count==0)) {
              # mark count>0 components
              var gcv_object_t* ptr = &TheRecord(obj)->recdata[0];
              if (SP_overflow()) # check SP-depth
                longjmp(env->abbruch_context,true); # abort
              dotimespC(count,count, { get_circ_mark(*ptr++,env); } ); # mark components (recursive)
            }
          }
          goto m_end;
         m_schon_da:
          # Object has been marked, but was already marked.
          # It is a circularity.
          if (STACK_overflow()) # check STACK-depth
            longjmp(env->abbruch_context,true); # abort
          # store object with deleted garcol_bit in STACK:
          pushSTACK(without_mark_bit(obj));
          env->counter++; # and count
          goto m_end;
        #ifdef TYPECODES
        case_machine: # Machine Pointer
        case_char: # Character
        case_subr: # Subr
        case_system: # Frame-pointer, Read-label, system
        case_fixnum: # Fixnum
        case_sfloat: # Short-Float
        #ifdef IMMEDIATE_FFLOAT
        case_ffloat: # Single-Float
        #endif
        #endif
        default:
          # Object cannot be marked -> finished
          goto m_end;
       m_end: ; # finished
      }
    }
# UP: Unmarks object obj.
  local void get_circ_unmark(obj,env)
    var object obj;
    var get_circ_global* env;
    {
     entry:
      #ifdef TYPECODES
      switch (typecode(obj) & ~bit(garcol_bit_t)) # according to typeinfo without garcol_bit
      #else
      if (orecordp(obj)) {
        goto case_orecord;
      } elif (consp(obj)) {
        goto case_cons;
      } else {
        goto u_end;
      }
      switch (0)
      #endif
      {
        case_cons:
          if (!marked(TheCons(obj))) goto u_end; # already unmarked?
          unmark(TheCons(obj)); # unmark
          get_circ_unmark(Car(obj),env); # unmark CAR (recursive)
          obj = Cdr(obj); goto entry; # unmark CDR (tail-end-recursive)
        case_bvector: # Bit-Vector
        case_b2vector: # 2Bit-Vector
        case_b4vector: # 4Bit-Vector
        case_b8vector: # 8Bit-Vector
        case_b16vector: # 16Bit-Vector
        case_b32vector: # 32Bit-Vector
        case_string: # String
        case_symbol:
          # unmark symbol. value cell etc. irrelevant for PRINT.
        case_bignum: # Bignum
        #ifndef IMMEDIATE_FFLOAT
        case_ffloat: # Single-Float
        #endif
        case_dfloat: # Double-Float
        case_lfloat: # Long-Float
        case_ratio: # Ratio
        case_complex: # Complex
        case_snilvector: /* (VECTOR NIL) */
          # unmark object, that has no marked components:
          unmark(ThePointer(obj)); # unmark
          goto u_end;
        case_svector:
          # unmark Simple-Vector, including its components:
          if (!marked(TheSvector(obj))) goto u_end; # already unmarked?
          unmark(TheSvector(obj)); # unmark
         u_svector:
          if (env->pr_array) { # were the components tracked?
            var uintL count = Svector_length(obj);
            if (!(count==0)) {
              # unmark count>0 components
              var gcv_object_t* ptr = &TheSvector(obj)->data[0];
              dotimespL(count,count, { get_circ_unmark(*ptr++,env); } ); # unmark components (recursive)
            }
          }
          goto u_end;
        case_mdarray: case_ovector: case_nilvector:
          # non-simple Array with components that are objects:
          if (!marked(TheIarray(obj))) goto u_end; # already unmarked?
          unmark(TheIarray(obj)); # unmark
         u_array:
          if (env->pr_array) { # were the components tracked?
            obj = TheIarray(obj)->data; goto entry; # unmark data vector (tail-end-recursive)
          } else
            goto u_end;
        case_closure: # unmark Closure
          if (!marked(TheClosure(obj))) goto u_end; # already unmarked?
          unmark(TheClosure(obj)); # unmark
          if (env->pr_closure) # were components tracked?
            goto u_record_components; # all components are printed (see below)
          else { # only unmark the name (tail-end-recursive)
            obj = TheClosure(obj)->clos_name; goto entry;
          }
        case_structure: # unmark structure:
          if (!marked(TheStructure(obj))) goto u_end; # already unmarked?
          unmark(TheStructure(obj)); # unmark
          goto u_record_components;
        case_stream: # unmark stream:
          if (!marked(TheStream(obj))) goto u_end; # already unmarked?
          unmark(TheStream(obj)); # unmark
          switch (TheStream(obj)->strmtype) {
            case strmtype_broad:
            case strmtype_concat:
              goto u_record_components;
            default:
              goto u_end;
          }
        case_instance: # unmark CLOS-instance:
          if (!marked(TheInstance(obj))) goto u_end; # already unmarked?
          unmark(TheInstance(obj)); # unmark
          goto u_record_components;
        case_orecord: # unmark other record:
          switch (Record_type(obj)) {
            #ifndef TYPECODES
            case_Rectype_bvector_above;
            case_Rectype_b2vector_above;
            case_Rectype_b4vector_above;
            case_Rectype_b8vector_above;
            case_Rectype_b16vector_above;
            case_Rectype_b32vector_above;
            case_Rectype_string_above;
            case_Rectype_Symbol_above;
            case_Rectype_Bignum_above;
            case_Rectype_Ffloat_above;
            case_Rectype_Dfloat_above;
            case_Rectype_Lfloat_above;
            case_Rectype_Ratio_above;
            case_Rectype_Complex_above;
            case_Rectype_Svector_above;
            case_Rectype_Snilvector_above;
            case_Rectype_nilvector_above;
            case_Rectype_mdarray_above;
            case_Rectype_ovector_above;
            #endif
            case_Rectype_Closure_above;
            case_Rectype_Structure_above;
            case_Rectype_Stream_above;
            case_Rectype_Instance_above;
            default: ;
          }
          if (!marked(TheRecord(obj))) goto u_end; # already unmarked?
          unmark(TheRecord(obj)); # unmark
          switch (Record_type(obj)) {
            case Rectype_Hashtable:
              # Hash-Table: according to Array-Print-Flag
              if (env->pr_array) break; else goto u_end;
            case Rectype_Package:
              # Packages are not printed component-wise
              goto u_end;
            case Rectype_Readtable:
              # Readtables are not printed component-wise
              goto u_end;
            case Rectype_Weakpointer: /* only the value is printed! */
              get_circ_unmark(TheWeakpointer(obj)->wp_value,env);
              goto u_end;
            default: break;
          }
          # Pathnames, Random-States, Bytes, Fsubrs, Loadtimeevals,
          # Symbol-Macros and poss. Hash-Tables are poss.
          # printed component-wise.
         u_record_components: # unmark components of a record:
          {
            var uintC count = Record_length(obj);
            if (!(count==0)) {
              # unmark count>0 components
              var gcv_object_t* ptr = &TheRecord(obj)->recdata[0];
              dotimespC(count,count, { get_circ_unmark(*ptr++,env); } ); # unmark components (recursive)
            }
          }
          goto u_end;
        #ifdef TYPECODES
        case_machine: # Maschine Pointer
        case_char: # Character
        case_subr: # Subr
        case_system: # Frame-pointer, Read-label, system
        case_fixnum: # Fixnum
        case_sfloat: # Short-Float
        #ifdef IMMEDIATE_FFLOAT
        case_ffloat: # Single-Float
        #endif
        #endif
        default:
          # unmark object that cannot have a mark at all:
          goto u_end;
       u_end: ; # finished
      }
    }

#endif


# Implementation of subst_circ.

#ifdef MULTITHREAD

# Global variables during subst_circ.
  typedef struct {
    mlbitmap bitmap;
    object alist;
    jmp_buf abbruch_context;
    object bad;
  } subst_circ_global;

  local void subst_circ_mark (gcv_object_t* ptr, subst_circ_global* env);
  local void subst_circ_mark(ptr,env)
    var gcv_object_t* ptr;
    var subst_circ_global* env;
    {
      #if !(defined(NO_SP_CHECK) || defined(NOCOST_SP_CHECK))
      if (SP_overflow()) { # check SP-depth
        env->bad = nullobj; longjmp(env->abbruch_context,true); # abort
      }
      #endif
     enter_subst:
      {
        var object obj = *ptr;
        # fall differentiation by type:
        # Objects without sub-objects (maschine pointers, bit-vectors,
        # strings, characters, subrs, integers, floats) contain no
        # references. The same holds true for Symbols and rational numbers (their
        # sub-objects could not have been entered in #n= - Syntax)
        # and complex numbers (for their components only
        # integers, floats, rational numbers are allowed, which means objects,
        # that cannot contain references themselves).
        #ifdef TYPECODES
        switch (typecode(obj))
        #else
        if (orecordp(obj)) {
          goto case_orecord;
        } elif (consp(obj)) {
          goto case_cons;
        } elif (immediate_number_p(obj)) {
          goto case_number;
        } elif (charp(obj)) {
          goto case_char;
        } elif (subrp(obj)) {
          goto case_subr;
        } elif (machinep(obj)) {
          goto case_machine;
        } elif (read_label_p(obj)) {
          goto case_read_label;
        } elif (systemp(obj)) {
          return;
        } else switch (0)
        #endif
        {
          case_svector: # Simple-Vector
            if (mlb_add(&env->bitmap,obj)) return; # Object already marked?
            # traverse all elements:
            {
              var uintL len = Svector_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheSvector(obj)->data[0];
                dotimespL(len,len, { subst_circ_mark(&(*objptr++),env); } );
              }
            }
            return;
          case_mdarray: case_ovector: case_nilvector:
            # non-simple array, no string or bit-vector
            if (mlb_add(&env->bitmap,obj)) return; # object already marked?
            # traverse data-vector: end-recursive subst_circ_mark(data-vector)
            ptr = &TheIarray(obj)->data; goto enter_subst;
          case_instance: /* Record */
          case_closure: _case_structure _case_stream case_orecord:
            #ifndef TYPECODES
            switch (Record_type(obj)) {
              case_Rectype_Svector_above;
              case_Rectype_Snilvector_above;
              case_Rectype_nilvector_above;
              case_Rectype_mdarray_above;
              case_Rectype_ovector_above;
              case_Rectype_bvector_above;
              case_Rectype_b2vector_above;
              case_Rectype_b4vector_above;
              case_Rectype_b8vector_above;
              case_Rectype_b16vector_above;
              case_Rectype_b32vector_above;
              case_Rectype_string_above;
              case_Rectype_number_above;
              case_Rectype_Symbol_above;
              default: ;
            }
            #endif
            if (mlb_add(&env->bitmap,obj)) return; # object already marked?
            # On replacement of Read-Labels in Hash-Tables their structure
            # is invalidated (because the hash-function of the objects stored
            # in it changes).
            if (Record_type(obj) == Rectype_Hashtable) # a hash-table?
              mark_ht_invalid(TheHashtable(obj)); # yes -> note for reorganization
            # traverse all elements:
            {
              var uintC len = Record_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheRecord(obj)->recdata[0];
                dotimespC(len,len, { subst_circ_mark(&(*objptr++),env); } );
              }
            }
            return;
          #ifdef TYPECODES
          case_system: # Frame-Pointer or Read-Label or System
            if (!(as_oint(obj) & wbit(0+oint_addr_shift))) {
              # Frame-Pointer
            } else
              # Read-Label or System
              if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift)) {
                # System
              } else
          #endif
              case_read_label:
                # Read-Label
                {
                  # search Read-Label obj in the Alist:
                  var object alist = env->alist;
                  while (consp(alist)) {
                    var object acons = Car(alist);
                    if (eq(Car(acons),obj)) {
                      # found
                      # replace *ptr = obj = (car acons) with (cdr acons) ,
                      # but leave the mark bit untouched:
                      *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : (object)Cdr(acons));
                      return;
                    }
                    alist = Cdr(alist);
                  }
                  # not found -> abort
                  env->bad = obj;
                  longjmp(env->abbruch_context,true);
                }
            return;
          case_cons: # Cons
            if (mlb_add(&env->bitmap,obj)) return; # Object already marked?
            # recursive: subst_circ_mark(&Car(obj))
            subst_circ_mark(&TheCons(obj)->car,env);
            # end-recursive: subst_circ_mark(&Cdr(obj))
            ptr = &TheCons(obj)->cdr; goto enter_subst;
          case_machine: # Machine Pointer
          case_bvector: # Bit-Vector
          case_b2vector: # 2Bit-Vector
          case_b4vector: # 4Bit-Vector
          case_b8vector: # 8Bit-Vector
          case_b16vector: # 16Bit-Vector
          case_b32vector: # 32Bit-Vector
          case_string: # String
          case_char: # Character
          case_subr: # SUBR
          case_number: # Zahl
          case_symbol: # Symbol
          case_snilvector: /* (VECTOR NIL) */
            # Object contains no references -> do nothing
            return;
          default: NOTREACHED;
        }
      }
    }

  global object subst_circ(ptr,alist)
    var gcv_object_t* ptr;
    var object alist;
    {
      var subst_circ_global my_global;
      my_global.alist = alist;
      set_break_sem_1(); # disable Break
      if (!setjmp(my_global.abbruch_context)) {
        bcopy(my_global.abbruch_context,my_global.bitmap.oom_context,sizeof(jmp_buf));
        mlb_alloc(&my_global.bitmap);
        subst_circ_mark(ptr,&my_global); # mark and substitute
        mlb_free(&my_global.bitmap);
        clr_break_sem_1(); # allow Break again
        return nullobj;
      } else {
        # abort from within subst_circ_mark()
        mlb_free(&my_global.bitmap);
        clr_break_sem_1(); # allow Break again
        #if !(defined(NO_SP_CHECK) || defined(NOCOST_SP_CHECK))
        if (eq(my_global.bad,nullobj)) {
          SP_ueber();
        }
        #endif
        return my_global.bad; # because of erroneous reference
      }
    }

#else # !MULTITHREAD

#if 0 # without consideration of circularities

  local void subst (gcv_object_t* ptr);
  local object subst_circ_alist;
  local jmp_buf subst_circ_jmpbuf;
  local object subst_circ_bad;
  global object subst_circ(ptr,alist)
    var gcv_object_t* ptr;
    var object alist;
    {
      subst_circ_alist = alist;
      begin_setjmp_call();
      if (!setjmp(subst_circ_jmpbuf)) {
        end_setjmp_call(); subst(ptr); return nullobj;
      } else {
        # abort because of erroneous reference
        end_longjmp_call(); return subst_circ_bad;
      }
    }
  local void subst(ptr)
    var gcv_object_t* ptr;
    {
      check_SP();
     enter_subst:
      {
        var object obj = *ptr;
        # fall differentiation by type:
        # Objects without sub-objects (maschine pointers, bit-vectors,
        # strings, characters, subrs, integers, floats) contain no
        # references. The same holds true for Symbols and rational numbers (their
        # sub-objects could not have been entered in #n= - Syntax)
        # and complex numbers (for their components only
        # integers, floats, rational numbers are allowed, which means: objects,
        # that cannot contain references themselves).
        #ifdef TYPECODES
        switch (mtypecode(*ptr))
        #else
        if (orecordp(obj)) {
          goto case_orecord;
        } elif (consp(obj)) {
          goto case_cons;
        } elif (immediate_number_p(obj)) {
          goto case_number;
        } elif (charp(obj)) {
          goto case_char;
        } elif (subrp(obj)) {
          goto case_subr;
        } elif (machinep(obj)) {
          goto case_machine;
        } elif (read_label_p(obj)) {
          goto case_read_label;
        } elif (systemp(obj)) {
          return;
        } else switch (0)
        #endif
        {
          case_svector: # Simple-Vector
            # traverse all elements:
            {
              var uintL len = Svector_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheSvector(obj)->data[0];
                dotimespL(len,len, { subst(&(*objptr++)); } );
              }
            }
            break;
          case_mdarray: case_ovector: case_nilvector:
            # non-simple array, no string or bit-vector
            # traverse data-vector: end-recursive subst(data-vector)
            ptr = &TheIarray(obj)->data; goto enter_subst;
          case_instance: /* Record */
          case_closure: _case_structure _case_stream case_orecord:
            #ifndef TYPECODES
            switch (Record_type(obj)) {
              case_Rectype_Svector_above;
              case_Rectype_Snilvector_above;
              case_Rectype_nilvector_above;
              case_Rectype_mdarray_above;
              case_Rectype_ovector_above;
              case_Rectype_bvector_above;
              case_Rectype_b2vector_above;
              case_Rectype_b4vector_above;
              case_Rectype_b8vector_above;
              case_Rectype_b16vector_above;
              case_Rectype_b32vector_above;
              case_Rectype_string_above;
              case_Rectype_number_above;
              case_Rectype_Symbol_above;
              default: ;
            }
            #endif
            # traverse all elements:
            {
              var uintC len = Record_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheRecord(obj)->recdata[0];
                dotimespC(len,len, { subst(&(*objptr++)); } );
              }
            }
            break;
          #ifdef TYPECODES
          case_system: # Frame-Pointer or Read-Label or System
            if (!(as_oint(obj) & wbit(0+oint_addr_shift))) {
              # Frame-Pointer
            } else
              # Read-Label or System
              if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift)) {
                # System
              } else
          #endif
              case_read_label:
                # Read-Label
                {
                  # search Read-Label obj in the Alist:
                  var object alist = subst_circ_alist;
                  while (consp(alist)) {
                    var object acons = Car(alist);
                    if (eq(Car(acons),obj)) {
                      # found
                      # replace *ptr = obj = (car acons) with (cdr acons) :
                      *ptr = Cdr(acons);
                      return;
                    }
                    alist = Cdr(alist);
                  }
                  # not found -> abort
                  subst_circ_bad = obj;
                  begin_longjmp_call();
                  longjmp(subst_circ_jmpbuf,true);
                }
            break;
          case_cons: # Cons
            # recursive: subst(&Car(obj))
            subst(&TheCons(obj)->car);
            # endrecursive: subst(&Cdr(obj))
            ptr = &TheCons(obj)->cdr; goto enter_subst;
          case_machine: # Machine Pointer
          case_bvector: # Bit-Vector
          case_b2vector: # 2Bit-Vector
          case_b4vector: # 4Bit-Vector
          case_b8vector: # 8Bit-Vector
          case_b16vector: # 16Bit-Vector
          case_b32vector: # 32Bit-Vector
          case_string: # String
          case_char: # Character
          case_subr: # SUBR
          case_number: # Zahl
          case_symbol: # Symbol
          case_snilvector: /* (VECTOR NIL) */
            # Object contains no references -> do nothing
            break;
          default: NOTREACHED;
        }
      }
    }

#else # with consideration of circularities

# Method:
# Mark the objects recursively, in which the substitution has just been
# performed. Then unmark the object recursively.

  local void subst_circ_mark (gcv_object_t* ptr);
  local void subst_circ_unmark (gcv_object_t* ptr);
  local object subst_circ_alist;
  local jmp_buf subst_circ_jmpbuf;
  local object subst_circ_bad;
  global object subst_circ(ptr,alist)
    var gcv_object_t* ptr;
    var object alist;
    {
      subst_circ_alist = alist;
      set_break_sem_1(); # disable Break
      if (!setjmp(subst_circ_jmpbuf)) {
        subst_circ_mark(ptr); # mark and substitute
        subst_circ_unmark(ptr); # delete marks again
        clr_break_sem_1(); # allow Break again
        return nullobj;
      } else {
        # abort from within subst_circ_mark()
        subst_circ_unmark(ptr); # first unmark everything
        clr_break_sem_1(); # allow Break again
        #if !(defined(NO_SP_CHECK) || defined(NOCOST_SP_CHECK))
        if (eq(subst_circ_bad,nullobj)) {
          SP_ueber();
        }
        #endif
        return subst_circ_bad; # because of erroneous reference
      }
    }
  local void subst_circ_mark(ptr)
    var gcv_object_t* ptr;
    {
      #if !(defined(NO_SP_CHECK) || defined(NOCOST_SP_CHECK))
      if (SP_overflow()) { # check SP-depth
        subst_circ_bad = nullobj; longjmp(subst_circ_jmpbuf,true); # abort
      }
      #endif
     enter_subst:
      {
        var object obj = without_mark_bit(*ptr);
        # fall differentiation by type:
        # Objects without sub-objects (maschine pointers, bit-vectors,
        # strings, characters, subrs, integers, floats) contain no
        # references. The same holds true for Symbols and rational numbers (their
        # sub-objects could not have been entered in #n= - Syntax)
        # and complex numbers (for their components only
        # integers, floats, rational numbers are allowed, which means: objects,
        # that cannot contain references themselves).
        #ifdef TYPECODES
        switch (typecode(obj))
        #else
        if (orecordp(obj)) {
          goto case_orecord;
        } elif (consp(obj)) {
          goto case_cons;
        } elif (immediate_number_p(obj)) {
          goto case_number;
        } elif (charp(obj)) {
          goto case_char;
        } elif (subrp(obj)) {
          goto case_subr;
        } elif (machinep(obj)) {
          goto case_machine;
        } elif (read_label_p(obj)) {
          goto case_read_label;
        } elif (systemp(obj)) {
          return;
        } else switch (0)
        #endif
        {
          case_svector: # Simple-Vector
            if (marked(TheSvector(obj))) return; # object already marked?
            mark(TheSvector(obj)); # mark
            # traverse all elements:
            {
              var uintL len = Svector_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheSvector(obj)->data[0];
                dotimespL(len,len, { subst_circ_mark(&(*objptr++)); } );
              }
            }
            return;
          case_mdarray: case_ovector: case_nilvector:
            # non-simple array, no string or bit-vector
            if (marked(TheIarray(obj))) return; # object already marked?
            mark(TheIarray(obj)); # mark
            # traverse data-vector: end-recursive subst_circ_mark(data-vector)
            ptr = &TheIarray(obj)->data; goto enter_subst;
          case_closure: _case_structure _case_stream case_orecord: case_instance: # Record
            #ifndef TYPECODES
            switch (Record_type(obj)) {
              case_Rectype_Svector_above;
              case_Rectype_Snilvector_above;
              case_Rectype_nilvector_above;
              case_Rectype_mdarray_above;
              case_Rectype_ovector_above;
              case_Rectype_bvector_above;
              case_Rectype_b2vector_above;
              case_Rectype_b4vector_above;
              case_Rectype_b8vector_above;
              case_Rectype_b16vector_above;
              case_Rectype_b32vector_above;
              case_Rectype_string_above;
              case_Rectype_number_above;
              case_Rectype_Symbol_above;
              default: ;
            }
            #endif
            if (marked(TheRecord(obj))) return; # object already marked?
            mark(TheRecord(obj)); # mark
            # On replacement of Read-Labels in Hash-Tables their structure
            # is invalidated (because the hash-function of the objects stored
            # in it changes).
            if (Record_type(obj) == Rectype_Hashtable) # a Hash-Table ?
              mark_ht_invalid(TheHashtable(obj)); # yes -> note for reorganization
            # traverse all elements:
            {
              var uintC len = Record_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheRecord(obj)->recdata[0];
                dotimespC(len,len, { subst_circ_mark(&(*objptr++)); } );
              }
            }
            return;
          #ifdef TYPECODES
          case_system: # Frame-Pointer or Read-Label or System
            if (!(as_oint(obj) & wbit(0+oint_addr_shift))) {
              # Frame-Pointer
            } else
              # Read-Label or System
              if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift)) {
                # System
              } else
          #endif
              case_read_label:
                # Read-Label
                {
                  # search Read-Label obj in the Alist:
                  var object alist = subst_circ_alist;
                  while (consp(alist)) {
                    var object acons = Car(alist);
                    if (eq(Car(acons),obj)) {
                      # found
                      # replace *ptr = obj = (car acons) with (cdr acons) ,
                      # but leave the mark bit untouched:
                      *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : (object)Cdr(acons));
                      return;
                    }
                    alist = Cdr(alist);
                  }
                  # not found -> abort
                  subst_circ_bad = obj;
                  longjmp(subst_circ_jmpbuf,true);
                }
            return;
          case_cons: # Cons
            if (marked(TheCons(obj))) return; # object already marked?
            mark(TheCons(obj)); # mark
            # recursive: subst_circ_mark(&Car(obj))
            subst_circ_mark(&TheCons(obj)->car);
            # end-recursive: subst_circ_mark(&Cdr(obj))
            ptr = &TheCons(obj)->cdr; goto enter_subst;
          case_machine: # Machine Pointer
          case_bvector: # Bit-Vector
          case_b2vector: # 2Bit-Vector
          case_b4vector: # 4Bit-Vector
          case_b8vector: # 8Bit-Vector
          case_b16vector: # 16Bit-Vector
          case_b32vector: # 32Bit-Vector
          case_string: # String
          case_char: # Character
          case_subr: # SUBR
          case_number: # Zahl
          case_symbol: # Symbol
          case_snilvector: /* (VECTOR NIL) */
            # Object contains no references -> do nothing
            return;
          default: NOTREACHED;
        }
      }
    }
  local void subst_circ_unmark(ptr)
    var gcv_object_t* ptr;
    {
     enter_subst:
      {
        var object obj = *ptr;
        # fall differentiation according to type, like above:
        #ifdef TYPECODES
        switch (typecode(obj))
        #else
        if (orecordp(obj)) {
          goto case_orecord;
        } elif (consp(obj)) {
          goto case_cons;
        } elif (immediate_number_p(obj)) {
          goto case_number;
        } elif (charp(obj)) {
          goto case_char;
        } elif (subrp(obj)) {
          goto case_subr;
        } elif (machinep(obj)) {
          goto case_machine;
        } elif (read_label_p(obj) || systemp(obj)) {
          goto case_system;
        } else switch (0)
        #endif
        {
          case_svector: # Simple-Vector
            if (!marked(TheSvector(obj))) return; # already unmarked?
            unmark(TheSvector(obj)); # unmark
            # traverse all elements:
            {
              var uintL len = Svector_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheSvector(obj)->data[0];
                dotimespL(len,len, { subst_circ_unmark(&(*objptr++)); } );
              }
            }
            return;
          case_mdarray: case_ovector: case_nilvector:
            # non-simple array, no string or bit-vector
            if (!marked(TheIarray(obj))) return; # already unmarked?
            unmark(TheIarray(obj)); # unmark
            # traverse data-vector: end-recursive subst_circ_unmark(data-vector)
            ptr = &TheIarray(obj)->data; goto enter_subst;
          case_instance: /* Record */
          case_closure: _case_structure _case_stream case_orecord:
            #ifndef TYPECODES
            switch (Record_type(obj)) {
              case_Rectype_Svector_above;
              case_Rectype_Snilvector_above;
              case_Rectype_nilvector_above;
              case_Rectype_mdarray_above;
              case_Rectype_ovector_above;
              case_Rectype_bvector_above;
              case_Rectype_b2vector_above;
              case_Rectype_b4vector_above;
              case_Rectype_b8vector_above;
              case_Rectype_b16vector_above;
              case_Rectype_b32vector_above;
              case_Rectype_string_above;
              case_Rectype_number_above;
              case_Rectype_Symbol_above;
              default: ;
            }
            #endif
            if (!marked(TheRecord(obj))) return; # already unmarked?
            unmark(TheRecord(obj)); # unmark
            # traverse all elements:
            {
              var uintC len = Record_length(obj);
              if (!(len==0)) {
                var gcv_object_t* objptr = &TheRecord(obj)->recdata[0];
                dotimespC(len,len, { subst_circ_unmark(&(*objptr++)); } );
              }
            }
            return;
          case_cons: # Cons
            if (!marked(TheCons(obj))) return; # already unmarked?
            unmark(TheCons(obj)); # unmark
            # recursive: subst_circ_unmark(&Car(obj))
            subst_circ_unmark(&TheCons(obj)->car);
            # end-recursive: subst_circ_unmark(&Cdr(obj))
            ptr = &TheCons(obj)->cdr; goto enter_subst;
          case_system: # Frame-Pointer or Read-Label or System
          case_machine: # Machine Pointer
          case_bvector: # Bit-Vector
          case_b2vector: # 2Bit-Vector
          case_b4vector: # 4Bit-Vector
          case_b8vector: # 8Bit-Vector
          case_b16vector: # 16Bit-Vector
          case_b32vector: # 32Bit-Vector
          case_string: # String
          case_char: # Character
          case_subr: # SUBR
          case_number: # Zahl
          case_symbol: # Symbol
          case_snilvector: /* (VECTOR NIL) */
            # Object contains no references -> do nothing
            return;
          default: NOTREACHED;
        }
      }
    }

#endif

#endif
