/src/record.d

Large files files are truncated, but you can click here to view the full file

/*
 * Functions for records and structures in CLISP
 * Bruno Haible 1990-2005
 * Sam Steingold 1998-2008
 * German comments translated into English: Stefan Kain 2002-04-16
 */
#include "lispbibl.c"

/* ===========================================================================
 * general records:

 (SYS::%RECORD-REF record index) return the index'th entry in the record.
 (SYS::%RECORD-STORE record index value) store value as the index'th
   entry in the record and return value.
 (SYS::%RECORD-LENGTH record) return the length of the record.

 Error message
 > STACK_1: record
 > STACK_0: (bad) index
 > limit: exclusive upper bound on the index */
nonreturning_function(local, error_index, (uintL limit)) {
  pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
  {
    var object tmp;
    pushSTACK(S(integer)); pushSTACK(Fixnum_0); pushSTACK(UL_to_I(limit));
    tmp = listof(1); pushSTACK(tmp); tmp = listof(3);
    pushSTACK(tmp); /* TYPE-ERROR slot EXPECTED-TYPE */
  }
  pushSTACK(STACK_(1+2)); /* record */
  pushSTACK(STACK_(0+3)); /* index */
  pushSTACK(TheSubr(subr_self)->name); /* function name */
  error(type_error,GETTEXT("~S: ~S is not a valid index into ~S"));
}

/* Error message
 > STACK_0: (bad) record */
nonreturning_function(local, error_record, (void)) {
  pushSTACK(TheSubr(subr_self)->name); /* function name */
  error(error_condition, /* type_error ?? */
        GETTEXT("~S: ~S is not a record"));
}

/* Subroutine for record access functions
 > STACK_1: record argument
 > STACK_0: index argument
 < STACK: cleared up
 < returns: the address of the referred record item */
local gcv_object_t* record_up (void) {
  /* the record must be a Closure/Structure/Stream/OtherRecord: */
  if_recordp(STACK_1, ; , { skipSTACK(1); error_record(); } );
  var object record = STACK_1;
  var uintL length = Record_length(record);
  var uintV index;
  if (!(posfixnump(STACK_0) && ((index = posfixnum_to_V(STACK_0)) < length)))
    /* extract and check index */
    error_index(length);
  skipSTACK(2); /* clear up stack */
  return &TheRecord(record)->recdata[index]; /* record element address */
}

/* (SYS::%RECORD-REF record index) return the index'th entry in the record */
LISPFUNNR(record_ref,2)
{
  VALUES1(*(record_up())); /* record element as value */
}

/* (SYS::%RECORD-STORE record index value) store value as the index'th
   entry in the record and return value. */
LISPFUNN(record_store,3)
{
  var object value = popSTACK();
  VALUES1(*(record_up()) = value); /* set record element */
}

/* (SYS::%RECORD-LENGTH record) return the length of the record. */
LISPFUNNR(record_length,1)
{
  /* the record must be a Closure/Structure/Stream/OtherRecord: */
  if_recordp(STACK_0, ; , { error_record(); } );
  var object record = popSTACK();
  var uintL length = Record_length(record);
  VALUES1(fixnum(length)); /* length as Fixnum */
}

/* check that the length is of type (INTEGER (0) (65536))
 > STACK_0: length
 < uintV length: checked length */
#define test_record_length(length)                                            \
  if (!(posfixnump(STACK_0)                                                   \
        && ((length = posfixnum_to_V(STACK_0)) <= (uintV)(vbitm(intWsize)-1)) \
        && (length>0)))                                                       \
    error_record_length()
nonreturning_function(local, error_record_length, (void)) {
  /* STACK_0 = length, TYPE-ERROR slot DATUM */
  pushSTACK(O(type_posint16)); /* TYPE-ERROR slot EXPECTED-TYPE */
  pushSTACK(O(type_posint16)); /* type */
  pushSTACK(STACK_2); /* length */
  pushSTACK(TheSubr(subr_self)->name); /* function name */
  error(type_error,GETTEXT("~S: length ~S should be of type ~S"));
}

/* ===========================================================================
 * Structures:

 (SYS::%STRUCTURE-REF type structure index) returns for a structure of
   given Type type (a Symbol) the entry at index>=1.
 (SYS::%STRUCTURE-STORE type structure index object) stores object as
   Entry index in a structure of given Type type and returns object.
 (SYS::%MAKE-STRUCTURE type length) creates a structure with length>=1
   elements of Type type.
 (COPY-STRUCTURE structure) returns a copy of the Structure structure,
   of the same type.
 (SYS::%STRUCTURE-TYPE-P type object) checks if object is a
   structure that has the Type type, which can be recognized in
   component 0. There, an object (name_1 ... name_i-1 name_i) should
   be located with one of the names EQ to type.
*/
/* subroutine for structure-access-functions:
 > STACK_2: type-argument
 > STACK_1: structure-argument
 > STACK_0: index-argument
 < result: Address of the structure-element */
local gcv_object_t* structure_up (void) {
  /* structure must be of Type structure: */
  if (!structurep(STACK_1)) {
   error_bad_structure: /* STACK_2 = type, STACK_1 = structure */
    pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */
    pushSTACK(STACK_(2+1)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(STACK_(2+2));
    pushSTACK(STACK_(1+3));
    pushSTACK(TheSubr(subr_self)->name); /* function name */
    error(type_error,GETTEXT("~S: ~S is not a structure of type ~S"));
  }
  var object structure = STACK_1;
  /* check if type occurs in namelist = (name_1 ... name_i-1 name_i) : */
  if (!nullp(memq(STACK_2,TheStructure(structure)->structure_types)))
    goto yes;
  /* type did not occur -> Error: */
  goto error_bad_structure;
 yes: { /* type did occur: */
    var uintL length = (uintL)Structure_length(structure);
    var uintV index;
    /* fetch index and check */
    if (!(posfixnump(STACK_0) && ((index = posfixnum_to_V(STACK_0)) < length)))
      error_index(length);
    /* address of the structure-component */
    return &TheStructure(structure)->recdata[index];
  }
}

/* (SYS::%%STRUCTURE-REF type structure index) returns for a structure of
   the given Type type (a symbol) the entry index>=1.
 #<UNBOUND> is possible. */
LISPFUNNR(pstructure_ref,3) {
  VALUES1(*(structure_up())); /* structure-element as value */
  skipSTACK(3); /* clean up stack */
}

/* (SYS::%STRUCTURE-REF type structure index) returns for a structure of
   the given Type type (a symbol) the entry index>=1. */
LISPFUNNR(structure_ref,3) {
  VALUES1(*(structure_up())); /* structure-element as value */
  if (!boundp(value1)) {
    /* could be = #<UNBOUND> , after use of SLOT-MAKUNBOUND
       or after incomplete INITIALIZE-INSTANCE */
    dynamic_bind(S(print_length),Fixnum_0); /* bind *PRINT-LENGTH* to 0 */
    pushSTACK(STACK_(1+3)); /* UNBOUND-SLOT slot INSTANCE */
    /* (clos:slot-definition-name
         (find index (clos::class-slots (find-class type))
                     :key #'clos:slot-definition-location)) */
    pushSTACK(STACK_(2+3+1)); funcall(L(find_class),1);
    pushSTACK(value1); funcall(S(class_slots),1);
    pushSTACK(STACK_(0+3+1)); pushSTACK(value1); pushSTACK(S(Kkey));
    pushSTACK(Symbol_function(S(slot_definition_location))); funcall(L(find),4);
    value1 = TheSlotDefinition(value1)->slotdef_name;
    pushSTACK(value1); /* UNBOUND-SLOT slot NAME */
    pushSTACK(STACK_(1+3+2));
    pushSTACK(value1);
    pushSTACK(S(structure_ref));
    error(unbound_slot,GETTEXT("~S: Slot ~S of ~S has no value"));
  }
  skipSTACK(3); /* clean up stack */
}

/* (SYS::%STRUCTURE-STORE type structure index object) stores object as
   entry index in a structure of given Type type and returns object. */
LISPFUNN(structure_store,4) {
  var object value = popSTACK();
  VALUES1(*(structure_up()) = value); /* enter structure-element */
  skipSTACK(3); /* clean up stack */
}

/* (SYS::%MAKE-STRUCTURE type length) creates a structure with length>=1
   elements of Type type. */
LISPFUNNR(make_structure,2) {
  /* check length, should be a fixnum /=0  that fits into a uintW: */
  var uintV length;
  test_record_length(length);
  skipSTACK(1);
  var object structure = allocate_structure(length);
  /* new structure, filled with NILs */
  TheStructure(structure)->structure_types = popSTACK(); /* type component */
  VALUES1(structure); /* structure as value */
}

/* check_structure_replacement(obj)
 > obj: not a structure object
 < result: a structure object, a replacement
 can trigger GC */
global maygc object check_structure_replacement (object obj) {
  do {
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(obj); /* TYPE-ERROR slot DATUM */
    pushSTACK(S(structure_object)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(S(structure_object)); pushSTACK(obj);
    pushSTACK(TheSubr(subr_self)->name); /* function name */
    check_value(type_error,GETTEXT("~S: ~S is not a ~S"));
    obj = value1;
  } while (!structurep(obj));
  return obj;
}

/* (COPY-STRUCTURE structure) returns a copy of the Structure structure
   of the same type. */
LISPFUNNR(copy_structure,1) {
  STACK_0 = check_structure(STACK_0);
  var uintC length = Structure_length(STACK_0);
  var object new_structure = allocate_structure(length);
  copy_mem_o(&TheStructure(new_structure)->structure_types,
             &TheStructure(popSTACK())->structure_types,length);
  VALUES1(new_structure);
}

/* (SYS::%STRUCTURE-TYPE-P type object) checks if object is a
   structure that has the Type type, which can be recognized in
   component 0. There, an object (name_1 ... name_i-1 name_i) should
   be located with one of the names EQ to type. */
LISPFUNNR(structure_type_p,2) {
  /* check object for structure: */
  if (!structurep(STACK_0)) { skipSTACK(2); goto no; }
  {
    var object namelist = TheStructure(popSTACK())->structure_types;
    var object type = popSTACK();
    /* test, if type occurs in namelist = (name_1 ... name_i-1 name_i) : */
    if (!nullp(memq(type,namelist)))
      goto yes;
  }
 no: /* type did not occur: */
  VALUES1(NIL); return; /* 1 value NIL */
 yes: /* type did occur: */
  VALUES1(T); return;
}

/* ===========================================================================
 * Closures:

 (SYS::CLOSURE-NAME closure) returns the name of a closure.
 (SYS::CLOSURE-CODEVEC closure) returns the code-vector of a compiled
   closure as an array of fixnums >=0, <256.
 (SYS::CLOSURE-CONSTS closure) returns a list of all constants of a
   compiled closure.
 (SYS::MAKE-CLOSURE &key name code constants seclass lambda-list documentation
    jitc-p) returns a closure with given name (a symbol), given code-vector
    (a list of bytes), given constants, seclass, lalist, doc string and JITC_p.
 (SYS::MAKE-CONSTANT-INITFUNCTION value) returns a closure that, when called
   with 0 arguments, returns the given value.
 (SYS::CONSTANT-INITFUNCTION-P object) tests whether an object was returned by
   SYS::MAKE-CONSTANT-INITFUNCTION.
 (CLOS:SET-FUNCALLABLE-INSTANCE-FUNCTION closure function) redirects closure
   so that it calls the given function.
 (SYS::%COPY-GENERIC-FUNCTION venv closure) copies the closure, which must be
   a generic function with venv slot, copying in the given venv.
 (SYS::GENERIC-FUNCTION-EFFECTIVE-METHOD-FUNCTION generic-function)
   returns a function, which delivers the effective methods, so that
   (APPLY generic-function arguments)
   == (APPLY (APPLY result arguments) arguments) .
*/

/* error, if argument is not a closure */
nonreturning_function(local, error_closure, (object obj)) {
  pushSTACK(obj);
  pushSTACK(TheSubr(subr_self)->name); /* function name */
  error(error_condition, /* type_error ?? */
        GETTEXT("~S: ~S is not a closure"));
}

/* (SYS::CLOSURE-NAME closure) returns the name of a closure. */
LISPFUNNR(closure_name,1) {
  var object closure = popSTACK();
  if (!closurep(closure)) error_closure(closure);
  VALUES1(Closure_name(closure));
}

/* ((SETF SYS::CLOSURE-NAME) new-value closure) changes the name of a
   closure. */
LISPFUNN(set_closure_name,2) {
  var object closure = popSTACK();
  if (!closurep(closure)) error_closure(closure);
  var object new_name = popSTACK();
  if (Closure_instancep(closure))
    TheCclosure(closure)->clos_consts[1] = new_name;
  else
    TheClosure(closure)->clos_name_or_class_version = new_name;
  VALUES1(new_name);
}

/* error, if argument is not a compiled closure */
nonreturning_function(local, error_cclosure, (object obj)) {
  pushSTACK(obj);
  pushSTACK(TheSubr(subr_self)->name); /* function name */
  error(error_condition, /* type_error ?? */
        GETTEXT("~S: ~S is not a compiled closure"));
}

/* (SYS::CLOSURE-CODEVEC closure) returns the code-vector of a compiled
   closure, as an array of fixnums >=0, <256. */
LISPFUNNR(closure_codevec,1) {
  var object closure = popSTACK();
  if (!cclosurep(closure)) error_cclosure(closure);
  var object codevec = TheCclosure(closure)->clos_codevec;
  VALUES1(codevec);
}

/* (SYS::CLOSURE-CONSTS closure) returns a list of all constants of a
   compiled closure. */
LISPFUNNR(closure_consts,1) {
  var object closure = popSTACK();
  if (!cclosurep(closure)) error_cclosure(closure);
  /* put elements 2,3,... to a list: */
  var uintB ccv_flags =
    TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags;
  var uintC index = Cclosure_last_const(closure) + 1
    - ccv_flags_jitc_p(ccv_flags) - ccv_flags_documentation_p(ccv_flags)
    - ccv_flags_lambda_list_p(ccv_flags);
  /* step through closure from behind and push constants onto a list: */
  pushSTACK(closure); /* closure */
  pushSTACK(NIL); /* list := () */
  while (index != 0) {
    index--; /* decrement index */
    /* put new cons in front of the list: */
    var object new_cons = allocate_cons();
    Cdr(new_cons) = popSTACK();
    Car(new_cons) = TheCclosure(STACK_0)->clos_consts[(uintP)index]; /* fetch constant */
    pushSTACK(new_cons);
  }
  VALUES1(STACK_0); skipSTACK(2); /* list as value */
}

/* return the address of the Nth constant
 > STACK_0: position
 > STACK_1: compiled closure
 < address of the constant
 can trigger GC */
local maygc gcv_object_t* closure_const (void) {
  var uintV pos = posfixnum_to_V(check_posfixnum(STACK_0));
  var object closure = STACK_1;
  if (!cclosurep(closure)) error_cclosure(closure);
  var uintB ccv_flags =
    TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags;
  var uintC max_index = Cclosure_last_const(closure)
    - ccv_flags_documentation_p(ccv_flags) - ccv_flags_lambda_list_p(ccv_flags);
  if (pos > max_index) error_index(max_index);
  return &(TheCclosure(closure)->clos_consts[(uintP)pos]);
}

/* (SYS::CLOSURE-CONST closure n)
   returns the n-th constant of the compiled closure. */
LISPFUNNR(closure_const,2) {
  VALUES1(*closure_const()); skipSTACK(2);
}
/* (SYS::SET-CLOSURE-CONST value closure n)
   set the n-th constant of the compiled closure. */
LISPFUNN(set_closure_const,3) {
  VALUES1(*closure_const() = STACK_2); skipSTACK(3);
}

/* make_code_vector(list) converts a list of fixnums >=0, <256
 into a simple-8bit-vector of the same length, that contains these numbers
 as bytes. */
local maygc void make_code_vector (gcv_object_t *code) {
  var object bv = allocate_bit_vector(Atype_8Bit,llength(*code)); /* simple-8bit-vector */
  /* fill: */
  var object listr = *code; /* list */
  var uintB* ptr = &TheSbvector(bv)->data[0]; /* loop through the bit-vector */
  while (consp(listr)) {
    var uintV byte;
    /* list element must be a fixnum >=0, <256 : */
    if (!(posfixnump(Car(listr))
          && ((byte = posfixnum_to_V(Car(listr))) < (1<<intBsize))))
      goto bad_byte;
    /* put into the bit-vector: */
    *ptr++ = (uintB)byte;
    listr = Cdr(listr);
  }
  *code = bv;
  return;
 bad_byte:
  pushSTACK(Car(listr)); /* TYPE-ERROR slot DATUM */
  pushSTACK(O(type_uint8)); /* TYPE-ERROR slot EXPECTED-TYPE */
  pushSTACK(STACK_1);
  error(type_error,GETTEXT("~S is not a valid code-vector byte"));
}

/* parse the seclass object (NIL or SECLASS, see compiler.lisp)
   into a seclass_t */
local seclass_t parse_seclass (object sec, object closure)
{
  if (nullp(sec)) return seclass_foldable;
  if (!consp(sec) || !consp(Cdr(sec)) || !consp(Cdr(Cdr(sec)))) {
    pushSTACK(closure); pushSTACK(sec);
    pushSTACK(TheSubr(subr_self)->name);
    error(error_condition,GETTEXT("~S: invalid side-effect class ~S for function ~S"));
  }
  var object modifies = Car(Cdr(sec));
  return (nullp(Car(sec))
          ? (nullp(modifies) ? seclass_no_se : seclass_write)
          : (nullp(modifies) ? seclass_read : seclass_default));
}

/* (SYS::%MAKE-CLOSURE name codevec consts seclassJ lambda-list documentation)
 returns a closure with given name (a symbol),
 given code-vector (a simple-bit-vector), given constants,
 given side-effect class, lambda-list and documentation. */
LISPFUN(make_closure,seclass_default,0,0,norest,key,7,(kw(name),kw(code),
        kw(constants),kw(seclass),kw(lambda_list),kw(documentation),kw(jitc_p)))
{
  var bool jitc_p = !eq(Fixnum_0,popSTACK());
  var seclass_t seclass = parse_seclass(STACK_2,STACK_5);
  /* convert code to a simple-bit-vector: */
  if (listp(STACK_4)) make_code_vector(&STACK_4);
  /* create a new closure of length
     (+ 2 (length consts) lalist-p doc-p jitc_p) : */
  var uintL length = 2+llength(STACK_3) + (jitc_p ? 1 : 0)
    +(listp(STACK_1) ? 1 : 0)+(nullp(STACK_0) || stringp(STACK_0) ? 1 : 0);
  if (!(length <= (uintL)(bitm(intWsize)-1))) { /* should fit into a uintW */
    pushSTACK(STACK_3/* constants */);
    pushSTACK(STACK_6/* name */);
    pushSTACK(TheSubr(subr_self)->name);
    error(error_condition,GETTEXT("~S: function ~S is too big: ~S"));
  }
  var object closure = allocate_closure(length,seclass<<4);
  TheCclosure(closure)->clos_name_or_class_version = STACK_5; /* fill name */
  TheCclosure(closure)->clos_codevec = STACK_4; /* fill codevector */
  /* fill constants: */
  var object constsr = STACK_3;
  var gcv_object_t* ptr = &TheCclosure(closure)->clos_consts[0];
  while (consp(constsr)) {
    *ptr++ = Car(constsr); constsr = Cdr(constsr);
  }
  var uintB *ccv_flags = &(TheCodevec(STACK_4)->ccv_flags);
  if (listp(STACK_1)) {
    *ccv_flags |= bit(1);
    *ptr++ = STACK_1;
  } else *ccv_flags &= ~bit(1);
  if (nullp(STACK_0) || stringp(STACK_0)) {
    *ccv_flags |= bit(2);
    *ptr++ = STACK_0;
  } else *ccv_flags &= ~bit(2);
  if (jitc_p) *ccv_flags |= bit(5);
  else *ccv_flags &= ~bit(5);
  VALUES1(closure); skipSTACK(6);
}

/* (SYS::MAKE-CONSTANT-INITFUNCTION value) returns a closure that, when called
   with 0 arguments, returns the given value. */
LISPFUNN(make_constant_initfunction,1)
{
  var object consts = listof(1);
  pushSTACK(S(constant_initfunction));
  pushSTACK(O(constant_initfunction_code));
  pushSTACK(consts);
  pushSTACK(O(seclass_no_se));
  pushSTACK(Fixnum_0); /* no lalist */
  pushSTACK(Fixnum_0); /* no doc */
  pushSTACK(Fixnum_0); /* no jitc */
  C_make_closure();
}

/* (SYS::CONSTANT-INITFUNCTION-P object) tests whether an object was returned by
   SYS::MAKE-CONSTANT-INITFUNCTION. */
#define CONSTANT_INITFUNCTION_P(obj)  (closurep(obj)  \
  && eq(TheClosure(obj)->clos_name_or_class_version,S(constant_initfunction)) \
  && eq(TheClosure(obj)->clos_codevec,O(constant_initfunction_code)))
LISPFUNN(constant_initfunction_p,1) {
  var object obj = popSTACK();
  VALUES_IF(CONSTANT_INITFUNCTION_P(obj));
}

LISPFUNN(closure_set_seclass,2)
{ /* (CLOSURE-SET-SECLASS closure new-seclass)
 - for adding methods to generic functions; return the old seclass */
  var object closure = STACK_1;
  if (!cclosurep(closure)) error_cclosure(closure);
  var seclass_t new_seclass = parse_seclass(STACK_0,closure);
  VALUES1(seclass_object((seclass_t)Cclosure_seclass(closure)));
  Cclosure_set_seclass(closure,new_seclass);
  skipSTACK(2);
}

LISPFUNNR(closure_documentation,1)
{ /* return the doc string, if any */
  var object closure = popSTACK();
  if (!cclosurep(closure)) error_cclosure(closure);
  var uintB ccv_flags =
    TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags;
  /* depending on bit(5), the ultimate or the penultimate constant */
  VALUES1(ccv_flags_documentation_p(ccv_flags)
          ? (object)TheCclosure(closure)->clos_consts
             [Cclosure_last_const(closure)-ccv_flags_jitc_p(ccv_flags)]
          : NIL);
}
LISPFUNN(closure_set_documentation,2)
{ /* set the doc string, if possible*/
  if (!nullp(STACK_0)) STACK_0 = check_string(STACK_0);
  var object closure = STACK_1;
  if (!cclosurep(closure)) error_cclosure(closure);
  var uintB ccv_flags =
    TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags;
  if (ccv_flags_documentation_p(ccv_flags))
    TheCclosure(closure)->clos_consts
      [Cclosure_last_const(closure)-ccv_flags_jitc_p(ccv_flags)] = STACK_0;
  VALUES1(STACK_0); skipSTACK(2);
}
LISPFUNNR(closure_lambda_list,1)
{ /* return the lambda list, if any */
  var object closure = popSTACK();
  if (!cclosurep(closure)) error_cclosure(closure);
  var uintB ccv_flags =
    TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags;
  /* depending on bit(2) & bit(5), the ultimate, penultimate
     or pre-penultimate constant */
  VALUES1(ccv_flags_lambda_list_p(ccv_flags)
          ? (object)TheCclosure(closure)->clos_consts
             [Cclosure_last_const(closure)-ccv_flags_documentation_p(ccv_flags)
	      -ccv_flags_jitc_p(ccv_flags)]
          : NIL);
}

/* (CLOS:SET-FUNCALLABLE-INSTANCE-FUNCTION closure function) redirects closure
   so that it calls the given function. */
LISPFUNN(set_funcallable_instance_function,2)
{
  var object closure = STACK_1;
  if (!funcallable_instance_p(closure)) {
    pushSTACK(closure); pushSTACK(TheSubr(subr_self)->name);
    error(error_condition, /* type_error ?? */
          GETTEXT("~S: argument is not a funcallable instance: ~S"));
  }
  var object function = STACK_0;
  if (!(subrp(function) || closurep(function) || ffunctionp(function))) {
    pushSTACK(function);    /* TYPE-ERROR slot DATUM */
    pushSTACK(S(function)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(function); pushSTACK(TheSubr(subr_self)->name);
    error(type_error, GETTEXT("~S: argument is not a function: ~S"));
  }
  var object codevec;
  var object venv;
  if (cclosurep(function) && Cclosure_length(function) <= 3) {
    codevec = TheCclosure(function)->clos_codevec;
    venv = (Cclosure_length(function) >= 3
            ? (object)TheCclosure(function)->clos_venv : NIL);
  } else {
    codevec = (pushSTACK(function), funcall(S(make_trampoline),1), value1);
    venv = STACK_0;
    closure = STACK_1;
  }
  if (record_flags(TheClosure(closure)) & instflags_forwarded_B) {
    var object closure_forwarded = TheClosure(closure)->clos_name_or_class_version;
    /* We know that there is at most one indirection. */
    ASSERT(!(record_flags(TheClosure(closure_forwarded)) & instflags_forwarded_B));
    /* Replace codevec and venv in both the original and the forwarded closure. */
    TheCclosure(closure_forwarded)->clos_codevec = codevec;
    TheCclosure(closure_forwarded)->clos_venv = venv;
  }
  TheCclosure(closure)->clos_codevec = codevec;
  TheCclosure(closure)->clos_venv = venv;
  VALUES1(closure); skipSTACK(2);
}

/* check_genericlambda_function(obj)
 > obj: an object
 < result: a function with a code vector produced by %GENERIC-FUNCTION-LAMBDA,
           either the same as obj or a replacement
 can trigger GC */
local maygc object check_genericlambda_function_replacement (object obj) {
  do {
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(obj); /* TYPE-ERROR slot DATUM */
    pushSTACK(S(standard_generic_function)); /* slot EXPECTED-TYPE */
    pushSTACK(S(standard_generic_function)); pushSTACK(obj);
    pushSTACK(TheSubr(subr_self)->name); /* function name */
    check_value(type_error,GETTEXT("~S: ~S is not a ~S"));
    obj = value1;
  } while (!genericlambda_function_p(obj));
  return obj;
}
local inline maygc object check_genericlambda_function (object obj) {
  if (!genericlambda_function_p(obj))
    obj = check_genericlambda_function_replacement(obj);
  return obj;
}

/* (SYS::%COPY-GENERIC-FUNCTION venv closure) copies the closure, which must be
   a generic function with venv slot, copying in the given venv. */
LISPFUNN(copy_generic_function,2) {
  /* Note: closure's clos_venv is a simple-vector #(NIL c1 ... cn) where
     c1,...,cn are constant objects, and NIL is the placeholder to be replaced
     with the passed venv. */
  var object oldclos = check_genericlambda_function(STACK_0);
  var object vector = TheCclosure(oldclos)->clos_venv;
  if (!(simple_vector_p(vector)
        && (Svector_length(vector) > 0)
        && nullp(TheSvector(vector)->data[0]))) {
    pushSTACK(oldclos);
    pushSTACK(TheSubr(subr_self)->name); /* function name */
    error(error_condition,
          GETTEXT("~S: This is not a prototype of a generic function: ~S"));
  }
  vector = copy_svector(vector); /* copy the vector */
  TheSvector(vector)->data[0] = STACK_1; /* put in venv */
  STACK_1 = vector;
  /* Copy the function: */
  var object newclos = allocate_cclosure_copy(STACK_0);
  oldclos = STACK_0;
  do_cclosure_copy(newclos,oldclos);
  /* Put in the copied vector with venv: */
  TheCclosure(newclos)->clos_venv = STACK_1;
  VALUES1(newclos);
  skipSTACK(2);
}

/* (SYS::GENERIC-FUNCTION-EFFECTIVE-METHOD-FUNCTION generic-function)
   returns a function, which delivers the effective methods, so that
   (APPLY generic-function arguments)
   == (APPLY (APPLY result arguments) arguments) .
   is used for CALL-NEXT-METHOD; can assume that the
   generic-function has already been called, i.e. that the dispatch has
   already been installed. */
LISPFUNN(generic_function_effective_method_function,1) {
  var object oldclos = STACK_0 = check_genericlambda_function(STACK_0);
  /* allocate closure of equal length: */
  var object newclos = allocate_cclosure_copy(oldclos);
  oldclos = STACK_0;
  do_cclosure_copy(newclos,oldclos);
  STACK_0 = newclos;
  /* copy the code-vector likewise: */
  var object newcodevec = copy_sbvector(TheClosure(newclos)->clos_codevec);
  /* set the bit therein which is queried by the RETGF-instruction: */
  TheCodevec(newcodevec)->ccv_flags |= bit(3);
  newclos = popSTACK();
  TheClosure(newclos)->clos_codevec = newcodevec;
  VALUES1(newclos);
}

/* ===========================================================================
 * load-time-eval:

 (SYS::MAKE-LOAD-TIME-EVAL form) returns a load-time-eval-object that
  - if printed and read again - evaluates form. */
LISPFUN(make_load_time_eval,seclass_no_se,1,0,norest,nokey,0,NIL) {
  var object lte = allocate_loadtimeeval();
  TheLoadtimeeval(lte)->loadtimeeval_form = popSTACK();
  VALUES1(lte);
}

/* ===========================================================================
 * symbol-macro:

 (SYS::MAKE-SYMBOL-MACRO expansion) returns a symbol-macro-object
   that represents the given expansion.
 (SYS::SYMBOL-MACRO-P object) tests for symbol-macro.

 Due to their special meaning in the interpreter, symbol-macro-objects
 - like #<UNBOUND> and #<SPECDECL> - are not first class objects.
 They can be passed only as values. They cannot be assigned to
 variables, however.

 (SYMBOL-MACRO-EXPAND symbol) tests if a symbol represents a symbol-macro
 in the global environment and returns T and the expansion if true, NIL if
 false.
*/
/* (SYS::MAKE-SYMBOL-MACRO expansion) returns a symbol-macro-object,
   that represents the given expansion. */
LISPFUN(make_symbol_macro,seclass_no_se,1,0,norest,nokey,0,NIL) {
  var object sm = allocate_symbolmacro();
  TheSymbolmacro(sm)->symbolmacro_expansion = popSTACK();
  VALUES1(sm);
}

LISPFUNNF(symbol_macro_p,1)
{ /* (SYS::SYMBOL-MACRO-P object) tests for symbol-macro. */
  var object obj = popSTACK();
  VALUES_IF(symbolmacrop(obj));
}

/* (SYMBOL-MACRO-EXPAND symbol) tests if a symbol represents a symbol-macro
 and returns T and the expansion if true, NIL if false.
 (defun symbol-macro-expand (v)
   (unless (symbolp v) (error ...))
   (and (sys::global-symbol-macro-p v)
        (values t (sys::%record-ref (get v 'SYS::SYMBOLMACRO) 0)))) */
LISPFUNN(symbol_macro_expand,1) {
  var object obj = check_symbol(popSTACK());
  if (symmacro_var_p(TheSymbol(obj))) {
    /* Fetch the symbol-macro definition from the property list: */
    var object symbolmacro = get(obj,S(symbolmacro));
    if (!eq(symbolmacro,unbound)) {
      ASSERT(globalsymbolmacrop(symbolmacro));
      VALUES2(T, TheSymbolmacro(TheGlobalSymbolmacro(symbolmacro)->globalsymbolmacro_definition)->symbolmacro_expansion);
      return;
    }
    /* Huh? The symbol-macro definition got lost. */
    clear_symmacro_flag(TheSymbol(obj));
  }
  VALUES1(NIL);
}

/* ===========================================================================
 * global-symbol-macro:

 The GlobalSymbolmacro object is used to wrap a Symbolmacro object while it
 is stored on the property list, so that user code that iterates over the
 elements of a property list in interpreted mode is not trapped.

 (SYS::MAKE-GLOBAL-SYMBOL-MACRO expansion) returns a global-symbol-macro object
   containing a symbol-macro object that represents the given expansion.
 (SYS::GLOBAL-SYMBOL-MACRO-DEFINITION object) unwraps a global-symbol-macro
   object and returns the symbol-macro object inside it.
*/

/* (SYS::MAKE-GLOBAL-SYMBOL-MACRO expansion) returns a global-symbol-macro object
   containing a symbol-macro object that represents the given expansion. */
LISPFUN(make_global_symbol_macro,seclass_no_se,1,0,norest,nokey,0,NIL) {
  pushSTACK(allocate_symbolmacro());
  var object gsm = allocate_globalsymbolmacro();
  var object sm = popSTACK();
  TheSymbolmacro(sm)->symbolmacro_expansion = popSTACK();
  TheGlobalSymbolmacro(gsm)->globalsymbolmacro_definition = sm;
  VALUES1(gsm);
}

/* (SYS::GLOBAL-SYMBOL-MACRO-DEFINITION object) unwraps a global-symbol-macro
   object and returns the symbol-macro object inside it. */
LISPFUNN(global_symbol_macro_definition,1)
{
  var object obj = popSTACK();
  while (!globalsymbolmacrop(obj)) {
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(obj); /* TYPE-ERROR slot DATUM */
    pushSTACK(S(global_symbol_macro)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(S(global_symbol_macro)); pushSTACK(obj);
    pushSTACK(S(global_symbol_macro_definition)); /* function name */
    check_value(type_error,GETTEXT("~S: ~S is not a ~S"));
    obj = value1;
  }
  VALUES1(TheGlobalSymbolmacro(obj)->globalsymbolmacro_definition);
}

/* ===========================================================================
 * Macro:

 (SYS::MAKE-MACRO expander lambdalist) returns a Macro object with the given
   expander function and macro lambda list.
 (SYS::MACROP object) tests for a Macro.
 (SYS::MACRO-EXPANDER macro) returns the macro's expander function. */

/* (SYS::MAKE-MACRO expander lambdalist)
 returns a Macro object with the given expander function. */
LISPFUN(make_macro,seclass_no_se,2,0,norest,nokey,0,NIL) {
  STACK_1 = check_function(STACK_1);
  var object m = allocate_macro();
  TheMacro(m)->macro_lambda_list = popSTACK();
  TheMacro(m)->macro_expander = popSTACK();
  VALUES1(m);
}

/* (SYS::MACROP object) tests for a Macro. */
LISPFUNN(macrop,1) {
  var object obj = popSTACK();
  VALUES_IF(macrop(obj));
}

/* UP: check that the argument is a macro
 > mac: macro
 < mac: same
 can trigger GC */
local maygc object check_macro (object obj) {
  while (!macrop(obj)) {
    pushSTACK(NIL);             /* no PLACE */
    pushSTACK(obj);             /* TYPE-ERROR slot DATUM */
    pushSTACK(S(macro));        /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(S(macro)); pushSTACK(obj);
    pushSTACK(TheSubr(subr_self)->name); /* function name */
    check_value(type_error,GETTEXT("~S: ~S is not a ~S"));
    obj = value1;
  }
  return obj;
}

/* (SYS::MACRO-EXPANDER macro) returns the macro's expander function. */
LISPFUNN(macro_expander,1) {
  var object obj = check_macro(popSTACK());
  VALUES1(TheMacro(obj)->macro_expander);
}

/* (SYS::MACRO-LAMBDA-LIST macro) returns the macro's lambda list. */
LISPFUNN(macro_lambda_list,1) {
  STACK_0 = check_macro(STACK_0);
  var object lalist = TheMacro(STACK_0)->macro_lambda_list;
  if (!listp(lalist))
    error(error_condition,GETTEXT("Due to the compiler optimization settings, lambda list for ~S is not available"));
  VALUES1(lalist); skipSTACK(1);
}

/* ===========================================================================
 * FunctionMacro:

 (SYS::MAKE-FUNCTION-MACRO function expander) returns a FunctionMacro object
 for the given function and with the given expander function.
 (SYS::FUNCTION-MACRO-P object) tests for a FunctionMacro.
 (SYS::FUNCTION-MACRO-FUNCTION macro) returns the functionmacro's function.
 (SYS::FUNCTION-MACRO-EXPANDER macro) returns the functionmacro's expander. */

/* (SYS::MAKE-FUNCTION-MACRO function expander) returns a FunctionMacro object
 for the given function and with the given expander function. */
LISPFUNN(make_function_macro,2) {
  STACK_0 = check_function(STACK_0);
  STACK_1 = check_function(STACK_1);
  var object m = allocate_functionmacro();
  TheFunctionMacro(m)->functionmacro_macro_expander = popSTACK();
  TheFunctionMacro(m)->functionmacro_function = popSTACK();
  VALUES1(m);
}

/* (SYS::FUNCTION-MACRO-P object) tests for a FunctionMacro. */
LISPFUNN(function_macro_p,1) {
  var object obj = popSTACK();
  VALUES_IF(functionmacrop(obj));
}

/* ensure that the OBJ is a FUNCTION-MACRO and return it
 can trigger GC */
local maygc object check_function_macro (object obj) {
  while (!functionmacrop(obj)) {
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(obj); /* TYPE-ERROR slot DATUM */
    pushSTACK(S(function_macro)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(S(function_macro)); pushSTACK(obj);
    pushSTACK(S(function_macro_expander)); /* function name */
    check_value(type_error,GETTEXT("~S: ~S is not a ~S"));
    obj = value1;
  }
  return obj;
}

/* (SYS::FUNCTION-MACRO-FUNCTION macro)
   returns the FunctionMacro's function. */
LISPFUNN(function_macro_function,1) {
  var object obj = check_function_macro(popSTACK());
  VALUES1(TheFunctionMacro(obj)->functionmacro_function);
}

/* (SYS::FUNCTION-MACRO-EXPANDER macro)
   returns the FunctionMacro's expander. */
LISPFUNN(function_macro_expander,1) {
  var object obj = check_function_macro(popSTACK());
  VALUES1(TheFunctionMacro(obj)->functionmacro_macro_expander);
}

/* ===========================================================================
 * Finalizer: */

/* (FINALIZE object function &optional alive)
 records that function is called if object dies through GC, with
 object and poss. alive as argument. If alive dies before object dies,
 nothing will be done. */
LISPFUN(finalize,seclass_default,2,1,norest,nokey,0,NIL) {
  STACK_1 = coerce_function(STACK_1);
  if (!gcinvariant_object_p(STACK_2)) {
    var object f = allocate_finalizer();
    TheFinalizer(f)->fin_trigger = STACK_2;
    TheFinalizer(f)->fin_function = STACK_1;
    TheFinalizer(f)->fin_alive = STACK_0; /* The default #<UNBOUND> lives forever. */
    TheFinalizer(f)->fin_cdr = O(all_finalizers);
    O(all_finalizers) = f;
  }
  skipSTACK(3); VALUES1(NIL);
}

/* ===========================================================================
 * CLOS objects: */

/* (CLOS::STRUCTURE-OBJECT-P object) tests if object is a structure. */
LISPFUNNF(structure_object_p,1)
{
  var object obj = popSTACK();
  VALUES_IF(structurep(obj));
}

/* (CLOS::STD-INSTANCE-P object) tests if object is a CLOS-object
   (funcallable or not). */
LISPFUNNF(std_instance_p,1)
{
  var object obj = popSTACK();
  VALUES_IF(instancep(obj));
}

/* (CLOS::FUNCALLABLE-INSTANCE-P object) tests if object is a funcallable
   CLOS-object. */
LISPFUNNF(funcallable_instance_p,1)
{
  var object obj = popSTACK();
  VALUES_IF(funcallable_instance_p(obj));
}

/* returns (CLOS:CLASS-OF object). Especially efficient for CLOS objects.
 can trigger GC */
local inline maygc object class_of (object obj) {
  if (instancep(obj)) {
    var object obj_forwarded = obj;
    instance_un_realloc(obj_forwarded);
    if ((record_flags(TheInstance(obj_forwarded)) & instflags_beingupdated_B) == 0) {
      /* We need instance_update here because CLHS 4.3.6. says:
         "Updating such an instance occurs at an implementation-dependent time,
          but no later than the next time a slot of that instance is read or
          written." */
      instance_update(obj,obj_forwarded);
      var object cv = TheInstance(obj_forwarded)->inst_class_version;
      return TheClassVersion(cv)->cv_newest_class;
    } else {
      /* Accessing an instance which is being updated. */
      var object cv = TheInstance(obj_forwarded)->inst_class_version;
      return TheClassVersion(cv)->cv_class;
    }
  } else {
    pushSTACK(obj); C_class_of(); return value1;
  }
}

/* (CLOS::ALLOCATE-METAOBJECT-INSTANCE class-version n) returns a CLOS-instance
 of length n, with ClassVersion class-version and n-1 additional slots. It does
 this without marking the class as being instantiated and is therefore suitable
 only for classes that are never redefined, such as CLASS, SLOT-DEFINITION. */
LISPFUNN(allocate_metaobject_instance,2) {
  /* check length, should be a fixnum >0 that fits into a uintW: */
  var uintV length;
  test_record_length(length);
  skipSTACK(1);
  {
    var object cv = STACK_0;
    if (!(simple_vector_p(cv) && Svector_length(cv) == classversion_length)) {
      pushSTACK(cv);
      pushSTACK(TheSubr(subr_self)->name); /* function name */
      error(error_condition,GETTEXT("~S: ~S is not a CLOS class-version"));
    }
  }
  var object instance =
    allocate_srecord(0,Rectype_Instance,length,instance_type);
  TheInstance(instance)->inst_class_version = popSTACK();
  /* fill the slots of the instance with #<UNBOUND> : */
  length--;
  if (length > 0) {
    var gcv_object_t* ptr = &TheInstance(instance)->other[0];
    dotimespV(length,length, { *ptr++ = unbound; } );
  }
  VALUES1(instance); /* instance as value */
}

/* (CLOS::ALLOCATE-STD-INSTANCE class n) returns a CLOS-instance of length n,
 with Class class and n-1 additional slots. */
LISPFUNN(allocate_std_instance,2) {
  /* check length, should be a fixnum >0 that fits into a uintW: */
  var uintV length;
  test_record_length(length);
  skipSTACK(1);
  { /* Fetch the class-version now, before any possible GC, at which the
       user could redefine the class of which we are creating an instance. */
    var object clas = STACK_0;
    if_defined_class_p(clas, ; , error_class(clas); );
    TheClass(clas)->instantiated = T;
    STACK_0 = TheClass(clas)->current_version;
  }
  var object instance =
    allocate_srecord(0,Rectype_Instance,length,instance_type);
  TheInstance(instance)->inst_class_version = popSTACK();
  /* fill the slots of the instance with #<UNBOUND> : */
  length--;
  if (length > 0) {
    var gcv_object_t* ptr = &TheInstance(instance)->other[0];
    dotimespV(length,length, { *ptr++ = unbound; } );
  }
  VALUES1(instance); /* instance as value */
}

/* (CLOS::ALLOCATE-FUNCALLABLE-INSTANCE class n) returns a funcallable
 CLOS-instance of length n, with Class class and n-3 additional slots. */
LISPFUNN(allocate_funcallable_instance,2) {
  /* check length, should be a fixnum >3 that fits into a uintW: */
  var uintV length;
  test_record_length(length);
  if (!(length>3)) error_record_length();
  skipSTACK(1);
  { /* Fetch the class-version now, before any possible GC, at which the
       user could redefine the class of which we are creating an instance. */
    var object clas = STACK_0;
    if_defined_class_p(clas, ; , error_class(clas); );
    TheClass(clas)->instantiated = T;
    STACK_0 = TheClass(clas)->current_version;
  }
  /* Allocate the closure. seclass is seclass_default (= *seclass-dirty*)
     because even simple generic functions can signal a NO-APPLICABLE-METHOD
     error. */
  var object instance =
    allocate_srecord(closflags_instance_B|(seclass_default<<4),
                     Rectype_Closure,length,closure_type);
  TheCclosure(instance)->clos_name_or_class_version = popSTACK();
  /* Provide a dummy codevector, in case the funcallable instance is called too
     early. */
  TheCclosure(instance)->clos_codevec = O(endless_loop_code);
  TheCclosure(instance)->clos_venv = NIL;
  /* fill the slots of the instance with #<UNBOUND> : */
  length -= 3;
  {
    var gcv_object_t* ptr = &TheCclosure(instance)->clos_consts[1];
    dotimespV(length,length, { *ptr++ = unbound; } );
  }
  VALUES1(instance); /* instance as value */
}

/* Checks that the argcount last words on the STACK form an
   "initialization argument list". */
local inline void check_initialization_argument_list (uintL argcount, object caller) {
  if (argcount%2 != 0)
    error_key_odd(argcount,caller);
  if (argcount > 0) {
    var gcv_object_t* argptr = STACK STACKop argcount;
    do {
      if (!symbolp(Next(argptr))) {
        pushSTACK(Next(argptr)); pushSTACK(caller);
        /* ANSI CL 3.5.1.5. wants a PROGRAM-ERROR here. */
        error(program_error,GETTEXT("~S: invalid initialization argument ~S"));
      }
      argptr skipSTACKop -2;
      argcount -= 2;
    } while (argcount > 0);
  }
}

local Values do_allocate_instance (object clas);
/* (CLOS::%ALLOCATE-INSTANCE class &rest initargs)
  returns an instance of the class.
  class must be an instance of <standard-class> or <structure-class>. */
LISPFUN(pallocate_instance,seclass_read,1,0,rest,nokey,0,NIL) {
  check_initialization_argument_list(argcount,S(allocate_instance));
  /* No need to check the validity of the initargs, because ANSI CL says
   "The caller of allocate-instance is expected to have already checked
    the initialization arguments." */
  set_args_end_pointer(rest_args_pointer); /* clean up STACK */
  return_Values do_allocate_instance(popSTACK());
}
local Values do_allocate_instance (object clas) {
  /* Make a distinction between <semi-standard-class> and <structure-class> for
     allocate-instance: Is (class-current-version class) a vector, or
     is (class-names class) a cons? */
  if (matomp(TheClass(clas)->current_version)) {
    /* <semi-standard-class>. */
    if (!eq(TheClass(clas)->initialized,fixnum(6))) {
      /* Call (CLOS:FINALIZE-INHERITANCE class). */
      pushSTACK(clas); /* save clas */
      pushSTACK(clas); funcall(S(finalize_inheritance),1);
      clas = popSTACK(); /* restore clas */
      /* The class must be finalized now, otherwise FINALIZE-INHERITANCE has
         not done its job. */
      ASSERT(eq(TheClass(clas)->initialized,fixnum(6)));
    }
    /* Make a distinction between <standard-class> and
       <funcallable-standard-class>. */
    pushSTACK(clas); pushSTACK(TheClass(clas)->instance_size);
    if (nullp(TheClass(clas)->funcallablep)) {
      /* <standard-class>. */
      /* (CLOS::ALLOCATE-STD-INSTANCE class (class-instance-size class)) */
      C_allocate_std_instance();
    } else {
      /* <funcallable-standard-class>. */
      /* (CLOS::ALLOCATE-FUNCALLABLE-INSTANCE class (class-instance-size class)) */
      C_allocate_funcallable_instance();
    }
  } else {
    /* <structure-class>. */
    /* (SYS::%MAKE-STRUCTURE (class-names class) (class-instance-size class))*/
    pushSTACK(TheClass(clas)->current_version);
    pushSTACK(TheClass(clas)->instance_size);
    C_make_structure();
    /* fill the slots of the structure with #<UNBOUND> for
       INITIALIZE-INSTANCE to enter the default-values later: */
    var uintL count = Structure_length(value1)-1;
    if (count > 0) {
      var gcv_object_t* ptr = &TheStructure(value1)->recdata[1];
      dotimespL(count,count, { *ptr++ = unbound; } );
    }
  }
}

/* (CLOS:SLOT-VALUE instance slot-name)
   (CLOS::SET-SLOT-VALUE instance slot-name new-value)
   (CLOS:SLOT-BOUNDP instance slot-name)
   (CLOS:SLOT-MAKUNBOUND instance slot-name)
   (CLOS:SLOT-EXISTS-P instance slot-name)
   CLtL2 p. 855,857
 The functions CLOS::%SLOT-...-USING-CLASS are the default methods; they
 access the cell indicated by the slot's location. The functions CLOS:SLOT-...
 are the general wrapper; they dispatch to the SLOT-...-USING-CLASS generic
 function if necessary and - as an optimization - access the cell indicated
 by the slot's location if possible. */

/* Derives the address of an existing slot in an instance of a standard-
 or structure-class from a slot-location-info. */
local inline gcv_object_t* ptr_to_slot (object instance, object slotinfo,
                                        object slotname) {
  instance_un_realloc(instance); /* by this time update_instance() is done */
  if (posfixnump(slotinfo)) /* local slot, slotinfo is index */
    return &TheSrecord(instance)->recdata[posfixnum_to_V(slotinfo)];
  if (consp(slotinfo)) /* shared slot, slotinfo is (class-version . index) */
    return &TheSvector(TheClassVersion(Car(slotinfo))->cv_shared_slots)
      ->data[posfixnum_to_V(Cdr(slotinfo))];
  /* invalid location, probably bad :allocation slot option */
  pushSTACK(instance); pushSTACK(slotname);
  pushSTACK(slotinfo); pushSTACK(TheSubr(subr_self)->name);
  error(error_condition,GETTEXT("~S: Invalid location ~S of slot ~S in ~S (check the :ALLOCATION slot option"));
}

/* UP: visits a slot.
 slot_using_class_up()
 > STACK_2: class
 > STACK_1: instance
 > STACK_0: slot-definition
 < result: pointer to the slot */
local gcv_object_t* slot_using_class_up (void) {
  /* The method applicability already guarantees that
     - the class is a <semi-standard-class>,
     - the slot is a <standard-effective-slot-definition>. */
  var object clas = class_of(STACK_1); /* determine (CLASS-OF instance) */
  if (!eq(clas,STACK_2)) {
    pushSTACK(STACK_1); pushSTACK(STACK_(2+1));
    pushSTACK(TheSubr(subr_self)->name);
    error(error_condition,GETTEXT("~S: invalid arguments: class argument ~S is not the class of ~S"));
  }
  var object slotinfo = TheSlotDefinition(STACK_0)->slotdef_location;
  return ptr_to_slot(STACK_1,slotinfo,STACK_0);
}

/* (CLOS::%SLOT-VALUE-USING-CLASS class instance slot) */
LISPFUNN(pslot_value_using_class,3) {
  var gcv_object_t* slot = slot_using_class_up();
  var object value = *slot;
  if (boundp(value)) {
    value1 = value;
    skipSTACK(3);
  } else {
    /* (SLOT-UNBOUND class instance slot-name) */
    STACK_0 = TheSlotDefinition(STACK_0)->slotdef_name;
    funcall(S(slot_unbound),3);
  }
  mv_count=1;
}

/* (CLOS::%SET-SLOT-VALUE-USING-CLASS new-value class instance slot) */
LISPFUNN(pset_slot_value_using_class,4) {
  var gcv_object_t* slot = slot_using_class_up();
  value1 = *slot = STACK_3;
  mv_count=1;
  skipSTACK(4);
}

/* (CLOS::%SLOT-BOUNDP-USING-CLASS class instance slot) */
LISPFUNN(pslot_boundp_using_class,3) {
  var gcv_object_t* slot = slot_using_class_up();
  VALUES_IF(boundp(*slot));
  skipSTACK(3);
}

/* (CLOS::%SLOT-MAKUNBOUND-USING-CLASS class instance slot) */
LISPFUNN(pslot_makunbound_using_class,3) {
  var gcv_object_t* slot = slot_using_class_up();
  *slot = unbound;
  VALUES1(STACK_1); /* instance as value */
  skipSTACK(3);
}

/* (CLOS:SLOT-VALUE instance slot-name) */
LISPFUNN(slot_value,2) {
  /* stack layout: instance, slot-name. */
  var object clas = class_of(STACK_1); /* determine (CLASS-OF instance) */
  var object slotinfo = /* (GETHASH slot-name (class-slot-location-table class)) */
    gethash(STACK_0,TheClass(clas)->slot_location_table,false);
  if (!eq(slotinfo,nullobj)) { /* found? */
    if (regular_instance_p(slotinfo)) {
      if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_svuc,L(pslot_value_using_class))) {
        /* Call the effective method of CLOS:SLOT-VALUE-USING-CLASS. */
        var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_svuc;
        pushSTACK(clas); pushSTACK(STACK_(1+1)); pushSTACK(slotinfo);
        funcall(efm,3);
        goto done;
      }
      slotinfo = TheSlotDefinition(slotinfo)->slotdef_location;
    }
    var gcv_object_t* slot = ptr_to_slot(STACK_1,slotinfo,STACK_0);
    var object value = *slot;
    if (boundp(value)) {
      value1 = value;
    } else {
      /* (SLOT-UNBOUND class instance slot-name) */
      pushSTACK(clas); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
      funcall(S(slot_unbound),3);
    }
  } else {
    /* missing slot -> (SLOT-MISSING class instance slot-name 'slot-value) */
    pushSTACK(clas); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
    pushSTACK(S(slot_value));
    funcall(S(slot_missing),4);
  }
 done:
  mv_count=1;
  skipSTACK(2);
}

/* (CLOS::SET-SLOT-VALUE instance slot-name new-value) */
LISPFUNN(set_slot_value,3) {
  /* stack layout: instance, slot-name, new-value. */
  var object clas = class_of(STACK_2); /* determine (CLASS-OF instance) */
  var object slotinfo = /* (GETHASH slot-name (class-slot-location-table class)) */
    gethash(STACK_1,TheClass(clas)->slot_location_table,false);
  if (!eq(slotinfo,nullobj)) { /* found? */
    if (regular_instance_p(slotinfo)) {
      if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc,L(pset_slot_value_using_class))) {
        /* Call the effective method of (SETF CLOS:SLOT-VALUE-USING-CLASS). */
        var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc;
        pushSTACK(STACK_0); pushSTACK(clas); pushSTACK(STACK_(2+2));
        pushSTACK(slotinfo);
        funcall(efm,4);
        /* It must return the new-value. But anyway, just for safety
         (don't trust user-defined methods): */
        value1 = STACK_0;
        goto done;
      }
      slotinfo = TheSlotDefinition(slotinfo)->slotdef_location;
    }
    value1 = *ptr_to_slot(STACK_2,slotinfo,STACK_1) = STACK_0;
  } else {
    /* missing slot
       -> (SLOT-MISSING class instance slot-name 'setf new-value) */
    pushSTACK(clas); pushSTACK(STACK_(2+1)); pushSTACK(STACK_(1+2));
    pushSTACK(S(setf)); pushSTACK(STACK_(0+4));
    funcall(S(slot_missing),5);
    value1 = STACK_0;
  }
 done:
  mv_count=1;
  skipSTACK(3);
}

/* (CLOS:SLOT-BOUNDP instance slot-name) */
LISPFUNN(slot_boundp,2) {
  /* stack layout: instance, slot-name. */
  var object clas = class_of(STACK_1); /* determine (CLASS-OF instance) */
  var object slotinfo = /* (GETHASH slot-name (class-slot-location-table class)) */
    gethash(STACK_0,TheClass(clas)->slot_location_table,false);
  if (!eq(sloti…