Cons.c

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

# include "rcs.h"
RCSID ("$Id: Cons.c,v 2.6 1994/11/12 22:14:05 blume Exp $")

# include <stdio.h>

# include "storext.h"
# include "Cons.h"
# include "identifier.h"
# include "keyword.h"
# include "Boolean.h"
# include "type.h"

static void iterator (void *vcons, MEM_visitor proc, void *cd)
{
  ScmCons *cons = (ScmCons *) vcons;

  (*proc) ((void *)&cons->car, cd);
  (*proc) ((void *)&cons->cdr, cd);
}

static
void do_write (void *vcons, putc_proc pp, void *cd, write_proc sub_write)
{
  ScmCons *cons = vcons;

  if (ScmTypeOf (cons->cdr) == ScmType (Cons) &&
      ((ScmCons *) cons->cdr)->cdr == &ScmNil) {
    int special = 0;
    if (cons->car == ScmQuotePtr) {
      (* pp) ('\'', cd);
      special = 1;
    } else if (cons->car == ScmQuasiquotePtr) {
      (* pp) ('`', cd);
      special = 1;
    } else if (cons->car == ScmUnquotePtr) {
      (* pp) (',', cd);
      special = 1;
    } else if (cons->car == ScmUnquoteSplicingPtr) {
      (* pp) (',', cd);
      (* pp) ('@', cd);
      special = 1;
    }
    if (special) {
      (* sub_write) (((ScmCons *) cons->cdr)->car, pp, cd);
      return;
    }
  }
  (* pp) ('(', cd);
  (* sub_write) (cons->car, pp, cd);
  vcons = cons->cdr;
  while (vcons != NULL && ScmTypeOf (vcons) == ScmType (Cons)) {
    cons = vcons;
    (* pp) (' ', cd);
    (* sub_write) (cons->car, pp, cd);
    vcons = cons->cdr;
  }
  if (vcons != &ScmNil) {
    putc_string (" . ", pp, cd);
    (* sub_write) (vcons, pp, cd);
  }
  (* pp) (')', cd);
}

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

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

static int equal (void *vself, void *vother)
{
  ScmCons *self, *other;

  do {
    if (vself == vother)
      return 1;
    if (ScmTypeOf (vother) != ScmType (Cons))
      return 0;
    self = vself;
    other = vother;
    if (equal_object (self->car, other->car) == 0)
      return 0;
    vself = self->cdr;
    vother = other->cdr;
  } while (ScmTypeOf (vself) == ScmType (Cons));
  return equal_object (vself, vother);
}

MEM_VECTOR (Cons,
	    MEM_UNITS (sizeof (ScmCons)), MEM_NULL_measure,
	    iterator, MEM_NULL_dumper, MEM_NULL_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));