# Funktionen für Records und Structures von CLISP
# Bruno Haible 13.11.1994

#include "lispbibl.c"


# ==============================================================================
# Records allgemein:

# (SYS::%RECORD-REF record index) liefert den Eintrag index in einem record.
# (SYS::%RECORD-STORE record index value) speichert value als Eintrag index
#   in record ab und liefert value.
# (SYS::%RECORD-LENGTH record) liefert die Länge eines record.

# Fehlermeldung
# > STACK_1: Record
# > STACK_0: (fehlerhafter) Index
# > subr_self: Aufrufer (ein SUBR)
  nonreturning_function(local, fehler_index, (void));
  local void fehler_index()
    { pushSTACK(TheSubr(subr_self)->name); # Funktionsname
      fehler(error,
             DEUTSCH ? "~: ~ ist kein erlaubter Index für ~." :
             ENGLISH ? "~: ~ is not a valid index into ~" :
             FRANCAIS ? "~ : ~ n'est pas un index valide pour ~." :
             ""
            );
    }

# Fehlermeldung
# > STACK_0: (fehlerhafter) Record
# > subr_self: Aufrufer (ein SUBR)
  nonreturning_function(local, fehler_record, (void));
  local void fehler_record()
    { pushSTACK(TheSubr(subr_self)->name); # Funktionsname
      fehler(error, # type_error ??
             DEUTSCH ? "~: ~ ist kein Record." :
             ENGLISH ? "~: ~ is not a record" :
             FRANCAIS ? "~ : ~ n'est pas un «record»." :
             ""
            );
    }

# Überprüfung eines Index auf Typ `(INTEGER 0 (,ARRAY-SIZE-LIMIT))
# > STACK_0: Index
# > STACK_1: Record o.ä. (für Fehlermeldung)
# > subr_self: Aufrufer (ein SUBR)
# < ergebnis: Index
  local uintL test_index (void);
  local uintL test_index()
    { if (!mposfixnump(STACK_0)) { fehler_index(); }
      return posfixnum_to_L(STACK_0);
    }

# Unterprogramm für Record-Zugriffsfunktionen:
# > STACK_1: record-Argument
# > STACK_0: index-Argument
# > subr_self: Aufrufer (ein SUBR)
# < STACK: aufgeräumt
# < ergebnis: Adresse des angesprochenen Record-Elements
  local object* record_up (void);
  local object* record_up ()
    { # record muß vom Typ Closure/Structure/Stream/OtherRecord sein:
      if_mrecordp(STACK_1, ; , { skipSTACK(1); fehler_record(); } );
     {var reg2 uintL index = test_index(); # Index holen
      var reg1 object record = STACK_1;
      if (!(index < (uintL)(TheRecord(record)->reclength))) { fehler_index(); } # und prüfen
      skipSTACK(2); # Stack aufräumen
      return &TheRecord(record)->recdata[index]; # Record-Element adressieren
    }}

LISPFUNN(record_ref,2)
# (SYS::%RECORD-REF record index) liefert den Eintrag index in einem record.
  { value1 = *(record_up()); mv_count=1; } # Record-Element als Wert

LISPFUNN(record_store,3)
# (SYS::%RECORD-STORE record index value) speichert value als Eintrag index
#   in record ab und liefert value.
  { var reg3 object value = popSTACK();
    value1 = *(record_up()) = value; mv_count=1; # Record-Element eintragen
  }

LISPFUNN(record_length,1)
# (SYS::%RECORD-LENGTH record) liefert die Länge eines record.
  { # record muß vom Typ Closure/Structure/Stream/OtherRecord sein:
    if_mrecordp(STACK_0, ; , { fehler_record(); } );
   {var reg1 object record = popSTACK();
    value1 = fixnum((uintL)(TheRecord(record)->reclength)); # Länge als Fixnum
    mv_count=1;
  }}

# ==============================================================================
# Structures:

# (SYS::%STRUCTURE-REF type structure index) liefert zu einer Structure vom
#   gegebenen Typ type (ein Symbol) den Eintrag index>=1.
# (SYS::%STRUCTURE-STORE type structure index object) speichert object als
#   Eintrag index in einer Structure vom gegebenen Typ type und liefert object.
# (SYS::%MAKE-STRUCTURE type length) erzeugt eine Structure mit length>=1
#   Elementen, vom Typ type.
# (SYS::%COPY-STRUCTURE structure) liefert eine Kopie der Structure structure,
#   vom selben Typ.
# (SYS::%STRUCTURE-TYPE-P type object) überprüft, ob object eine
#   Structure ist, die vom Typ type ist, was daran erkennbar ist, daß in
#   der Komponente 0 ein Objekt (name_1 ... name_i-1 name_i) steht, wobei
#   einer der Namen EQ zu type ist.

# Unterprogramm für Structure-Zugriffsfunktionen:
# > STACK_2: type-Argument
# > STACK_1: structure-Argument
# > STACK_0: index-Argument
# > subr_self: Aufrufer (ein SUBR)
# < ergebnis: Adresse des angesprochenen Structure-Elements
  local object* structure_up (void);
  local object* structure_up ()
    { # structure muß vom Typ Structure sein:
      if (!mstructurep(STACK_1))
        { fehler_bad_structure: # STACK_2 = type, STACK_1 = structure
          pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
          pushSTACK(STACK_(2+1)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
          pushSTACK(STACK_(2+2));
          pushSTACK(STACK_(1+3));
          pushSTACK(TheSubr(subr_self)->name); # Funktionsname
          fehler(type_error,
                 DEUTSCH ? "~: ~ ist keine Structure vom Typ ~." :
                 ENGLISH ? "~: ~ is not a structure of type ~" :
                 FRANCAIS ? "~ : ~ n'est pas une structure de type ~." :
                 ""
                );
        }
     {var reg4 uintL index = test_index(); # Index holen
      var reg3 object structure = STACK_1;
      var reg1 object namelist = TheStructure(structure)->structure_types; # erste Komponente
      var reg2 object type = STACK_2; # type-Argument
      # Teste, ob in namelist = (name_1 ... name_i-1 name_i) type vorkommt:
      while (consp(namelist))
        { if (eq(Car(namelist),type)) goto yes;
          namelist = Cdr(namelist);
        }
      # type kam nicht vor -> Error:
      goto fehler_bad_structure;
      # type kam vor:
      yes:
      if (!(index < (uintL)(TheStructure(structure)->reclength))) { fehler_index(); } # und prüfen
      return &TheStructure(structure)->recdata[index]; # Structure-Komponente adressieren
    }}

LISPFUNN(structure_ref,3)
# (SYS::%STRUCTURE-REF type structure index) liefert zu einer Structure vom
#   gegebenen Typ type (ein Symbol) den Eintrag index>=1.
  { value1 = *(structure_up()); # Structure-Element als Wert
    if (eq(value1,unbound)) # Könnte = #<UNBOUND> sein, nach Gebrauch von SLOT-MAKUNBOUND
      { pushSTACK(STACK_1);
        pushSTACK(S(structure_ref));
        fehler(error,
               DEUTSCH ? "~: Ein Slot von ~ hat keinen Wert." :
               ENGLISH ? "~: A slot of ~ has no value" :
               FRANCAIS ? "~ : Un composant de ~ n'a pas de valeur." :
               ""
              );
      }
    mv_count=1;
    skipSTACK(3); # Stack aufräumen
  }

LISPFUNN(structure_store,4)
# (SYS::%STRUCTURE-STORE type structure index object) speichert object als
#   Eintrag index in einer Structure vom gegebenen Typ type und liefert object.
  { var reg3 object value = popSTACK();
    value1 = *(structure_up()) = value; mv_count=1; # Structure-Element eintragen
    skipSTACK(3); # Stack aufräumen
  }

LISPFUNN(make_structure,2)
# (SYS::%MAKE-STRUCTURE type length) erzeugt eine Structure mit length>=1
#   Elementen, vom Typ type.
  { # Länge überprüfen, sollte ein Fixnum /=0 sein, das in ein uintW paßt:
    var reg1 uintL length;
    if (!(mposfixnump(STACK_0)
          && ((length = posfixnum_to_L(STACK_0)) <= (uintL)(bitm(intWsize)-1))
          && (length>0)
       ) )
      { # STACK_0 = length, Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(O(type_posint16)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(STACK_1); # length
        pushSTACK(TheSubr(subr_self)->name); # Funktionsname
        fehler(type_error,
               DEUTSCH ? "~: ~ ist nicht als Länge zugelassen, da nicht vom Typ (INTEGER (0) (65536))." :
               ENGLISH ? "~: length ~ is illegal, should be of type (INTEGER (0) (65536))" :
               FRANCAIS ? "~ : ~ n'est pas permis comme longueur parce qu'il faut le type (INTEGER (0) (65536))." :
               ""
              );
      }
    skipSTACK(1);
   {var reg2 object structure = allocate_structure(length);
    # neue Structure, mit NILs gefüllt
    TheStructure(structure)->structure_types = popSTACK(); # Typ-Komponente eintragen
    value1 = structure; mv_count=1; # structure als Wert
  }}

LISPFUNN(copy_structure,1)
# (SYS::%COPY-STRUCTURE structure) liefert eine Kopie der Structure structure,
#   vom selben Typ.
  { if (!(mstructurep(STACK_0)))
      { # STACK_0 = Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(S(structure)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(STACK_1); # structure
        pushSTACK(TheSubr(subr_self)->name); # Funktionsname
        fehler(type_error,
               DEUTSCH ? "~: ~ ist keine Structure." :
               ENGLISH ? "~: ~ is not a structure" :
               FRANCAIS ? "~ : ~ n'est pas une structure." :
               ""
              );
      }
   {var reg3 uintC length = TheStructure(STACK_0)->reclength;
    var reg4 object new_structure = allocate_structure(length); # neue Structure
    # und füllen:
    {var reg1 object* old_ptr = &TheStructure(popSTACK())->structure_types;
     var reg2 object* new_ptr = &TheStructure(new_structure)->structure_types;
     dotimespC(length,length, { *new_ptr++ = *old_ptr++; });
    }
    # und als Wert zurück:
    value1 = new_structure; mv_count=1;
  }}

LISPFUNN(structure_type_p,2)
# (SYS::%STRUCTURE-TYPE-P type object) überprüft, ob object eine
#   Structure ist, die vom Typ type ist, was daran erkennbar ist, daß in
#   der Komponente 0 ein Objekt (name_1 ... name_i-1 name_i) steht, wobei
#   einer der Namen EQ zu type ist.
  { # object auf Structure testen:
    if (!(mstructurep(STACK_0))) { skipSTACK(2); goto no; }
    { var reg1 object namelist = TheStructure(popSTACK())->structure_types;
      var reg2 object type = popSTACK();
      # Teste, ob in namelist = (name_1 ... name_i-1 name_i) type vorkommt:
      while (consp(namelist))
        { if (eq(Car(namelist),type)) goto yes;
          namelist = Cdr(namelist);
    }   }
    # type kam nicht vor:
    no: value1 = NIL; mv_count=1; return; # 1 Wert NIL
    # type kam vor:
    yes: value1 = T; mv_count=1; return; # 1 Wert T
  }

# ==============================================================================
# Closures:

# (SYS::CLOSURE-NAME closure) liefert den Namen einer Closure.
# (SYS::CLOSURE-CODEVEC closure) liefert den Code-Vektor einer compilierten
#   Closure, als Liste von Fixnums >=0, <256.
# (SYS::CLOSURE-CONSTS closure) liefert eine Liste aller Konstanten einer
#   compilierten Closure.
# (SYS::MAKE-CODE-VECTOR list) liefert zu einer Liste von Fixnums >=0, <256
#   einen Simple-Bit-Vector der 8-fachen Länge, der diese Zahlen als Bytes
#   enthält.
# (SYS::%MAKE-CLOSURE name codevec consts) liefert eine Closure mit gegebenem
#   Namen (einem Symbol), gegebenem Code-Vektor (einem Simple-Bit-Vector) und
#   gegebenen weiteren Konstanten.

LISPFUNN(closure_name,1)
# (SYS::CLOSURE-NAME closure) liefert den Namen einer Closure.
  { var reg1 object closure = popSTACK();
    if (!(closurep(closure)))
      { pushSTACK(closure);
        pushSTACK(TheSubr(subr_self)->name); # Funktionsname
        fehler(error, # type_error ??
               DEUTSCH ? "~: ~ ist keine Closure." :
               ENGLISH ? "~: ~ is not a closure" :
               FRANCAIS ? "~ : ~ n'est pas une fermeture." :
               ""
              );
      }
    value1 = TheClosure(closure)->clos_name; mv_count=1;
  }

# Fehler, wenn Argument keine compilierte Closure
  nonreturning_function(local, fehler_cclosure, (object obj));
  local void fehler_cclosure(obj)
    var reg1 object obj;
    { pushSTACK(obj);
      pushSTACK(TheSubr(subr_self)->name); # Funktionsname
      fehler(error, # type_error ??
             DEUTSCH ? "~: Das ist keine compilierte Closure: ~" :
             ENGLISH ? "~: This is not a compiled closure: ~" :
             FRANCAIS ? "~ : Ceci n'est pas un fermeture compilée : ~" :
             ""
            );
    }

LISPFUNN(closure_codevec,1)
# (SYS::CLOSURE-CODEVEC closure) liefert den Code-Vektor einer compilierten
#   Closure, als Liste von Fixnums >=0, <256.
  { var reg3 object closure = popSTACK();
    if (!(cclosurep(closure))) fehler_cclosure(closure);
   {var reg2 object codevec = TheCclosure(closure)->clos_codevec;
    var reg1 uintL index = (TheSbvector(codevec)->length)/8; # index := Länge in Bytes
    # Codevektor codevec von hinten durchgehen und Bytes auf eine Liste pushen:
    pushSTACK(codevec); # Codevektor
    pushSTACK(NIL); # Liste := ()
    until (index==0)
      { index--; # Index decrementieren
        # neues Cons vor die Liste setzen:
       {var reg1 object new_cons = allocate_cons();
        Cdr(new_cons) = popSTACK();
        Car(new_cons) = fixnum((uintL)(TheSbvector(STACK_0)->data[index])); # Byte herausholen
        pushSTACK(new_cons);
      }}
    value1 = STACK_0; mv_count=1; skipSTACK(2); # Liste als Wert
  }}

LISPFUNN(closure_consts,1)
# (SYS::CLOSURE-CONSTS closure) liefert eine Liste aller Konstanten einer
#   compilierten Closure.
  { var reg2 object closure = popSTACK();
    if (!(cclosurep(closure))) fehler_cclosure(closure);
    # Elemente 2,3,... zu einer Liste zusammenfassen:
   {var reg1 uintC index = (TheCclosure(closure)->reclength)-2; # index := Länge
    # Closure von hinten durchgehen und Konstanten auf eine Liste pushen:
    pushSTACK(closure); # Closure
    pushSTACK(NIL); # Liste := ()
    until (index==0)
      { index--; # Index decrementieren
        # neues Cons vor die Liste setzen:
       {var reg1 object new_cons = allocate_cons();
        Cdr(new_cons) = popSTACK();
        Car(new_cons) = TheCclosure(STACK_0)->clos_consts[(uintP)index]; # Konstante herausholen
        pushSTACK(new_cons);
      }}
    value1 = STACK_0; mv_count=1; skipSTACK(2); # Liste als Wert
  }}

LISPFUNN(make_code_vector,1)
# (SYS::MAKE-CODE-VECTOR list) liefert zu einer Liste von Fixnums >=0, <256
#   einen Simple-Bit-Vector der 8-fachen Länge, der diese Zahlen als Bytes
#   enthält.
  { var reg4 object bv = allocate_bit_vector(8*llength(STACK_0)); # Simple-Bit-Vektor
    # füllen:
    var reg1 object listr = popSTACK(); # Liste
    var reg3 uintB* ptr = &TheSbvector(bv)->data[0]; # läuft durch den Bit-Vektor
    while (consp(listr))
      { var reg2 uintL byte;
        # Listenelement muß ein Fixnum >=0, <256 sein:
        if (!(mposfixnump(Car(listr))
              && ((byte = posfixnum_to_L(Car(listr))) < (1<<intBsize))
           ) )
          goto bad_byte;
        # in den Bit-Vektor stecken:
        *ptr++ = (uintB)byte;
        listr = Cdr(listr);
      }
    value1 = bv; mv_count=1; return; # bv als Wert
    bad_byte:
      pushSTACK(Car(listr)); # Wert für Slot DATUM von TYPE-ERROR
      pushSTACK(O(type_uint8)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
      pushSTACK(STACK_1);
      fehler(type_error,
             DEUTSCH ? "~ ist als Byte in einem Code-Vektor ungeeignet." :
             ENGLISH ? "~ is not a valid code-vector byte" :
             FRANCAIS ? "~ est inutilisable comme octet dans un «code-vector»." :
             ""
            );
  }

LISPFUNN(make_closure,3)
# (SYS::%MAKE-CLOSURE name codevec consts) liefert eine Closure mit gegebenem
#   Namen (einem Symbol), gegebenem Code-Vektor (einem Simple-Bit-Vector) und
#   gegebenen weiteren Konstanten.
  { # codevec muß ein Simple-Bit-Vector sein:
    if (!(m_simple_bit_vector_p(STACK_1)))
      { # STACK_1 = codevec
        pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(S(simple_bit_vector)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(STACK_(1+2));
        pushSTACK(TheSubr(subr_self)->name);
        fehler(type_error,
               DEUTSCH ? "~: Als Code-Vektor einer Funktion ist ~ ungeeignet." :
               ENGLISH ? "~: invalid code-vector ~" :
               FRANCAIS ? "~ : ~ n'est pas utilisable comme «code-vector» d'une fonction." :
               ""
              );
      }
   {# neue Closure der Länge (+ 2 (length consts)) erzeugen:
    var reg4 uintL length = 2+llength(STACK_0);
    if (!(length <= (uintL)(bitm(intWsize)-1))) # sollte in ein uintW passen
      { # STACK_0 = consts
        pushSTACK(STACK_2); # name
        pushSTACK(TheSubr(subr_self)->name);
        fehler(error,
               DEUTSCH ? "~: Funktion ~ ist zu groß: ~" :
               ENGLISH ? "~: function ~ is too big: ~" :
               FRANCAIS ? "~ : La function ~ est trop grosse: ~" :
               ""
              );
      }
    {var reg3 object closure = allocate_record(0,0,length,closure_type);
     TheCclosure(closure)->clos_name = STACK_2; # Namen einfüllen
     TheCclosure(closure)->clos_codevec = STACK_1; # Codevektor einfüllen
     # Konstanten einfüllen:
     {var reg1 object constsr = popSTACK();
      var reg2 object* ptr = &TheCclosure(closure)->clos_consts[0];
      while (consp(constsr))
        { *ptr++ = Car(constsr); constsr = Cdr(constsr); }
     }
     value1 = closure; mv_count=1; skipSTACK(2);
  }}}

# ==============================================================================
# Load-Time-Eval:

# (SYS::MAKE-LOAD-TIME-EVAL form) liefert ein Load-Time-Eval-Objekt, das
#   - wenn ausgegeben und wieder eingelesen - form auswertet.

LISPFUNN(make_load_time_eval,1)
# (SYS::MAKE-LOAD-TIME-EVAL form) liefert ein Load-Time-Eval-Objekt, das
#   - wenn ausgegeben und wieder eingelesen - form auswertet.
  { var reg1 object lte = allocate_loadtimeeval();
    TheLoadtimeeval(lte)->loadtimeeval_form = popSTACK();
    value1 = lte; mv_count=1;
  }

# ==============================================================================
# Symbol-Macro:

# (SYS::MAKE-SYMBOL-MACRO expansion) liefert ein Symbol-Macro-Objekt,
#   das die gegebene Expansion repräsentiert.
# (SYS::SYMBOL-MACRO-P object) testet auf Symbol-Macro.

LISPFUNN(make_symbol_macro,1)
# (SYS::MAKE-SYMBOL-MACRO expansion) liefert ein Symbol-Macro-Objekt,
#   das die gegebene Expansion repräsentiert.
  { var reg1 object sm = allocate_symbolmacro();
    TheSymbolmacro(sm)->symbolmacro_expansion = popSTACK();
    value1 = sm; mv_count=1;
  }

LISPFUNN(symbol_macro_p,1)
# (SYS::SYMBOL-MACRO-P object) testet auf Symbol-Macro.
  { var reg1 object obj = popSTACK();
    value1 = (symbolmacrop(obj) ? T : NIL); mv_count=1;
  }

# ==============================================================================
# CLOS-Objekte:

LISPFUNN(std_instance_p,1)
# (CLOS::STD-INSTANCE-P object) testet, ob ein Objekt ein CLOS-Objekt ist.
  { var reg1 object obj = popSTACK();
    value1 = (instancep(obj) ? T : NIL); mv_count=1;
  }

LISPFUNN(allocate_std_instance,2)
# (CLOS::ALLOCATE-STD-INSTANCE class n) liefert eine CLOS-Instanz der Länge n,
# mit Klasse class und n-1 zusätzlichen Slots.
  { # Länge überprüfen, sollte ein Fixnum >=0 sein, das in ein uintW paßt:
    var reg2 uintL length;
    if (!(mposfixnump(STACK_0)
          && ((length = posfixnum_to_L(STACK_0)) <= (uintL)(bitm(intWsize)-1))
       ) )
      { # STACK_0 = n, Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(O(type_uint16)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(STACK_1); # n
        pushSTACK(TheSubr(subr_self)->name); # Funktionsname
        fehler(type_error,
               DEUTSCH ? "~: ~ ist nicht als Länge zugelassen, da nicht vom Typ (INTEGER 0 (65536))." :
               ENGLISH ? "~: length ~ is illegal, should be of type (INTEGER 0 (65536))" :
               FRANCAIS ? "~ : ~ n'est pas permis comme longueur parce qu'il faut le type (INTEGER 0 (65536))." :
               ""
              );
      }
    skipSTACK(1);
   {var reg3 object instance = allocate_record(0,0,length,instance_type);
    var reg4 object class = popSTACK();
    if (!classp(class))
      { pushSTACK(class); # Wert für Slot DATUM von TYPE-ERROR
        pushSTACK(S(closclass)); # CLOS::CLASS, Wert für Slot EXPECTED-TYPE von TYPE-ERROR
        pushSTACK(class);
        pushSTACK(TheSubr(subr_self)->name); # Funktionsname
        fehler(type_error,
               DEUTSCH ? "~: ~ ist keine Klasse." :
               ENGLISH ? "~: ~ is not a class" :
               FRANCAIS ? "~ : ~ n'est pas une classe." :
               ""
              );
      }
    TheInstance(instance)->class = class;
    # Slots der Instanz mit #<UNBOUND> füllen:
    {var reg1 object* ptr = &TheInstance(instance)->other[0];
     dotimesL(length,length-1, { *ptr++ = unbound; } );
    }
    value1 = instance; mv_count=1; # instance als Wert
  }}

# (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-EXISIS-P instance slot-name)
# CLtL2 S. 855,857

# Liefert aus einer Slot-Location-Info die Adresse eines existierenden Slots
# in einer Instanz einer Standard- oder Structure-Klasse.
  #define ptr_to_slot(instance,slotinfo)  \
    (atomp(slotinfo)                                           \
     # local slot, slotinfo ist Index                          \
     ? &TheRecord(instance)->recdata[posfixnum_to_L(slotinfo)] \
     # shared slot, slotinfo ist (class . index)               \
     : &TheSvector(TheClass(Car(slotinfo))->shared_slots)      \
                  ->data[posfixnum_to_L(Cdr(slotinfo))]        \
    )

# UP: Sucht einen Slot auf.
# slot_up()
# > STACK_1: instance
# > STACK_0: slot-name
# < ergebnis: Pointer auf den Slot (dann ist value1 = (class-of instance)),
#             oder NULL (dann wurde SLOT-MISSING aufgerufen).
  local object* slot_up (void);
  #ifdef RISCOS_CCBUG
    #pragma -z0
  #endif
  local object* slot_up()
    { pushSTACK(STACK_1); C_class_of(); # (CLASS-OF instance) bestimmen
     {var reg1 object slotinfo = # (GETHASH slot-name (class-slot-location-table class))
        gethash(STACK_0,TheClass(value1)->slot_location_table);
      if (!eq(slotinfo,nullobj)) # gefunden?
        { return ptr_to_slot(STACK_1,slotinfo); }
        else
        # missing slot -> (SLOT-MISSING class instance slot-name caller)
        { pushSTACK(value1); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
          pushSTACK(TheSubr(subr_self)->name);
          funcall(S(slot_missing),4);
          return NULL;
        }
    }}
  #ifdef RISCOS_CCBUG
    #pragma -z1
  #endif

LISPFUNN(slot_value,2)
{ var reg2 object* slot = slot_up();
  if (slot)
    { var reg1 object value = *slot;
      if (!eq(value,unbound))
        { value1 = value; mv_count=1; }
        else
        # (SLOT-UNBOUND class instance slot-name)
        { pushSTACK(value1); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
          funcall(S(slot_unbound),3);
    }   }
  skipSTACK(2);
}

#ifdef RISCOS_CCBUG
  #pragma -z0
#endif
LISPFUNN(set_slot_value,3)
{ # Stackaufbau: instance, slot-name, new-value.
  pushSTACK(STACK_2); C_class_of(); # (CLASS-OF instance) bestimmen
 {var reg1 object slotinfo = # (GETHASH slot-name (class-slot-location-table class))
    gethash(STACK_1,TheClass(value1)->slot_location_table);
  if (!eq(slotinfo,nullobj)) # gefunden?
    { value1 = *ptr_to_slot(STACK_2,slotinfo) = STACK_0; mv_count=1; }
    else
    # missing slot -> (SLOT-MISSING class instance slot-name 'setf new-value)
    { pushSTACK(value1); pushSTACK(STACK_(2+1)); pushSTACK(STACK_(1+2));
      pushSTACK(S(setf)); pushSTACK(STACK_(0+4));
      funcall(S(slot_missing),5);
    }
  skipSTACK(3);
}}
#ifdef RISCOS_CCBUG
  #pragma -z1
#endif

LISPFUNN(slot_boundp,2)
{ var reg2 object* slot = slot_up();
  if (slot)
    { value1 = (eq(*slot,unbound) ? NIL : T); mv_count=1; }
  skipSTACK(2);
}

LISPFUNN(slot_makunbound,2)
{ var reg2 object* slot = slot_up();
  if (slot)
    { *slot = unbound;
      value1 = STACK_1; mv_count=1; # instance als Wert
    }
  skipSTACK(2);
}

#ifdef RISCOS_CCBUG
  #pragma -z0
#endif
LISPFUNN(slot_exists_p,2)
{ pushSTACK(STACK_1); C_class_of(); # (CLASS-OF instance) bestimmen
 {var reg1 object slotinfo = # (GETHASH slot-name (class-slot-location-table class))
    gethash(STACK_0,TheClass(value1)->slot_location_table);
  value1 = (eq(slotinfo,nullobj) ? NIL : T); mv_count=1; skipSTACK(2);
}}
#ifdef RISCOS_CCBUG
  #pragma -z1
#endif

# UP: Keywords überprüfen, vgl. SYSTEM::KEYWORD-TEST
# keyword_test(caller,rest_args_pointer,argcount,valid_keywords);
# > caller: Aufrufer (ein Symbol)
# > rest_args_pointer: Pointer über die Argumente
# > argcount: Anzahl der Argumente / 2
# > valid_keywords: Liste der gültigen Keywords
  local void keyword_test (object caller, object* rest_args_pointer, uintC argcount, object valid_keywords);
  local void keyword_test(caller,rest_args_pointer,argcount,valid_keywords)
    var reg8 object caller;
    var reg7 object* rest_args_pointer;
    var reg6 uintC argcount;
    var reg5 object valid_keywords;
    { if (argcount==0) return;
      # Suche, ob :ALLOW-OTHER-KEYS kommt:
      { var reg1 object* ptr = rest_args_pointer;
        var reg2 uintC count;
        dotimespC(count,argcount,
          { if (eq(NEXT(ptr),S(Kallow_other_keys)))
              if (!nullp(Next(ptr)))
                return;
            NEXT(ptr);
          });
      }
      # Suche, ob alle angegebenen Keywords in valid_keywords vorkommen:
      { var reg3 object* ptr = rest_args_pointer;
        var reg4 uintC count;
        dotimespC(count,argcount,
          { var reg2 object key = NEXT(ptr);
            var reg1 object kwlistr = valid_keywords;
            while (consp(kwlistr))
              { if (eq(Car(kwlistr),key)) goto kw_found;
                kwlistr = Cdr(kwlistr);
              }
            # nicht gefunden
            pushSTACK(valid_keywords);
            pushSTACK(Next(ptr));
            pushSTACK(key);
            pushSTACK(caller);
            fehler(error,
                   DEUTSCH ? "~: Unzulässiges Keyword/Wert-Paar ~, ~ in der Argumentliste." NLstring "Die erlaubten Keywords sind ~" :
                   ENGLISH ? "~: illegal keyword/value pair ~, ~ in argument list." NLstring "The allowed keywords are ~" :
                   FRANCAIS ? "~ : Paire mot-clé - valeur ~, ~ illicite dans la liste d'arguments." NLstring "Les mots-clé permis sont ~" :
                   ""
                  );
            kw_found: # gefunden. Weiter:
            NEXT(ptr);
          });
    } }

LISPFUN(shared_initialize,2,0,rest,nokey,0,NIL)
# (CLOS::%SHARED-INITIALIZE instance slot-names &rest initargs)
# instance ist eine Instanz von <standard-object>, initargs eine paarige Liste.
# Das ist die primäre Methode von CLOS:SHARED-INITIALIZE.
# vgl. clos.lsp
# (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs &key &allow-other-keys)
#   (dolist (slot (class-slots (class-of instance)))
#     (let ((slotname (slotdef-name slot)))
#       (multiple-value-bind (init-key init-value foundp)
#           (get-properties initargs (slotdef-initargs slot))
#         (declare (ignore init-key))
#         (if foundp
#           (setf (slot-value instance slotname) init-value)
#           (unless (slot-boundp instance slotname)
#             (let ((init (slotdef-initer slot)))
#               (when init
#                 (when (or (eq slot-names 'T) (member slotname slot-names :test #'eq))
#                   (setf (slot-value instance slotname)
#                         (if (car init) (funcall (car init)) (cdr init))
#   ) ) ) ) ) ) ) ) )
#   instance
# )
{ if (!((argcount%2) == 0))
    { var reg1 object arglist = listof(argcount);
      pushSTACK(arglist);
      fehler(error,
             DEUTSCH ? "SHARED-INITIALIZE: Keyword-Argumentliste ~ hat ungerade Länge." :
             ENGLISH ? "SHARED-INITIALIZE: keyword argument list ~ has an odd length" :
             FRANCAIS ? "SHARED-INITIALIZE : La liste de mots clé ~ est de longueur impaire." :
             ""
            );
    }
  argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
  # Stackaufbau: instance, slot-names, argcount Initarg/Wert-Paare.
  { var reg9 object instance = Before(rest_args_pointer STACKop 1);
    var reg8 object class = TheInstance(instance)->class; # Instanz der <standard-class>
    var reg7 object slots = TheClass(class)->slots; # Liste aller Slots (als Slot-Definitionen)
    while (consp(slots))
      { var reg6 object slot = Car(slots);
        slots = Cdr(slots);
        # Suche ob der Slot durch die Initargs initialisiert wird:
        { var reg5 object l = TheSvector(slot)->data[2]; # (slotdef-initargs slot)
          var reg3 object* ptr = rest_args_pointer;
          var reg4 uintC count;
          dotimesC(count,argcount,
            { var reg2 object initarg = NEXT(ptr);
              # Suche initarg in l
              var reg1 object lr = l;
              while (consp(lr))
                { if (eq(initarg,Car(lr))) goto initarg_found;
                  lr = Cdr(lr);
                }
              NEXT(ptr);
            });
          goto initarg_not_found;
          initarg_found:
          value1 = NEXT(ptr);
          goto fill_slot;
        }
        initarg_not_found:
        # Nicht gefunden -> erst auf (slot-boundp instance slotname) testen:
        { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
          if (!eq(*ptr_to_slot(Before(rest_args_pointer STACKop 1),slotinfo),unbound))
            goto slot_done;
        }
        # Slot hat noch keinen Wert. Evtl. die Initform auswerten:
        { var reg3 object init = TheSvector(slot)->data[4]; # (slotdef-initer slot)
          if (atomp(init)) goto slot_done;
          # Slot in slot-names suchen:
          { var reg1 object slotnames = Before(rest_args_pointer);
            if (eq(slotnames,T)) goto eval_init;
           {var reg2 object slotname = TheSvector(slot)->data[0]; # (slotdef-name slot)
            while (consp(slotnames))
              { if (eq(Car(slotnames),slotname)) goto eval_init;
                slotnames = Cdr(slotnames);
              }
            goto slot_done;
          }}
          eval_init:
          # Die Initform auswerten:
          if (!nullp(Car(init)))
            { pushSTACK(slots); pushSTACK(slot);
              funcall(Car(init),0);
              slot = popSTACK(); slots = popSTACK();
            }
            else
            { value1 = Cdr(init); }
        }
        fill_slot:
        # Slot mit value1 initialisieren:
        { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
          *ptr_to_slot(Before(rest_args_pointer STACKop 1),slotinfo) = value1;
        }
        slot_done: ;
  }   }
  value1 = Before(rest_args_pointer STACKop 1); mv_count=1; # Instanz als Wert
  set_args_end_pointer(rest_args_pointer STACKop 2); # STACK aufräumen
}

LISPFUN(reinitialize_instance,1,0,rest,nokey,0,NIL)
# (CLOS::%REINITIALIZE-INSTANCE instance &rest initargs)
# instance ist eine Instanz von <standard-object>, initargs eine paarige Liste.
# Das ist die primäre Methode von CLOS:REINITIALIZE-INSTANCE.
# vgl. clos.lsp
# (defmethod reinitialize-instance ((instance standard-object) &rest initargs &key &allow-other-keys)
#   (let ((h (gethash (class-of instance) *reinitialize-instance-table*)))
#     (if h
#       (progn
#         ; 28.1.9.2. validity of initialization arguments
#         (let ((valid-keywords (car h)))
#           (sys::keyword-test initargs valid-keywords)
#         )
#         (if (not (eq (cdr h) #'clos::%shared-initialize))
#           ; effektive Methode von shared-initialize anwenden:
#           (apply (cdr h) instance 'NIL initargs)
#           ; clos::%shared-initialize mit slot-names=NIL läßt sich vereinfachen:
#           (progn
#             (dolist (slot (class-slots (class-of instance)))
#               (let ((slotname (slotdef-name slot)))
#                 (multiple-value-bind (init-key init-value foundp)
#                     (get-properties initargs (slotdef-initargs slot))
#                   (declare (ignore init-key))
#                   (if foundp
#                     (setf (slot-value instance slotname) init-value)
#             ) ) ) )
#             instance
#       ) ) )
#       (apply #'initial-reinitialize-instance instance initargs)
# ) ) )
{ var reg9 object instance = Before(rest_args_pointer);
  var reg8 object class = TheInstance(instance)->class; # Instanz der <standard-class>
  # (GETHASH class *REINITIALIZE-INSTANCE-TABLE*) suchen:
  { var reg5 object info = gethash(class,Symbol_value(S(reinitialize_instance_table)));
    if (eq(info,nullobj))
      # Hash-Tabellen-Eintrag neu berechnen. Siehe clos.lsp.
      { funcall(S(initial_reinitialize_instance),argcount+1); return; }
    # Keywords überprüfen:
    if (!((argcount%2) == 0))
      { var reg1 object arglist = listof(argcount);
        pushSTACK(arglist);
        fehler(error,
               DEUTSCH ? "REINITIALIZE-INSTANCE: Keyword-Argumentliste ~ hat ungerade Länge." :
               ENGLISH ? "REINITIALIZE-INSTANCE: keyword argument list ~ has an odd length" :
               FRANCAIS ? "REINITIALIZE-INSTANCE : La liste de mots clé ~ est de longueur impaire." :
               ""
              );
      }
    argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
    keyword_test(S(reinitialize_instance),rest_args_pointer,argcount,Car(info));
  # Stackaufbau: instance, slot-names, argcount Initarg/Wert-Paare.
   {var reg6 object fun = Cdr(info);
    if (!eq(fun,L(shared_initialize)))
      { # initargs im Stack um 1 nach unten schieben, dann fun aufrufen:
        var reg1 object* ptr = rest_args_pointer;
        var reg2 object last = NIL;
        var reg4 uintC count;
        dotimesC(count,argcount,
          { var reg3 object next = Next(ptr); NEXT(ptr) = last;
            last = Next(ptr); NEXT(ptr) = next;
          });
        pushSTACK(last);
        funcall(fun,2*argcount+2);
        return;
      }
  }}
  # CLOS::%SHARED-INITIALIZE mit slot-names=NIL läßt sich vereinfachen:
  { var reg7 object slots = TheClass(class)->slots; # Liste aller Slots (als Slot-Definitionen)
    while (consp(slots))
      { var reg6 object slot = Car(slots);
        slots = Cdr(slots);
        # Suche ob der Slot durch die Initargs initialisiert wird:
        { var reg5 object l = TheSvector(slot)->data[2]; # (slotdef-initargs slot)
          var reg3 object* ptr = rest_args_pointer;
          var reg4 uintC count;
          dotimesC(count,argcount,
            { var reg2 object initarg = NEXT(ptr);
              # Suche initarg in l
              var reg1 object lr = l;
              while (consp(lr))
                { if (eq(initarg,Car(lr))) goto initarg_found;
                  lr = Cdr(lr);
                }
              NEXT(ptr);
            });
          goto slot_done;
          initarg_found:
         {var reg1 object value = NEXT(ptr);
          # Slot mit value initialisieren:
          {var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
           *ptr_to_slot(Before(rest_args_pointer STACKop 1),slotinfo) = value;
        }}}
        slot_done: ;
  }   }
  value1 = Before(rest_args_pointer); mv_count=1; # Instanz als Wert
  set_args_end_pointer(rest_args_pointer STACKop 1); # STACK aufräumen
}

# (CLOS::%INITIALIZE-INSTANCE instance &rest initargs)
# instance ist eine Instanz von <standard-object>, initargs eine paarige Liste.
# Das ist die primäre Methode von CLOS:INITIALIZE-INSTANCE.
# vgl. clos.lsp
# (defmethod initialize-instance ((instance standard-object) &rest initargs)
#   (let ((h (gethash class *make-instance-table*)))
#     (if h
#       (if (not (eq (cddr h) #'clos::%shared-initialize))
#         ; effektive Methode von shared-initialize anwenden:
#         (apply (cddr h) instance 'T initargs)
#         ; clos::%shared-initialize mit slot-names=T läßt sich vereinfachen:
#         (progn
#           (dolist (slot (class-slots (class-of instance)))
#             (let ((slotname (slotdef-name slot)))
#               (multiple-value-bind (init-key init-value foundp)
#                   (get-properties initargs (slotdef-initargs slot))
#                 (declare (ignore init-key))
#                 (if foundp
#                   (setf (slot-value instance slotname) init-value)
#                   (unless (slot-boundp instance slotname)
#                     (let ((init (slotdef-initer slot)))
#                       (when init
#                         (setf (slot-value instance slotname)
#                               (if (car init) (funcall (car init)) (cdr init))
#           ) ) ) ) ) ) ) )
#           instance
#       ) )
#       (apply #'initial-initialize-instance instance initargs)
# ) ) )
local Values do_initialize_instance (object info, object* rest_args_pointer, uintC argcount);
LISPFUN(initialize_instance,1,0,rest,nokey,0,NIL)
{ var reg9 object instance = Before(rest_args_pointer);
  var reg8 object class = TheInstance(instance)->class; # Instanz der <standard-class>
  # (GETHASH class *MAKE-INSTANCE-TABLE*) suchen:
  { var reg5 object info = gethash(class,Symbol_value(S(make_instance_table)));
    if (eq(info,nullobj))
      # Hash-Tabellen-Eintrag neu berechnen. Siehe clos.lsp.
      { funcall(S(initial_initialize_instance),argcount+1); return; }
    if (!((argcount%2) == 0))
      { var reg1 object arglist = listof(argcount);
        pushSTACK(arglist);
        fehler(error,
               DEUTSCH ? "INITIALIZE-INSTANCE: Keyword-Argumentliste ~ hat ungerade Länge." :
               ENGLISH ? "INITIALIZE-INSTANCE: keyword argument list ~ has an odd length" :
               FRANCAIS ? "INITIALIZE-INSTANCE : La liste de mots clé ~ est de longueur impaire." :
               ""
              );
      }
    argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
    return_Values do_initialize_instance(info,rest_args_pointer,argcount);
} }
local Values do_initialize_instance(info,rest_args_pointer,argcount)
  var reg5 object info;
  var reg8 object* rest_args_pointer;
  var reg8 uintC argcount;
  { # Stackaufbau: instance, argcount Initarg/Wert-Paare.
    { var reg6 object fun = Cdr(Cdr(info));
      if (!eq(fun,L(shared_initialize)))
        { # initargs im Stack um 1 nach unten schieben, dann fun aufrufen:
          var reg1 object* ptr = rest_args_pointer;
          var reg2 object last = T;
          var reg4 uintC count;
          dotimesC(count,argcount,
            { var reg3 object next = Next(ptr); NEXT(ptr) = last;
              last = Next(ptr); NEXT(ptr) = next;
            });
          pushSTACK(last);
          funcall(fun,2*argcount+2);
          return;
        }
    }
    # CLOS::%SHARED-INITIALIZE mit slot-names=T läßt sich vereinfachen:
    { var reg10 object instance = Before(rest_args_pointer);
      var reg9 object class = TheInstance(instance)->class; # Instanz der <standard-class>
      var reg7 object slots = TheClass(class)->slots; # Liste aller Slots (als Slot-Definitionen)
      while (consp(slots))
        { var reg6 object slot = Car(slots);
          slots = Cdr(slots);
          # Suche ob der Slot durch die Initargs initialisiert wird:
          { var reg5 object l = TheSvector(slot)->data[2]; # (slotdef-initargs slot)
            var reg3 object* ptr = rest_args_pointer;
            var reg4 uintC count;
            dotimesC(count,argcount,
              { var reg2 object initarg = NEXT(ptr);
                # Suche initarg in l
                var reg1 object lr = l;
                while (consp(lr))
                  { if (eq(initarg,Car(lr))) goto initarg_found;
                    lr = Cdr(lr);
                  }
                NEXT(ptr);
              });
            goto initarg_not_found;
            initarg_found:
            value1 = NEXT(ptr);
            goto fill_slot;
          }
          initarg_not_found:
          # Nicht gefunden -> erst auf (slot-boundp instance slotname) testen:
          { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
            if (!eq(*ptr_to_slot(Before(rest_args_pointer),slotinfo),unbound))
              goto slot_done;
          }
          # Slot hat noch keinen Wert. Die Initform auswerten:
          { var reg2 object init = TheSvector(slot)->data[4]; # (slotdef-initer slot)
            if (atomp(init)) goto slot_done;
            if (!nullp(Car(init)))
              { pushSTACK(slots); pushSTACK(slot);
                funcall(Car(init),0);
                slot = popSTACK(); slots = popSTACK();
              }
              else
              { value1 = Cdr(init); }
          }
          fill_slot:
          # Slot mit value1 initialisieren:
          { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
            *ptr_to_slot(Before(rest_args_pointer),slotinfo) = value1;
          }
          slot_done: ;
    }   }
    value1 = Before(rest_args_pointer); mv_count=1; # Instanz als Wert
    set_args_end_pointer(rest_args_pointer STACKop 1); # STACK aufräumen
  }

#ifdef RISCOS_CCBUG
  #pragma -z0
#endif
LISPFUN(make_instance,1,0,rest,nokey,0,NIL)
# (CLOS::%MAKE-INSTANCE class &rest initargs)
# class ist eine Instanz der <standard-class>,
# initargs eine (hoffentlich paarige) Liste.
# vgl. clos.lsp
# (defun %make-instance (class &rest initargs)
#   ; 28.1.9.3., 28.1.9.4. default-initargs zur Kenntnis nehmen:
#   (dolist (default-initarg (class-default-initargs class))
#     (let ((nothing default-initarg))
#       (when (eq (getf initargs (car default-initarg) nothing) nothing)
#         (setq initargs
#               (append initargs
#                 (list (car default-initarg)
#                       (let ((init (cdr default-initarg)))
#                         (if (car init) (funcall (car init)) (cdr init))
#   ) ) ) )     ) )     )
#   (let ((h (gethash class *make-instance-table*)))
#     (if h
#       (progn
#         ; 28.1.9.2. validity of initialization arguments
#         (let ((valid-keywords (car h)))
#           (sys::keyword-test initargs valid-keywords)
#         )
#         (let ((instance (std-allocate-instance class)))
#           (if (not (eq (cadr h) #'clos::%initialize-instance))
#             ; effektive Methode von initialize-instance anwenden:
#             (apply (cadr h) instance initargs)
#             ; clos::%initialize-instance läßt sich vereinfachen (man braucht
#             ; nicht nochmal in *make-instance-table* nachzusehen):
#             (if (not (eq (cddr h) #'clos::%shared-initialize))
#               ; effektive Methode von shared-initialize anwenden:
#               (apply (cddr h) instance 'T initargs)
#               ...
#             )
#       ) ) )
#       (apply #'initial-make-instance class initargs)
# ) ) )
{ if (!((argcount%2) == 0))
    { var reg1 object arglist = listof(argcount);
      pushSTACK(arglist);
      fehler(error,
             DEUTSCH ? "MAKE-INSTANCE: Keyword-Argumentliste ~ hat ungerade Länge." :
             ENGLISH ? "MAKE-INSTANCE: keyword argument list ~ has an odd length" :
             FRANCAIS ? "MAKE-INSTANCE : La liste de mots clé ~ est de longueur impaire." :
             ""
            );
    }
  argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
  # Stackaufbau: class, argcount Initarg/Wert-Paare.
  # Default-Initargs anfügen:
  { var reg6 object class = Before(rest_args_pointer);
    var reg5 object l = TheClass(class)->default_initargs;
    while (consp(l))
      { var reg4 object default_initarg = Car(l);
        l = Cdr(l);
       {var reg3 object key = Car(default_initarg);
        # Suche key unter den bisherigen Initargs:
        { var reg1 object* ptr = rest_args_pointer;
          var reg2 uintC count;
          dotimesC(count,argcount,
            { if (eq(NEXT(ptr),key)) goto key_found;
              NEXT(ptr);
            });
        }
        # Nicht gefunden
        pushSTACK(key); # Initarg in den Stack
        { var reg1 object init = Cdr(default_initarg);
          if (!nullp(Car(init)))
            { pushSTACK(l);
              funcall(Car(init),0); # Default auswerten
              l = STACK_0;
              STACK_0 = value1; # Wert in den Stack
            }
            else
            { pushSTACK(Cdr(init)); } # Default in den Stack
        }
        argcount++;
        key_found: ;
      }}
  }
  # (GETHASH class *MAKE-INSTANCE-TABLE*) suchen:
  { var reg6 object class = Before(rest_args_pointer);
    var reg7 object info = gethash(class,Symbol_value(S(make_instance_table)));
    if (eq(info,nullobj))
      # Hash-Tabellen-Eintrag neu berechnen. Siehe clos.lsp.
      { return_Values funcall(S(initial_make_instance),2*argcount+1); }
      else
      { # Keywords überprüfen:
        keyword_test(S(make_instance),rest_args_pointer,argcount,Car(info));
        # (CLOS::ALLOCATE-STD-INSTANCE class (class-instance-slot-count class))
        pushSTACK(info);
        pushSTACK(class); pushSTACK(TheClass(class)->instance_slot_count);
        C_allocate_std_instance();
        info = popSTACK();
        # Effektive Methode von INITIALIZE-INSTANCE anwenden:
        Before(rest_args_pointer) = value1; # instance als 1. Argument statt class
       {var reg1 object fun = Car(Cdr(info));
        if (!eq(fun,L(initialize_instance)))
          { return_Values funcall(fun,2*argcount+1); }
          else
          # CLOS::%INITIALIZE-INSTANCE läßt sich vereinfachen (man braucht
          # nicht nochmal in *make-instance-table* nachzusehen):
          { return_Values do_initialize_instance(info,rest_args_pointer,argcount); }
        # Deren Wert ist die Instanz.
      }}
} }
#ifdef RISCOS_CCBUG
  #pragma -z1
#endif

# ==============================================================================

