mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-26 06:22:33 -08:00
239a2aa4f1
We support both compare-and-swap and fetch-and-add (via
atomic-incf/decf) on the most common places and define an
extension interface for compare-and-swap similiar to the one in
SBCL.
These changes introduce new dependencies on the libatomic_ops
macros AO_fetch_compare_and_swap and AO_fetch_and_add.
153 lines
4 KiB
C
153 lines
4 KiB
C
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
|
|
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
|
|
|
|
/*
|
|
* structure.d - structure interface
|
|
*
|
|
* Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
|
|
* Copyright (c) 1990 Giuseppe Attardi
|
|
* Copyright (c) 2001 Juan Jose Garcia Ripoll
|
|
*
|
|
* See file 'LICENSE' for the copyright details.
|
|
*
|
|
*/
|
|
|
|
#include <ecl/ecl.h>
|
|
#include <ecl/ecl-inl.h>
|
|
#include <string.h>
|
|
|
|
/******************************* ------- ******************************/
|
|
|
|
static bool
|
|
structure_subtypep(cl_object x, cl_object y)
|
|
{
|
|
if (ECL_CLASS_NAME(x) == y) {
|
|
return TRUE;
|
|
} else {
|
|
cl_object superiors = ECL_CLASS_SUPERIORS(x);
|
|
loop_for_on_unsafe(superiors) {
|
|
if (structure_subtypep(ECL_CONS_CAR(superiors), y))
|
|
return TRUE;
|
|
} end_loop_for_on_unsafe(superiors);
|
|
return FALSE;
|
|
}
|
|
}
|
|
|
|
cl_object
|
|
si_structure_subtype_p(cl_object x, cl_object y)
|
|
{
|
|
@(return ((ecl_t_of(x) == T_STRUCTURE
|
|
&& structure_subtypep(ECL_STRUCT_TYPE(x), y)) ? ECL_T : ECL_NIL));
|
|
}
|
|
|
|
@(defun si::make-structure (type &rest args)
|
|
cl_object x;
|
|
int i;
|
|
@
|
|
x = ecl_alloc_object(T_STRUCTURE);
|
|
ECL_STRUCT_TYPE(x) = type;
|
|
ECL_STRUCT_SLOTS(x) = NULL; /* for GC sake */
|
|
ECL_STRUCT_LENGTH(x) = --narg;
|
|
ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object));
|
|
x->instance.sig = ECL_UNBOUND;
|
|
if (narg >= ECL_SLOTS_LIMIT)
|
|
FEerror("Limit on structure size exceeded: ~S slots requested.",
|
|
1, ecl_make_fixnum(narg));
|
|
for (i = 0; i < narg; i++)
|
|
ECL_STRUCT_SLOT(x, i) = ecl_va_arg(args);
|
|
@(return x);
|
|
@)
|
|
|
|
#define ecl_copy_structure si_copy_instance
|
|
|
|
cl_object
|
|
cl_copy_structure(cl_object s)
|
|
{
|
|
switch (ecl_t_of(s)) {
|
|
case t_instance:
|
|
s = ecl_copy_structure(s);
|
|
break;
|
|
case t_list:
|
|
#ifdef ECL_UNICODE
|
|
case t_string:
|
|
#endif
|
|
case t_base_string:
|
|
case t_bitvector:
|
|
case t_vector:
|
|
s = cl_copy_seq(s);
|
|
break;
|
|
default:
|
|
FEwrong_type_only_arg(@[copy-structure], s, @[structure]);
|
|
}
|
|
@(return s);
|
|
}
|
|
|
|
|
|
/* Kept only for compatibility. One should use class-of or type-of. */
|
|
cl_object
|
|
si_structure_name(cl_object s)
|
|
{
|
|
if (ecl_unlikely(Null(si_structurep(s))))
|
|
FEwrong_type_only_arg(@[si::structure-name], s, @[structure]);
|
|
@(return ECL_STRUCT_NAME(s));
|
|
}
|
|
|
|
cl_object
|
|
si_structure_ref(cl_object x, cl_object type, cl_object index)
|
|
{
|
|
if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE ||
|
|
!structure_subtypep(ECL_STRUCT_TYPE(x), type)))
|
|
FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type);
|
|
@(return ECL_STRUCT_SLOT(x, ecl_fixnum(index)));
|
|
}
|
|
|
|
cl_object
|
|
ecl_structure_ref(cl_object x, cl_object type, cl_fixnum n)
|
|
{
|
|
|
|
if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE ||
|
|
!structure_subtypep(ECL_STRUCT_TYPE(x), type)))
|
|
FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type);
|
|
return(ECL_STRUCT_SLOT(x, n));
|
|
}
|
|
|
|
cl_object
|
|
si_structure_set(cl_object x, cl_object type, cl_object index, cl_object val)
|
|
{
|
|
if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE ||
|
|
!structure_subtypep(ECL_STRUCT_TYPE(x), type)))
|
|
FEwrong_type_nth_arg(@[si::structure-set], 1, x, type);
|
|
ECL_STRUCT_SLOT(x, ecl_fixnum(index)) = val;
|
|
@(return val);
|
|
}
|
|
|
|
cl_object
|
|
ecl_structure_set(cl_object x, cl_object type, cl_fixnum n, cl_object v)
|
|
{
|
|
if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE ||
|
|
!structure_subtypep(ECL_STRUCT_TYPE(x), type)))
|
|
FEwrong_type_nth_arg(@[si::structure-set], 1, x, type);
|
|
ECL_STRUCT_SLOT(x, n) = v;
|
|
return(v);
|
|
}
|
|
|
|
#ifdef ECL_THREADS
|
|
cl_object
|
|
mp_compare_and_swap_structure(cl_object x, cl_object type, cl_object index, cl_object old, cl_object new)
|
|
{
|
|
if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE ||
|
|
!structure_subtypep(ECL_STRUCT_TYPE(x), type)))
|
|
FEwrong_type_nth_arg(@[mp::compare-and-swap-structure], 1, x, type);
|
|
return ecl_compare_and_swap(&(ECL_STRUCT_SLOT(x, ecl_fixnum(index))), old, new);
|
|
}
|
|
#endif
|
|
|
|
cl_object
|
|
si_structurep(cl_object s)
|
|
{
|
|
if (ECL_INSTANCEP(s) &&
|
|
structure_subtypep(ECL_CLASS_OF(s), @'structure-object'))
|
|
return ECL_T;
|
|
else
|
|
return ECL_NIL;
|
|
}
|