Vector.c

/*
 * Vector.c -- Implementation of Scheme Vectors
 *
 * (C) m.b (Matthias Blume); Mar 1992, HUB; Jan 1993 PU/CS
 *         Humboldt-University of Berlin
 *         Princeton University, Dept. of Computer Science
 *
 * $Id: Vector.c,v 2.6 1994/11/12 22:17:00 blume Exp $
 */

# include "rcs.h"
RCSID ("$Id: Vector.c,v 2.6 1994/11/12 22:17:00 blume Exp $")

# include <stdio.h>

# include "storext.h"
# include "Vector.h"
# include "identifier.h"
# include "type.h"
# include "except.h"

static MEM_cnt measure (void *vvect)
{
  ScmVector *vect = (ScmVector *) vvect;

  return MEM_UNITS (sizeof (ScmVector) + (vect->length - 1) * sizeof (void *));
}

static void iterator (void *vvect, MEM_visitor proc, void *cd)
{
  ScmVector *vect = (ScmVector *) vvect;
  unsigned long i;

  i = vect->length;
  while(i--)
    (*proc) ((void *)&vect->array[i], cd);
}

static void dumper (void *vvect, FILE *file)
{
  MEM_dump_ul (((ScmVector *)vvect)->length, file);
}

ScmVector *NewScmVector (unsigned long length)
{
  ScmVector *vect;

  SCM_NEW_VECTOR (vect, length);
  while (length-- > 0)
    vect->array [length] = NULL;
  return vect;
}

static void *excavator (FILE *file)
{
  unsigned long length;

  length = MEM_restore_ul (file);
  return NewScmVector (length);
}

static
void do_write (ScmVector *vect, putc_proc pp, void *cd, write_proc sub_write)
{
  unsigned long i;

  (* pp) ('#', cd);
  (* pp) ('(', cd);
  if (vect->length > 0) {
    (* sub_write) (vect->array[0], pp, cd);
    for (i = 1; i < vect->length; i++) {
      (* pp) (' ', cd);
      (* sub_write) (vect->array[i], pp, cd);
    }
  }
  (* pp) (')', cd);
}

static void display (void *vvect, putc_proc pp, void *cd)
{
  do_write (vvect, pp, cd, display_object);
}

static void write_this (void *vvect, putc_proc pp, void *cd)
{
  do_write (vvect, pp, cd, write_object);
}

static int equal (void *vself, void *vother)
{
  ScmVector *self, *other;
  unsigned long i;

  if (ScmTypeOf (vother) != ScmType (Vector))
    return 0;
  self = vself;
  other = vother;
  if (self->length != other->length)
    return 0;
  for (i = 0; i < self->length; i++)
    if (equal_object (self->array[i], other->array[i]) == 0)
      return 0;
  return 1;
}

MEM_VECTOR (Vector,
	    0, measure,
	    iterator, dumper, excavator, MEM_NULL_revisor,
	    MEM_NULL_task, MEM_NULL_task, MEM_NULL_task,
	    EXT (SCM_NO_NUMBER,
		 cannot_cvt_real, display, write_this, equal, NULL_eq));