ecl/src/c/structure.d

/*
    structure.c -- Structure interface.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

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

    See file '../Copyright' for full details.
*/


#include "ecls.h"

/******************************* EXPORTS ******************************/

cl_object @'si::structure-print-function';
cl_object @'si::structure-slot-descriptions';
#ifdef CLOS
cl_object @'structure-object';
#else
cl_object siSstructure_include;
#endif

/******************************* ------- ******************************/

#ifdef CLOS
bool
structure_subtypep(cl_object x, cl_object y)
{ cl_object superiors;
  if (CLASS_NAME(x) == y)
    return(TRUE);
  for (superiors=CLASS_SUPERIORS(x); superiors!=Cnil;
       superiors=CDR(superiors)) {
    if (structure_subtypep(CAR(superiors), y))
      return(TRUE);
  }
  return(FALSE);
}
#else
bool
structure_subtypep(cl_object x, cl_object y)
{
	do {
		if (!SYMBOLP(x))
			return(FALSE);
		if (x == y)
			return(TRUE);
		x = get(x, siSstructure_include, Cnil);
	} while (x != Cnil);
	return(FALSE);
}
#endif CLOS

@(defun si::structure_subtype_p (x y)
@
	@(return ((type_of(x) == T_STRUCTURE
		     && structure_subtypep(STYPE(x), y)) ? Ct : Cnil))
@)

#ifndef CLOS
/* This is only used for printing. Should not cons!! */ 
cl_object
structure_to_list(cl_object x)
{
	cl_object *p, r, s;
	int i, n;

	s = getf(SNAME(x)->symbol.plist,
	         siSstructure_slot_descriptions, Cnil);
	p = &CDR(r = CONS(SNAME(x), Cnil));
	for (i=0, n=SLENGTH(x);  !endp(s) && i<n;  s=CDR(s), i++) {
		p = &(CDR(*p = CONS(car(CAR(s)), Cnil)));
		p = &(CDR(*p = CONS(SLOT(x, i), Cnil)));
	}
	return(r);
}
#else
cl_object
structure_to_list(cl_object x)
{ FEerror("Should never be called!",0);
}
#endif CLOS

@(defun si::make_structure (type &rest args)
	cl_object x;
	int i;
@
	x = alloc_object(T_STRUCTURE);
	STYPE(x) = type;
	SLOTS(x) = NULL;	/* for GC sake */
	SLENGTH(x) = --narg;
	SLOTS(x) = alloc_align(sizeof(cl_object)*narg, sizeof(cl_object));
	for (i = 0;  i < narg;  i++)
		SLOT(x, i) = va_arg(args, cl_object);
	@(return x)
@)

@(defun si::copy_structure (x)
	cl_index j, size;
	cl_object y;
@
	if (!STRUCTUREP(x))
		FEwrong_type_argument(@'structure', x);
	y = alloc_object(T_STRUCTURE);
	STYPE(y) = STYPE(x);
	SLENGTH(y) = j = SLENGTH(x);
	size = sizeof(cl_object)*j;
	SLOTS(y) = NULL;	/* for GC sake */
	SLOTS(y) = alloc_align(size, sizeof(cl_object));
	memcpy(SLOTS(y), SLOTS(x), size);
	@(return y)
@)

/* Kept only for compatibility. One should use class-of or type-of. */
@(defun si::structure_name (s)
@
	if (!STRUCTUREP(s))
		FEwrong_type_argument(@'structure', s);
	@(return SNAME(s))
@)

@(defun si::structure_ref (x type index)
@
	if (type_of(x) != T_STRUCTURE ||
	    !structure_subtypep(STYPE(x), type))
		FEwrong_type_argument(type, x);
	@(return SLOT(x, fix(index)))
@)

cl_object
structure_ref(cl_object x, cl_object name, int n)
{

	if (type_of(x) != T_STRUCTURE ||
	    !structure_subtypep(STYPE(x), name))
		FEwrong_type_argument(name, x);
	return(SLOT(x, n));
}

@(defun si::structure_set (x type index val)
@
	if (type_of(x) != T_STRUCTURE ||
	    !structure_subtypep(STYPE(x), type))
		FEwrong_type_argument(type, x);
	SLOT(x, fix(index)) = val;
	@(return val)
@)

cl_object
structure_set(cl_object x, cl_object name, int n, cl_object v)
{

	if (type_of(x) != T_STRUCTURE ||
	    !structure_subtypep(STYPE(x), name))
		FEwrong_type_argument(name, x);
	SLOT(x, n) = v;
	return(v);
}

@(defun si::structurep (s)
@
	@(return (STRUCTUREP(s) ? Ct : Cnil))
@)

@(defun si::rplaca_nthcdr (x idx v)
/*
	Used in DEFSETF forms generated by DEFSTRUCT.
	(si:rplaca-nthcdr x i v) is equivalent to 
	(progn (rplaca (nthcdr i x) v) v).
*/
	cl_fixnum i;
	cl_object l;
@
	assert_type_cons(x);
	for (i = fixnnint(idx), l = x;  i > 0; --i) {
		l = CDR(l);
		if (endp(l)) FEtype_error_index(idx);
	}
	CAR(l) = v;
	@(return v)
@)

@(defun si::list_nth (idx x)
/*
	Used in structure access functions generated by DEFSTRUCT.
	si:list-nth is similar to nth except that
	(si:list-nth i x) is error if the length of the list x is less than i.
*/
	cl_fixnum i;
	cl_object l;
@
	assert_type_cons(x);
	for (i = fixnnint(idx), l = x;  i > 0; --i) {
		l = CDR(l);
		if (endp(l)) FEtype_error_index(idx);
	}
	@(return CAR(l))
@)