home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / record.d < prev    next >
Encoding:
Text File  |  1996-04-27  |  46.7 KB  |  1,117 lines
  1. # Funktionen für Records und Structures von CLISP
  2. # Bruno Haible 20.4.1995
  3.  
  4. #include "lispbibl.c"
  5.  
  6.  
  7. # ==============================================================================
  8. # Records allgemein:
  9.  
  10. # (SYS::%RECORD-REF record index) liefert den Eintrag index in einem record.
  11. # (SYS::%RECORD-STORE record index value) speichert value als Eintrag index
  12. #   in record ab und liefert value.
  13. # (SYS::%RECORD-LENGTH record) liefert die Länge eines record.
  14.  
  15. # Fehlermeldung
  16. # > STACK_1: Record
  17. # > STACK_0: (fehlerhafter) Index
  18. # > subr_self: Aufrufer (ein SUBR)
  19.   nonreturning_function(local, fehler_index, (void));
  20.   local void fehler_index()
  21.     { pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  22.       //: DEUTSCH "~: ~ ist kein erlaubter Index für ~."
  23.       //: ENGLISH "~: ~ is not a valid index into ~"
  24.       //: FRANCAIS "~ : ~ n'est pas un index valide pour ~."
  25.       fehler(error, GETTEXT("~: ~ is not a valid index into ~"));
  26.     }
  27.  
  28. # Fehlermeldung
  29. # > STACK_0: (fehlerhafter) Record
  30. # > subr_self: Aufrufer (ein SUBR)
  31.   nonreturning_function(local, fehler_record, (void));
  32.   local void fehler_record()
  33.     { pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  34.       # type_error ?? 
  35.       //: DEUTSCH "~: ~ ist kein Record."
  36.       //: ENGLISH "~: ~ is not a record"
  37.       //: FRANCAIS "~ : ~ n'est pas un «record»."
  38.       fehler(error,GETTEXT("~: ~ is not a record"));
  39.     }
  40.  
  41. # Überprüfung eines Index auf Typ `(INTEGER 0 (,ARRAY-SIZE-LIMIT))
  42. # > STACK_0: Index
  43. # > STACK_1: Record o.ä. (für Fehlermeldung)
  44. # > subr_self: Aufrufer (ein SUBR)
  45. # < ergebnis: Index
  46.   local uintL test_index (void);
  47.   local uintL test_index()
  48.     { if (!mposfixnump(STACK_0)) { fehler_index(); }
  49.       return posfixnum_to_L(STACK_0);
  50.     }
  51.  
  52. # Unterprogramm für Record-Zugriffsfunktionen:
  53. # > STACK_1: record-Argument
  54. # > STACK_0: index-Argument
  55. # > subr_self: Aufrufer (ein SUBR)
  56. # < STACK: aufgeräumt
  57. # < ergebnis: Adresse des angesprochenen Record-Elements
  58.   local object* record_up (void);
  59.   local object* record_up ()
  60.     { # record muß vom Typ Closure/Structure/Stream/OtherRecord sein:
  61.       if_mrecordp(STACK_1, ; , { skipSTACK(1); fehler_record(); } );
  62.      {var reg2 uintL index = test_index(); # Index holen
  63.       var reg1 object record = STACK_1;
  64.       var reg3 uintL length = Record_length(record);
  65.       if (!(index < length)) { fehler_index(); } # und prüfen
  66.       skipSTACK(2); # Stack aufräumen
  67.       return &TheRecord(record)->recdata[index]; # Record-Element adressieren
  68.     }}
  69.  
  70. LISPFUNN(record_ref,2)
  71. # (SYS::%RECORD-REF record index) liefert den Eintrag index in einem record.
  72.   { value1 = *(record_up()); mv_count=1; } # Record-Element als Wert
  73.  
  74. LISPFUNN(record_store,3)
  75. # (SYS::%RECORD-STORE record index value) speichert value als Eintrag index
  76. #   in record ab und liefert value.
  77.   { var reg3 object value = popSTACK();
  78.     value1 = *(record_up()) = value; mv_count=1; # Record-Element eintragen
  79.   }
  80.  
  81. LISPFUNN(record_length,1)
  82. # (SYS::%RECORD-LENGTH record) liefert die Länge eines record.
  83.   { # record muß vom Typ Closure/Structure/Stream/OtherRecord sein:
  84.     if_mrecordp(STACK_0, ; , { fehler_record(); } );
  85.    {var reg1 object record = popSTACK();
  86.     var reg2 uintL length = Record_length(record);
  87.     value1 = fixnum(length); mv_count=1; # Länge als Fixnum
  88.   }}
  89.  
  90. # ==============================================================================
  91. # Structures:
  92.  
  93. # (SYS::%STRUCTURE-REF type structure index) liefert zu einer Structure vom
  94. #   gegebenen Typ type (ein Symbol) den Eintrag index>=1.
  95. # (SYS::%STRUCTURE-STORE type structure index object) speichert object als
  96. #   Eintrag index in einer Structure vom gegebenen Typ type und liefert object.
  97. # (SYS::%MAKE-STRUCTURE type length) erzeugt eine Structure mit length>=1
  98. #   Elementen, vom Typ type.
  99. # (SYS::%COPY-STRUCTURE structure) liefert eine Kopie der Structure structure,
  100. #   vom selben Typ.
  101. # (SYS::%STRUCTURE-TYPE-P type object) überprüft, ob object eine
  102. #   Structure ist, die vom Typ type ist, was daran erkennbar ist, daß in
  103. #   der Komponente 0 ein Objekt (name_1 ... name_i-1 name_i) steht, wobei
  104. #   einer der Namen EQ zu type ist.
  105.  
  106. # Unterprogramm für Structure-Zugriffsfunktionen:
  107. # > STACK_2: type-Argument
  108. # > STACK_1: structure-Argument
  109. # > STACK_0: index-Argument
  110. # > subr_self: Aufrufer (ein SUBR)
  111. # < ergebnis: Adresse des angesprochenen Structure-Elements
  112.   local object* structure_up (void);
  113.   local object* structure_up ()
  114.     { # structure muß vom Typ Structure sein:
  115.       if (!mstructurep(STACK_1))
  116.         { fehler_bad_structure: # STACK_2 = type, STACK_1 = structure
  117.           pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  118.           pushSTACK(STACK_(2+1)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  119.           pushSTACK(STACK_(2+2));
  120.           pushSTACK(STACK_(1+3));
  121.           pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  122.           //: DEUTSCH "~: ~ ist keine Structure vom Typ ~."
  123.           //: ENGLISH "~: ~ is not a structure of type ~"
  124.           //: FRANCAIS "~ : ~ n'est pas une structure de type ~."
  125.           fehler(type_error, GETTEXT("~: ~ is not a structure of type ~"));
  126.         }
  127.      {var reg4 uintL index = test_index(); # Index holen
  128.       var reg3 object structure = STACK_1;
  129.       var reg1 object namelist = TheStructure(structure)->structure_types; # erste Komponente
  130.       var reg2 object type = STACK_2; # type-Argument
  131.       # Teste, ob in namelist = (name_1 ... name_i-1 name_i) type vorkommt:
  132.       while (consp(namelist))
  133.         { if (eq(Car(namelist),type)) goto yes;
  134.           namelist = Cdr(namelist);
  135.         }
  136.       # type kam nicht vor -> Error:
  137.       goto fehler_bad_structure;
  138.       # type kam vor:
  139.       yes:
  140.       if (!(index < (uintL)(TheStructure(structure)->reclength))) { fehler_index(); } # und prüfen
  141.       return &TheStructure(structure)->recdata[index]; # Structure-Komponente adressieren
  142.     }}
  143.  
  144. LISPFUNN(structure_ref,3)
  145. # (SYS::%STRUCTURE-REF type structure index) liefert zu einer Structure vom
  146. #   gegebenen Typ type (ein Symbol) den Eintrag index>=1.
  147.   { value1 = *(structure_up()); # Structure-Element als Wert
  148.     if (eq(value1,unbound)) # Könnte = #<UNBOUND> sein, nach Gebrauch von SLOT-MAKUNBOUND
  149.       { pushSTACK(STACK_1);
  150.         pushSTACK(S(structure_ref));
  151.         //: DEUTSCH "~: Ein Slot von ~ hat keinen Wert."
  152.         //: ENGLISH "~: A slot of ~ has no value"
  153.         //: FRANCAIS "~ : Un composant de ~ n'a pas de valeur."
  154.         fehler(error, GETTEXT("~: A slot of ~ has no value"));
  155.       }
  156.     mv_count=1;
  157.     skipSTACK(3); # Stack aufräumen
  158.   }
  159.  
  160. LISPFUNN(structure_store,4)
  161. # (SYS::%STRUCTURE-STORE type structure index object) speichert object als
  162. #   Eintrag index in einer Structure vom gegebenen Typ type und liefert object.
  163.   { var reg3 object value = popSTACK();
  164.     value1 = *(structure_up()) = value; mv_count=1; # Structure-Element eintragen
  165.     skipSTACK(3); # Stack aufräumen
  166.   }
  167.  
  168. LISPFUNN(make_structure,2)
  169. # (SYS::%MAKE-STRUCTURE type length) erzeugt eine Structure mit length>=1
  170. #   Elementen, vom Typ type.
  171.   { # Länge überprüfen, sollte ein Fixnum /=0 sein, das in ein uintW paßt:
  172.     var reg1 uintL length;
  173.     if (!(mposfixnump(STACK_0)
  174.           && ((length = posfixnum_to_L(STACK_0)) <= (uintL)(bitm(intWsize)-1))
  175.           && (length>0)
  176.        ) )
  177.       { # STACK_0 = length, Wert für Slot DATUM von TYPE-ERROR
  178.         pushSTACK(O(type_posint16)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  179.         pushSTACK(STACK_1); # length
  180.         pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  181.         //: DEUTSCH "~: ~ ist nicht als Länge zugelassen, da nicht vom Typ (INTEGER (0) (65536))."
  182.         //: ENGLISH "~: length ~ is illegal, should be of type (INTEGER (0) (65536))"
  183.         //: FRANCAIS "~ : ~ n'est pas permis comme longueur parce qu'il faut le type (INTEGER (0) (65536))."
  184.         fehler(type_error, GETTEXT("~: length ~ is illegal, should be of type (INTEGER (0) (65536))"));
  185.       }
  186.     skipSTACK(1);
  187.    {var reg2 object structure = allocate_structure(length);
  188.     # neue Structure, mit NILs gefüllt
  189.     TheStructure(structure)->structure_types = popSTACK(); # Typ-Komponente eintragen
  190.     value1 = structure; mv_count=1; # structure als Wert
  191.   }}
  192.  
  193. LISPFUNN(copy_structure,1)
  194. # (SYS::%COPY-STRUCTURE structure) liefert eine Kopie der Structure structure,
  195. #   vom selben Typ.
  196.   { if (!(mstructurep(STACK_0)))
  197.       { # STACK_0 = Wert für Slot DATUM von TYPE-ERROR
  198.         pushSTACK(S(structure)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  199.         pushSTACK(STACK_1); # structure
  200.         pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  201.         //: DEUTSCH "~: ~ ist keine Structure."
  202.         //: ENGLISH "~: ~ is not a structure"
  203.         //: FRANCAIS "~ : ~ n'est pas une structure."
  204.         fehler(type_error, GETTEXT("~: ~ is not a structure"));
  205.       }
  206.    {var reg3 uintC length = TheStructure(STACK_0)->reclength;
  207.     var reg4 object new_structure = allocate_structure(length); # neue Structure
  208.     # und füllen:
  209.     {var reg1 object* old_ptr = &TheStructure(popSTACK())->structure_types;
  210.      var reg2 object* new_ptr = &TheStructure(new_structure)->structure_types;
  211.      dotimespC(length,length, { *new_ptr++ = *old_ptr++; });
  212.     }
  213.     # und als Wert zurück:
  214.     value1 = new_structure; mv_count=1;
  215.   }}
  216.  
  217. LISPFUNN(structure_type_p,2)
  218. # (SYS::%STRUCTURE-TYPE-P type object) überprüft, ob object eine
  219. #   Structure ist, die vom Typ type ist, was daran erkennbar ist, daß in
  220. #   der Komponente 0 ein Objekt (name_1 ... name_i-1 name_i) steht, wobei
  221. #   einer der Namen EQ zu type ist.
  222.   { # object auf Structure testen:
  223.     if (!(mstructurep(STACK_0))) { skipSTACK(2); goto no; }
  224.     { var reg1 object namelist = TheStructure(popSTACK())->structure_types;
  225.       var reg2 object type = popSTACK();
  226.       # Teste, ob in namelist = (name_1 ... name_i-1 name_i) type vorkommt:
  227.       while (consp(namelist))
  228.         { if (eq(Car(namelist),type)) goto yes;
  229.           namelist = Cdr(namelist);
  230.     }   }
  231.     # type kam nicht vor:
  232.     no: value1 = NIL; mv_count=1; return; # 1 Wert NIL
  233.     # type kam vor:
  234.     yes: value1 = T; mv_count=1; return; # 1 Wert T
  235.   }
  236.  
  237. # ==============================================================================
  238. # Closures:
  239.  
  240. # (SYS::CLOSURE-NAME closure) liefert den Namen einer Closure.
  241. # (SYS::CLOSURE-CODEVEC closure) liefert den Code-Vektor einer compilierten
  242. #   Closure, als Liste von Fixnums >=0, <256.
  243. # (SYS::CLOSURE-CONSTS closure) liefert eine Liste aller Konstanten einer
  244. #   compilierten Closure.
  245. # (SYS::MAKE-CODE-VECTOR list) liefert zu einer Liste von Fixnums >=0, <256
  246. #   einen Simple-Bit-Vector der 8-fachen Länge, der diese Zahlen als Bytes
  247. #   enthält.
  248. # (SYS::%MAKE-CLOSURE name codevec consts) liefert eine Closure mit gegebenem
  249. #   Namen (einem Symbol), gegebenem Code-Vektor (einem Simple-Bit-Vector) und
  250. #   gegebenen weiteren Konstanten.
  251.  
  252. LISPFUNN(closure_name,1)
  253. # (SYS::CLOSURE-NAME closure) liefert den Namen einer Closure.
  254.   { var reg1 object closure = popSTACK();
  255.     if (!(closurep(closure)))
  256.       { pushSTACK(closure);
  257.         pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  258.         # type_error ?? 
  259.         //: DEUTSCH "~: ~ ist keine Closure."
  260.         //: ENGLISH "~: ~ is not a closure"
  261.         //: FRANCAIS "~ : ~ n'est pas une fermeture."
  262.         fehler(error, GETTEXT("~: ~ is not a closure"));
  263.       }
  264.     value1 = TheClosure(closure)->clos_name; mv_count=1;
  265.   }
  266.  
  267. # Fehler, wenn Argument keine compilierte Closure
  268.   nonreturning_function(local, fehler_cclosure, (object obj));
  269.   local void fehler_cclosure(obj)
  270.     var reg1 object obj;
  271.     { pushSTACK(obj);
  272.       pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  273.       # type_error ??
  274.       //: DEUTSCH "~: Das ist keine compilierte Closure: ~"
  275.       //: ENGLISH "~: This is not a compiled closure: ~"
  276.       //: FRANCAIS "~ : Ceci n'est pas un fermeture compilée : ~"
  277.       fehler(error, GETTEXT("~: This is not a compiled closure: ~"));
  278.     }
  279.  
  280. LISPFUNN(closure_codevec,1)
  281. # (SYS::CLOSURE-CODEVEC closure) liefert den Code-Vektor einer compilierten
  282. #   Closure, als Liste von Fixnums >=0, <256.
  283.   { var reg3 object closure = popSTACK();
  284.     if (!(cclosurep(closure))) fehler_cclosure(closure);
  285.    {var reg2 object codevec = TheCclosure(closure)->clos_codevec;
  286.     var reg1 uintL index = (TheSbvector(codevec)->length)/8; # index := Länge in Bytes
  287.     # Codevektor codevec von hinten durchgehen und Bytes auf eine Liste pushen:
  288.     pushSTACK(codevec); # Codevektor
  289.     pushSTACK(NIL); # Liste := ()
  290.     until (index==0)
  291.       { index--; # Index decrementieren
  292.         # neues Cons vor die Liste setzen:
  293.        {var reg1 object new_cons = allocate_cons();
  294.         Cdr(new_cons) = popSTACK();
  295.         Car(new_cons) = fixnum((uintL)(TheSbvector(STACK_0)->data[index])); # Byte herausholen
  296.         pushSTACK(new_cons);
  297.       }}
  298.     value1 = STACK_0; mv_count=1; skipSTACK(2); # Liste als Wert
  299.   }}
  300.  
  301. LISPFUNN(closure_consts,1)
  302. # (SYS::CLOSURE-CONSTS closure) liefert eine Liste aller Konstanten einer
  303. #   compilierten Closure.
  304.   { var reg2 object closure = popSTACK();
  305.     if (!(cclosurep(closure))) fehler_cclosure(closure);
  306.     # Elemente 2,3,... zu einer Liste zusammenfassen:
  307.    {var reg1 uintC index = (TheCclosure(closure)->reclength)-2; # index := Länge
  308.     # Closure von hinten durchgehen und Konstanten auf eine Liste pushen:
  309.     pushSTACK(closure); # Closure
  310.     pushSTACK(NIL); # Liste := ()
  311.     until (index==0)
  312.       { index--; # Index decrementieren
  313.         # neues Cons vor die Liste setzen:
  314.        {var reg1 object new_cons = allocate_cons();
  315.         Cdr(new_cons) = popSTACK();
  316.         Car(new_cons) = TheCclosure(STACK_0)->clos_consts[(uintP)index]; # Konstante herausholen
  317.         pushSTACK(new_cons);
  318.       }}
  319.     value1 = STACK_0; mv_count=1; skipSTACK(2); # Liste als Wert
  320.   }}
  321.  
  322. LISPFUNN(make_code_vector,1)
  323. # (SYS::MAKE-CODE-VECTOR list) liefert zu einer Liste von Fixnums >=0, <256
  324. #   einen Simple-Bit-Vector der 8-fachen Länge, der diese Zahlen als Bytes
  325. #   enthält.
  326.   { var reg4 object bv = allocate_bit_vector(8*llength(STACK_0)); # Simple-Bit-Vektor
  327.     # füllen:
  328.     var reg1 object listr = popSTACK(); # Liste
  329.     var reg3 uintB* ptr = &TheSbvector(bv)->data[0]; # läuft durch den Bit-Vektor
  330.     while (consp(listr))
  331.       { var reg2 uintL byte;
  332.         # Listenelement muß ein Fixnum >=0, <256 sein:
  333.         if (!(mposfixnump(Car(listr))
  334.               && ((byte = posfixnum_to_L(Car(listr))) < (1<<intBsize))
  335.            ) )
  336.           goto bad_byte;
  337.         # in den Bit-Vektor stecken:
  338.         *ptr++ = (uintB)byte;
  339.         listr = Cdr(listr);
  340.       }
  341.     value1 = bv; mv_count=1; return; # bv als Wert
  342.     bad_byte:
  343.       pushSTACK(Car(listr)); # Wert für Slot DATUM von TYPE-ERROR
  344.       pushSTACK(O(type_uint8)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  345.       pushSTACK(STACK_1);
  346.       //: DEUTSCH "~ ist als Byte in einem Code-Vektor ungeeignet."
  347.       //: ENGLISH "~ is not a valid code-vector byte"
  348.       //: FRANCAIS "~ est inutilisable comme octet dans un «code-vector»."
  349.       fehler(type_error, GETTEXT("~ is not a valid code-vector byte"));
  350.   }
  351.  
  352. LISPFUNN(make_closure,3)
  353. # (SYS::%MAKE-CLOSURE name codevec consts) liefert eine Closure mit gegebenem
  354. #   Namen (einem Symbol), gegebenem Code-Vektor (einem Simple-Bit-Vector) und
  355. #   gegebenen weiteren Konstanten.
  356.   { # codevec muß ein Simple-Bit-Vector sein:
  357.     if (!(m_simple_bit_vector_p(STACK_1)))
  358.       { # STACK_1 = codevec
  359.         pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  360.         pushSTACK(S(simple_bit_vector)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  361.         pushSTACK(STACK_(1+2));
  362.         pushSTACK(TheSubr(subr_self)->name);
  363.         //: DEUTSCH "~: Als Code-Vektor einer Funktion ist ~ ungeeignet."
  364.         //: ENGLISH "~: invalid code-vector ~"
  365.         //: FRANCAIS "~ : ~ n'est pas utilisable comme «code-vector» d'une fonction."
  366.         fehler(type_error, GETTEXT("~: invalid code-vector ~"));
  367.       }
  368.    {# neue Closure der Länge (+ 2 (length consts)) erzeugen:
  369.     var reg4 uintL length = 2+llength(STACK_0);
  370.     if (!(length <= (uintL)(bitm(intWsize)-1))) # sollte in ein uintW passen
  371.       { # STACK_0 = consts
  372.         pushSTACK(STACK_2); # name
  373.         pushSTACK(TheSubr(subr_self)->name);
  374.         //: DEUTSCH "~: Funktion ~ ist zu groß: ~"
  375.         //: ENGLISH "~: function ~ is too big: ~"
  376.         //: FRANCAIS "~ : La function ~ est trop grosse: ~"
  377.         fehler(error, GETTEXT("~: function ~ is too big: ~"));
  378.       }
  379.     {var reg3 object closure = allocate_srecord(0,Rectype_Closure,length,closure_type);
  380.      TheCclosure(closure)->clos_name = STACK_2; # Namen einfüllen
  381.      TheCclosure(closure)->clos_codevec = STACK_1; # Codevektor einfüllen
  382.      # Konstanten einfüllen:
  383.      {var reg1 object constsr = popSTACK();
  384.       var reg2 object* ptr = &TheCclosure(closure)->clos_consts[0];
  385.       while (consp(constsr))
  386.         { *ptr++ = Car(constsr); constsr = Cdr(constsr); }
  387.      }
  388.      value1 = closure; mv_count=1; skipSTACK(2);
  389.   }}}
  390.  
  391. # ==============================================================================
  392. # Load-Time-Eval:
  393.  
  394. # (SYS::MAKE-LOAD-TIME-EVAL form) liefert ein Load-Time-Eval-Objekt, das
  395. #   - wenn ausgegeben und wieder eingelesen - form auswertet.
  396.  
  397. LISPFUNN(make_load_time_eval,1)
  398. # (SYS::MAKE-LOAD-TIME-EVAL form) liefert ein Load-Time-Eval-Objekt, das
  399. #   - wenn ausgegeben und wieder eingelesen - form auswertet.
  400.   { var reg1 object lte = allocate_loadtimeeval();
  401.     TheLoadtimeeval(lte)->loadtimeeval_form = popSTACK();
  402.     value1 = lte; mv_count=1;
  403.   }
  404.  
  405. # ==============================================================================
  406. # Symbol-Macro:
  407.  
  408. # (SYS::MAKE-SYMBOL-MACRO expansion) liefert ein Symbol-Macro-Objekt,
  409. #   das die gegebene Expansion repräsentiert.
  410. # (SYS::SYMBOL-MACRO-P object) testet auf Symbol-Macro.
  411.  
  412. # Wegen ihrer besonderen Bedeutung im Interpreter sind Symbol-Macro-Objekte
  413. # - genauso wie #<UNBOUND> und #<SPECDECL> - keine Objekte erster Klasse.
  414. # Sie können nur als Werte durchgereicht, nicht aber an Variablen zugewiesen
  415. # werden.
  416.  
  417. # (SYMBOL-MACRO-EXPAND symbol) testet, ob ein Symbol ein Symbol-Macro
  418. # repräsentiert, und liefert T und die Expansion wenn ja, NIL wenn nein.
  419.  
  420. LISPFUNN(make_symbol_macro,1)
  421. # (SYS::MAKE-SYMBOL-MACRO expansion) liefert ein Symbol-Macro-Objekt,
  422. #   das die gegebene Expansion repräsentiert.
  423.   { var reg1 object sm = allocate_symbolmacro();
  424.     TheSymbolmacro(sm)->symbolmacro_expansion = popSTACK();
  425.     value1 = sm; mv_count=1;
  426.   }
  427.  
  428. LISPFUNN(symbol_macro_p,1)
  429. # (SYS::SYMBOL-MACRO-P object) testet auf Symbol-Macro.
  430.   { var reg1 object obj = popSTACK();
  431.     value1 = (symbolmacrop(obj) ? T : NIL); mv_count=1;
  432.   }
  433.  
  434. LISPFUNN(symbol_macro_expand,1)
  435. # (SYMBOL-MACRO-EXPAND symbol) testet, ob ein Symbol ein Symbol-Macro
  436. # repräsentiert, und liefert T und die Expansion wenn ja, NIL wenn nein.
  437. # (defun symbol-macro-expand (v)
  438. #   (unless (symbolp v) (error ...))
  439. #   (and (boundp v) (symbol-macro-p (%symbol-value v))
  440. #        (values t (sys::%record-ref (%symbol-value v) 0))
  441. # ) )
  442.   { var reg1 object obj = popSTACK();
  443.     if (!symbolp(obj)) { fehler_symbol(obj); }
  444.     obj = Symbol_value(obj);
  445.     if (!symbolmacrop(obj))
  446.       { value1 = NIL; mv_count=1; return; }
  447.     value1 = T; value2 = TheSymbolmacro(obj)->symbolmacro_expansion; mv_count=2;
  448.   }
  449.  
  450. # ==============================================================================
  451. # Finalisierer:
  452.  
  453. LISPFUN(finalize,2,1,norest,nokey,0,NIL)
  454. # (FINALIZE object function &optional alive)
  455. # registiert, daß, wenn object durch GC stirbt, function aufgerufen wird, mit
  456. # object und evtl. alive als Argument. Wenn alive stirbt, bevor object stirbt,
  457. # wird gar nichts getan.
  458.   { var reg1 object f = allocate_finalizer();
  459.     TheFinalizer(f)->fin_trigger = STACK_2;
  460.     TheFinalizer(f)->fin_function = STACK_1;
  461.     TheFinalizer(f)->fin_alive = STACK_0; # Der Default #<UNBOUND> lebt ewig.
  462.     TheFinalizer(f)->fin_cdr = O(all_finalizers);
  463.     O(all_finalizers) = f;
  464.     skipSTACK(3); value1 = NIL; mv_count=1;
  465.   }
  466.  
  467. # ==============================================================================
  468. # CLOS-Objekte:
  469.  
  470. LISPFUNN(std_instance_p,1)
  471. # (CLOS::STD-INSTANCE-P object) testet, ob ein Objekt ein CLOS-Objekt ist.
  472.   { var reg1 object obj = popSTACK();
  473.     value1 = (instancep(obj) ? T : NIL); mv_count=1;
  474.   }
  475.  
  476. LISPFUNN(allocate_std_instance,2)
  477. # (CLOS::ALLOCATE-STD-INSTANCE class n) liefert eine CLOS-Instanz der Länge n,
  478. # mit Klasse class und n-1 zusätzlichen Slots.
  479.   { # Länge überprüfen, sollte ein Fixnum >=0 sein, das in ein uintW paßt:
  480.     var reg2 uintL length;
  481.     if (!(mposfixnump(STACK_0)
  482.           && ((length = posfixnum_to_L(STACK_0)) <= (uintL)(bitm(intWsize)-1))
  483.        ) )
  484.       { # STACK_0 = n, Wert für Slot DATUM von TYPE-ERROR
  485.         pushSTACK(O(type_uint16)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  486.         pushSTACK(STACK_1); # n
  487.         pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  488.         //: DEUTSCH "~: ~ ist nicht als Länge zugelassen, da nicht vom Typ (INTEGER 0 (65536))."
  489.         //: ENGLISH "~: length ~ is illegal, should be of type (INTEGER 0 (65536))"
  490.         //: FRANCAIS "~ : ~ n'est pas permis comme longueur parce qu'il faut le type (INTEGER 0 (65536))."
  491.         fehler(type_error, GETTEXT("~: length ~ is illegal, should be of type (INTEGER 0 (65536))"));
  492.       }
  493.     skipSTACK(1);
  494.    {var reg3 object instance = allocate_srecord(0,Rectype_Instance,length,instance_type);
  495.     var reg4 object class = popSTACK();
  496.     if (!classp(class))
  497.       { pushSTACK(class); # Wert für Slot DATUM von TYPE-ERROR
  498.         pushSTACK(S(closclass)); # CLOS::CLASS, Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  499.         pushSTACK(class);
  500.         pushSTACK(TheSubr(subr_self)->name); # Funktionsname
  501.         //: DEUTSCH "~: ~ ist keine Klasse."
  502.         //: ENGLISH "~: ~ is not a class"
  503.         //: FRANCAIS "~ : ~ n'est pas une classe."
  504.         fehler(type_error, GETTEXT("~: ~ is not a class"));
  505.       }
  506.     TheInstance(instance)->class = class;
  507.     # Slots der Instanz mit #<UNBOUND> füllen:
  508.     {var reg1 object* ptr = &TheInstance(instance)->other[0];
  509.      dotimesL(length,length-1, { *ptr++ = unbound; } );
  510.     }
  511.     value1 = instance; mv_count=1; # instance als Wert
  512.   }}
  513.  
  514. # (CLOS:SLOT-VALUE instance slot-name)
  515. # (CLOS::SET-SLOT-VALUE instance slot-name new-value)
  516. # (CLOS:SLOT-BOUNDP instance slot-name)
  517. # (CLOS:SLOT-MAKUNBOUND instance slot-name)
  518. # (CLOS:SLOT-EXISIS-P instance slot-name)
  519. # CLtL2 S. 855,857
  520.  
  521. # Liefert aus einer Slot-Location-Info die Adresse eines existierenden Slots
  522. # in einer Instanz einer Standard- oder Structure-Klasse.
  523.   #define ptr_to_slot(instance,slotinfo)  \
  524.     (atomp(slotinfo)                                            \
  525.      # local slot, slotinfo ist Index                           \
  526.      ? &TheSrecord(instance)->recdata[posfixnum_to_L(slotinfo)] \
  527.      # shared slot, slotinfo ist (class . index)                \
  528.      : &TheSvector(TheClass(Car(slotinfo))->shared_slots)       \
  529.                   ->data[posfixnum_to_L(Cdr(slotinfo))]         \
  530.     )
  531.  
  532. # UP: Sucht einen Slot auf.
  533. # slot_up()
  534. # > STACK_1: instance
  535. # > STACK_0: slot-name
  536. # < ergebnis: Pointer auf den Slot (dann ist value1 = (class-of instance)),
  537. #             oder NULL (dann wurde SLOT-MISSING aufgerufen).
  538.   local object* slot_up (void);
  539.   #ifdef RISCOS_CCBUG
  540.     #pragma -z0
  541.   #endif
  542.   local object* slot_up()
  543.     { pushSTACK(STACK_1); C_class_of(); # (CLASS-OF instance) bestimmen
  544.      {var reg1 object slotinfo = # (GETHASH slot-name (class-slot-location-table class))
  545.         gethash(STACK_0,TheClass(value1)->slot_location_table);
  546.       if (!eq(slotinfo,nullobj)) # gefunden?
  547.         { return ptr_to_slot(STACK_1,slotinfo); }
  548.         else
  549.         # missing slot -> (SLOT-MISSING class instance slot-name caller)
  550.         { pushSTACK(value1); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
  551.           pushSTACK(TheSubr(subr_self)->name);
  552.           funcall(S(slot_missing),4);
  553.           return NULL;
  554.         }
  555.     }}
  556.   #ifdef RISCOS_CCBUG
  557.     #pragma -z1
  558.   #endif
  559.  
  560. LISPFUNN(slot_value,2)
  561. { var reg2 object* slot = slot_up();
  562.   if (slot)
  563.     { var reg1 object value = *slot;
  564.       if (!eq(value,unbound))
  565.         { value1 = value; mv_count=1; }
  566.         else
  567.         # (SLOT-UNBOUND class instance slot-name)
  568.         { pushSTACK(value1); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
  569.           funcall(S(slot_unbound),3);
  570.     }   }
  571.   skipSTACK(2);
  572. }
  573.  
  574. #ifdef RISCOS_CCBUG
  575.   #pragma -z0
  576. #endif
  577. LISPFUNN(set_slot_value,3)
  578. { # Stackaufbau: instance, slot-name, new-value.
  579.   pushSTACK(STACK_2); C_class_of(); # (CLASS-OF instance) bestimmen
  580.  {var reg1 object slotinfo = # (GETHASH slot-name (class-slot-location-table class))
  581.     gethash(STACK_1,TheClass(value1)->slot_location_table);
  582.   if (!eq(slotinfo,nullobj)) # gefunden?
  583.     { value1 = *ptr_to_slot(STACK_2,slotinfo) = STACK_0; mv_count=1; }
  584.     else
  585.     # missing slot -> (SLOT-MISSING class instance slot-name 'setf new-value)
  586.     { pushSTACK(value1); pushSTACK(STACK_(2+1)); pushSTACK(STACK_(1+2));
  587.       pushSTACK(S(setf)); pushSTACK(STACK_(0+4));
  588.       funcall(S(slot_missing),5);
  589.     }
  590.   skipSTACK(3);
  591. }}
  592. #ifdef RISCOS_CCBUG
  593.   #pragma -z1
  594. #endif
  595.  
  596. LISPFUNN(slot_boundp,2)
  597. { var reg2 object* slot = slot_up();
  598.   if (slot)
  599.     { value1 = (eq(*slot,unbound) ? NIL : T); mv_count=1; }
  600.   skipSTACK(2);
  601. }
  602.  
  603. LISPFUNN(slot_makunbound,2)
  604. { var reg2 object* slot = slot_up();
  605.   if (slot)
  606.     { *slot = unbound;
  607.       value1 = STACK_1; mv_count=1; # instance als Wert
  608.     }
  609.   skipSTACK(2);
  610. }
  611.  
  612. #ifdef RISCOS_CCBUG
  613.   #pragma -z0
  614. #endif
  615. LISPFUNN(slot_exists_p,2)
  616. { pushSTACK(STACK_1); C_class_of(); # (CLASS-OF instance) bestimmen
  617.  {var reg1 object slotinfo = # (GETHASH slot-name (class-slot-location-table class))
  618.     gethash(STACK_0,TheClass(value1)->slot_location_table);
  619.   value1 = (eq(slotinfo,nullobj) ? NIL : T); mv_count=1; skipSTACK(2);
  620. }}
  621. #ifdef RISCOS_CCBUG
  622.   #pragma -z1
  623. #endif
  624.  
  625.   local void fehler_illegal_keyword_value_pair (object valid_keywords,object next,object key,object caller);
  626.   local void fehler_illegal_keyword_value_pair(valid_keywords,next,key,caller)
  627.     var object valid_keywords;
  628.     var object next;
  629.     var object key;
  630.     var object caller;
  631.     { var const char *msg1,*msg2;
  632.       pushSTACK(valid_keywords);
  633.       pushSTACK(next); 
  634.       pushSTACK(key);
  635.       pushSTACK(caller);
  636.  
  637.       //: DEUTSCH "~: Unzulässiges Keyword/Wert-Paar ~, ~ in der Argumentliste."
  638.       //: ENGLISH "~: illegal keyword/value pair ~, ~ in argument list."
  639.       //: FRANCAIS "~ : Paire mot-clé - valeur ~, ~ illicite dans la liste d'arguments." 
  640.       msg1 = GETTEXT("~: illegal keyword/value pair ~, ~ in argument list.");
  641.       //: DEUTSCH "Die erlaubten Keywords sind ~" 
  642.       //: ENGLISH "The allowed keywords are ~"
  643.       //: FRANCAIS "Les mots-clé permis sont ~"
  644.       msg2 = GETTEXT("~: illegal keyword/value pair ~, ~ in argument list.");
  645.       fehler3(error,msg1,NLstring,msg2);
  646.     }
  647.  
  648. # UP: Keywords überprüfen, vgl. SYSTEM::KEYWORD-TEST
  649. # keyword_test(caller,rest_args_pointer,argcount,valid_keywords);
  650. # > caller: Aufrufer (ein Symbol)
  651. # > rest_args_pointer: Pointer über die Argumente
  652. # > argcount: Anzahl der Argumente / 2
  653. # > valid_keywords: Liste der gültigen Keywords
  654.   local void keyword_test (object caller, object* rest_args_pointer, uintC argcount, object valid_keywords);
  655.   local void keyword_test(caller,rest_args_pointer,argcount,valid_keywords)
  656.     var reg8 object caller;
  657.     var reg7 object* rest_args_pointer;
  658.     var reg6 uintC argcount;
  659.     var reg5 object valid_keywords;
  660.     { if (argcount==0) return;
  661.       # Suche, ob :ALLOW-OTHER-KEYS kommt:
  662.       { var reg1 object* ptr = rest_args_pointer;
  663.         var reg2 uintC count;
  664.         dotimespC(count,argcount,
  665.           { if (eq(NEXT(ptr),S(Kallow_other_keys)))
  666.               if (!nullp(Next(ptr)))
  667.                 return;
  668.             NEXT(ptr);
  669.           });
  670.       }
  671.       # Suche, ob alle angegebenen Keywords in valid_keywords vorkommen:
  672.       { var reg3 object* ptr = rest_args_pointer;
  673.         var reg4 uintC count;
  674.         dotimespC(count,argcount,
  675.           { var reg2 object key = NEXT(ptr);
  676.             var reg1 object kwlistr = valid_keywords;
  677.             while (consp(kwlistr))
  678.               { if (eq(Car(kwlistr),key)) goto kw_found;
  679.                 kwlistr = Cdr(kwlistr);
  680.               }
  681.             # nicht gefunden
  682.             fehler_illegal_keyword_value_pair(valid_keywords,Next(ptr),key,caller);
  683.             kw_found: # gefunden. Weiter:
  684.             NEXT(ptr);
  685.           });
  686.     } }
  687.  
  688. LISPFUN(shared_initialize,2,0,rest,nokey,0,NIL)
  689. # (CLOS::%SHARED-INITIALIZE instance slot-names &rest initargs)
  690. # instance ist eine Instanz von <standard-object>, initargs eine paarige Liste.
  691. # Das ist die primäre Methode von CLOS:SHARED-INITIALIZE.
  692. # vgl. clos.lsp
  693. # (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs &key &allow-other-keys)
  694. #   (dolist (slot (class-slots (class-of instance)))
  695. #     (let ((slotname (slotdef-name slot)))
  696. #       (multiple-value-bind (init-key init-value foundp)
  697. #           (get-properties initargs (slotdef-initargs slot))
  698. #         (declare (ignore init-key))
  699. #         (if foundp
  700. #           (setf (slot-value instance slotname) init-value)
  701. #           (unless (slot-boundp instance slotname)
  702. #             (let ((init (slotdef-initer slot)))
  703. #               (when init
  704. #                 (when (or (eq slot-names 'T) (member slotname slot-names :test #'eq))
  705. #                   (setf (slot-value instance slotname)
  706. #                         (if (car init) (funcall (car init)) (cdr init))
  707. #   ) ) ) ) ) ) ) ) )
  708. #   instance
  709. # )
  710. { if (!((argcount%2) == 0))
  711.     { var reg1 object arglist = listof(argcount);
  712.       pushSTACK(arglist);
  713.       //: DEUTSCH "SHARED-INITIALIZE: Keyword-Argumentliste ~ hat ungerade Länge."
  714.       //: ENGLISH "SHARED-INITIALIZE: keyword argument list ~ has an odd length"
  715.       //: FRANCAIS "SHARED-INITIALIZE : La liste de mots clé ~ est de longueur impaire."
  716.       fehler(error, GETTEXT("SHARED-INITIALIZE: keyword argument list ~ has an odd length"));
  717.     }
  718.   argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
  719.   # Stackaufbau: instance, slot-names, argcount Initarg/Wert-Paare.
  720.   { var reg9 object instance = Before(rest_args_pointer STACKop 1);
  721.     var reg8 object class = TheInstance(instance)->class; # Instanz der <standard-class>
  722.     var reg7 object slots = TheClass(class)->slots; # Liste aller Slots (als Slot-Definitionen)
  723.     while (consp(slots))
  724.       { var reg6 object slot = Car(slots);
  725.         slots = Cdr(slots);
  726.         # Suche ob der Slot durch die Initargs initialisiert wird:
  727.         { var reg5 object l = TheSvector(slot)->data[2]; # (slotdef-initargs slot)
  728.           var reg3 object* ptr = rest_args_pointer;
  729.           var reg4 uintC count;
  730.           dotimesC(count,argcount,
  731.             { var reg2 object initarg = NEXT(ptr);
  732.               # Suche initarg in l
  733.               var reg1 object lr = l;
  734.               while (consp(lr))
  735.                 { if (eq(initarg,Car(lr))) goto initarg_found;
  736.                   lr = Cdr(lr);
  737.                 }
  738.               NEXT(ptr);
  739.             });
  740.           goto initarg_not_found;
  741.           initarg_found:
  742.           value1 = NEXT(ptr);
  743.           goto fill_slot;
  744.         }
  745.         initarg_not_found:
  746.         # Nicht gefunden -> erst auf (slot-boundp instance slotname) testen:
  747.         { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
  748.           if (!eq(*ptr_to_slot(Before(rest_args_pointer STACKop 1),slotinfo),unbound))
  749.             goto slot_done;
  750.         }
  751.         # Slot hat noch keinen Wert. Evtl. die Initform auswerten:
  752.         { var reg3 object init = TheSvector(slot)->data[4]; # (slotdef-initer slot)
  753.           if (atomp(init)) goto slot_done;
  754.           # Slot in slot-names suchen:
  755.           { var reg1 object slotnames = Before(rest_args_pointer);
  756.             if (eq(slotnames,T)) goto eval_init;
  757.            {var reg2 object slotname = TheSvector(slot)->data[0]; # (slotdef-name slot)
  758.             while (consp(slotnames))
  759.               { if (eq(Car(slotnames),slotname)) goto eval_init;
  760.                 slotnames = Cdr(slotnames);
  761.               }
  762.             goto slot_done;
  763.           }}
  764.           eval_init:
  765.           # Die Initform auswerten:
  766.           if (!nullp(Car(init)))
  767.             { pushSTACK(slots); pushSTACK(slot);
  768.               funcall(Car(init),0);
  769.               slot = popSTACK(); slots = popSTACK();
  770.             }
  771.             else
  772.             { value1 = Cdr(init); }
  773.         }
  774.         fill_slot:
  775.         # Slot mit value1 initialisieren:
  776.         { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
  777.           *ptr_to_slot(Before(rest_args_pointer STACKop 1),slotinfo) = value1;
  778.         }
  779.         slot_done: ;
  780.   }   }
  781.   value1 = Before(rest_args_pointer STACKop 1); mv_count=1; # Instanz als Wert
  782.   set_args_end_pointer(rest_args_pointer STACKop 2); # STACK aufräumen
  783. }
  784.  
  785. LISPFUN(reinitialize_instance,1,0,rest,nokey,0,NIL)
  786. # (CLOS::%REINITIALIZE-INSTANCE instance &rest initargs)
  787. # instance ist eine Instanz von <standard-object>, initargs eine paarige Liste.
  788. # Das ist die primäre Methode von CLOS:REINITIALIZE-INSTANCE.
  789. # vgl. clos.lsp
  790. # (defmethod reinitialize-instance ((instance standard-object) &rest initargs &key &allow-other-keys)
  791. #   (let ((h (gethash (class-of instance) *reinitialize-instance-table*)))
  792. #     (if h
  793. #       (progn
  794. #         ; 28.1.9.2. validity of initialization arguments
  795. #         (let ((valid-keywords (car h)))
  796. #           (sys::keyword-test initargs valid-keywords)
  797. #         )
  798. #         (if (not (eq (cdr h) #'clos::%shared-initialize))
  799. #           ; effektive Methode von shared-initialize anwenden:
  800. #           (apply (cdr h) instance 'NIL initargs)
  801. #           ; clos::%shared-initialize mit slot-names=NIL läßt sich vereinfachen:
  802. #           (progn
  803. #             (dolist (slot (class-slots (class-of instance)))
  804. #               (let ((slotname (slotdef-name slot)))
  805. #                 (multiple-value-bind (init-key init-value foundp)
  806. #                     (get-properties initargs (slotdef-initargs slot))
  807. #                   (declare (ignore init-key))
  808. #                   (if foundp
  809. #                     (setf (slot-value instance slotname) init-value)
  810. #             ) ) ) )
  811. #             instance
  812. #       ) ) )
  813. #       (apply #'initial-reinitialize-instance instance initargs)
  814. # ) ) )
  815. { var reg9 object instance = Before(rest_args_pointer);
  816.   var reg8 object class = TheInstance(instance)->class; # Instanz der <standard-class>
  817.   # (GETHASH class *REINITIALIZE-INSTANCE-TABLE*) suchen:
  818.   { var reg5 object info = gethash(class,Symbol_value(S(reinitialize_instance_table)));
  819.     if (eq(info,nullobj))
  820.       # Hash-Tabellen-Eintrag neu berechnen. Siehe clos.lsp.
  821.       { funcall(S(initial_reinitialize_instance),argcount+1); return; }
  822.     # Keywords überprüfen:
  823.     if (!((argcount%2) == 0))
  824.       { var reg1 object arglist = listof(argcount);
  825.         pushSTACK(arglist);
  826.         //: DEUTSCH "REINITIALIZE-INSTANCE: Keyword-Argumentliste ~ hat ungerade Länge."
  827.         //: ENGLISH "REINITIALIZE-INSTANCE: keyword argument list ~ has an odd length"
  828.         //: FRANCAIS "REINITIALIZE-INSTANCE : La liste de mots clé ~ est de longueur impaire."
  829.         fehler(error, GETTEXT("REINITIALIZE-INSTANCE: keyword argument list ~ has an odd length"));
  830.       }
  831.     argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
  832.     keyword_test(S(reinitialize_instance),rest_args_pointer,argcount,Car(info));
  833.   # Stackaufbau: instance, slot-names, argcount Initarg/Wert-Paare.
  834.    {var reg6 object fun = Cdr(info);
  835.     if (!eq(fun,L(shared_initialize)))
  836.       { # initargs im Stack um 1 nach unten schieben, dann fun aufrufen:
  837.         var reg1 object* ptr = rest_args_pointer;
  838.         var reg2 object last = NIL;
  839.         var reg4 uintC count;
  840.         dotimesC(count,argcount,
  841.           { var reg3 object next = Next(ptr); NEXT(ptr) = last;
  842.             last = Next(ptr); NEXT(ptr) = next;
  843.           });
  844.         pushSTACK(last);
  845.         funcall(fun,2*argcount+2);
  846.         return;
  847.       }
  848.   }}
  849.   # CLOS::%SHARED-INITIALIZE mit slot-names=NIL läßt sich vereinfachen:
  850.   { var reg7 object slots = TheClass(class)->slots; # Liste aller Slots (als Slot-Definitionen)
  851.     while (consp(slots))
  852.       { var reg6 object slot = Car(slots);
  853.         slots = Cdr(slots);
  854.         # Suche ob der Slot durch die Initargs initialisiert wird:
  855.         { var reg5 object l = TheSvector(slot)->data[2]; # (slotdef-initargs slot)
  856.           var reg3 object* ptr = rest_args_pointer;
  857.           var reg4 uintC count;
  858.           dotimesC(count,argcount,
  859.             { var reg2 object initarg = NEXT(ptr);
  860.               # Suche initarg in l
  861.               var reg1 object lr = l;
  862.               while (consp(lr))
  863.                 { if (eq(initarg,Car(lr))) goto initarg_found;
  864.                   lr = Cdr(lr);
  865.                 }
  866.               NEXT(ptr);
  867.             });
  868.           goto slot_done;
  869.           initarg_found:
  870.          {var reg1 object value = NEXT(ptr);
  871.           # Slot mit value initialisieren:
  872.           {var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
  873.            *ptr_to_slot(Before(rest_args_pointer STACKop 1),slotinfo) = value;
  874.         }}}
  875.         slot_done: ;
  876.   }   }
  877.   value1 = Before(rest_args_pointer); mv_count=1; # Instanz als Wert
  878.   set_args_end_pointer(rest_args_pointer STACKop 1); # STACK aufräumen
  879. }
  880.  
  881. # (CLOS::%INITIALIZE-INSTANCE instance &rest initargs)
  882. # instance ist eine Instanz von <standard-object>, initargs eine paarige Liste.
  883. # Das ist die primäre Methode von CLOS:INITIALIZE-INSTANCE.
  884. # vgl. clos.lsp
  885. # (defmethod initialize-instance ((instance standard-object) &rest initargs)
  886. #   (let ((h (gethash class *make-instance-table*)))
  887. #     (if h
  888. #       (if (not (eq (cddr h) #'clos::%shared-initialize))
  889. #         ; effektive Methode von shared-initialize anwenden:
  890. #         (apply (cddr h) instance 'T initargs)
  891. #         ; clos::%shared-initialize mit slot-names=T läßt sich vereinfachen:
  892. #         (progn
  893. #           (dolist (slot (class-slots (class-of instance)))
  894. #             (let ((slotname (slotdef-name slot)))
  895. #               (multiple-value-bind (init-key init-value foundp)
  896. #                   (get-properties initargs (slotdef-initargs slot))
  897. #                 (declare (ignore init-key))
  898. #                 (if foundp
  899. #                   (setf (slot-value instance slotname) init-value)
  900. #                   (unless (slot-boundp instance slotname)
  901. #                     (let ((init (slotdef-initer slot)))
  902. #                       (when init
  903. #                         (setf (slot-value instance slotname)
  904. #                               (if (car init) (funcall (car init)) (cdr init))
  905. #           ) ) ) ) ) ) ) )
  906. #           instance
  907. #       ) )
  908. #       (apply #'initial-initialize-instance instance initargs)
  909. # ) ) )
  910. local Values do_initialize_instance (object info, object* rest_args_pointer, uintC argcount);
  911. LISPFUN(initialize_instance,1,0,rest,nokey,0,NIL)
  912. { var reg9 object instance = Before(rest_args_pointer);
  913.   var reg8 object class = TheInstance(instance)->class; # Instanz der <standard-class>
  914.   # (GETHASH class *MAKE-INSTANCE-TABLE*) suchen:
  915.   { var reg5 object info = gethash(class,Symbol_value(S(make_instance_table)));
  916.     if (eq(info,nullobj))
  917.       # Hash-Tabellen-Eintrag neu berechnen. Siehe clos.lsp.
  918.       { funcall(S(initial_initialize_instance),argcount+1); return; }
  919.     if (!((argcount%2) == 0))
  920.       { var reg1 object arglist = listof(argcount);
  921.         pushSTACK(arglist);
  922.         //: DEUTSCH "INITIALIZE-INSTANCE: Keyword-Argumentliste ~ hat ungerade Länge."
  923.         //: ENGLISH "INITIALIZE-INSTANCE: keyword argument list ~ has an odd length"
  924.         //: FRANCAIS "INITIALIZE-INSTANCE : La liste de mots clé ~ est de longueur impaire."
  925.         fehler(error, GETTEXT("INITIALIZE-INSTANCE: keyword argument list ~ has an odd length"));
  926.       }
  927.     argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
  928.     return_Values do_initialize_instance(info,rest_args_pointer,argcount);
  929. } }
  930. local Values do_initialize_instance(info,rest_args_pointer,argcount)
  931.   var reg5 object info;
  932.   var reg8 object* rest_args_pointer;
  933.   var reg8 uintC argcount;
  934.   { # Stackaufbau: instance, argcount Initarg/Wert-Paare.
  935.     { var reg6 object fun = Cdr(Cdr(info));
  936.       if (!eq(fun,L(shared_initialize)))
  937.         { # initargs im Stack um 1 nach unten schieben, dann fun aufrufen:
  938.           var reg1 object* ptr = rest_args_pointer;
  939.           var reg2 object last = T;
  940.           var reg4 uintC count;
  941.           dotimesC(count,argcount,
  942.             { var reg3 object next = Next(ptr); NEXT(ptr) = last;
  943.               last = Next(ptr); NEXT(ptr) = next;
  944.             });
  945.           pushSTACK(last);
  946.           funcall(fun,2*argcount+2);
  947.           return;
  948.         }
  949.     }
  950.     # CLOS::%SHARED-INITIALIZE mit slot-names=T läßt sich vereinfachen:
  951.     { var reg10 object instance = Before(rest_args_pointer);
  952.       var reg9 object class = TheInstance(instance)->class; # Instanz der <standard-class>
  953.       var reg7 object slots = TheClass(class)->slots; # Liste aller Slots (als Slot-Definitionen)
  954.       while (consp(slots))
  955.         { var reg6 object slot = Car(slots);
  956.           slots = Cdr(slots);
  957.           # Suche ob der Slot durch die Initargs initialisiert wird:
  958.           { var reg5 object l = TheSvector(slot)->data[2]; # (slotdef-initargs slot)
  959.             var reg3 object* ptr = rest_args_pointer;
  960.             var reg4 uintC count;
  961.             dotimesC(count,argcount,
  962.               { var reg2 object initarg = NEXT(ptr);
  963.                 # Suche initarg in l
  964.                 var reg1 object lr = l;
  965.                 while (consp(lr))
  966.                   { if (eq(initarg,Car(lr))) goto initarg_found;
  967.                     lr = Cdr(lr);
  968.                   }
  969.                 NEXT(ptr);
  970.               });
  971.             goto initarg_not_found;
  972.             initarg_found:
  973.             value1 = NEXT(ptr);
  974.             goto fill_slot;
  975.           }
  976.           initarg_not_found:
  977.           # Nicht gefunden -> erst auf (slot-boundp instance slotname) testen:
  978.           { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
  979.             if (!eq(*ptr_to_slot(Before(rest_args_pointer),slotinfo),unbound))
  980.               goto slot_done;
  981.           }
  982.           # Slot hat noch keinen Wert. Die Initform auswerten:
  983.           { var reg2 object init = TheSvector(slot)->data[4]; # (slotdef-initer slot)
  984.             if (atomp(init)) goto slot_done;
  985.             if (!nullp(Car(init)))
  986.               { pushSTACK(slots); pushSTACK(slot);
  987.                 funcall(Car(init),0);
  988.                 slot = popSTACK(); slots = popSTACK();
  989.               }
  990.               else
  991.               { value1 = Cdr(init); }
  992.           }
  993.           fill_slot:
  994.           # Slot mit value1 initialisieren:
  995.           { var reg1 object slotinfo = TheSvector(slot)->data[3]; # (slotdef-location slot)
  996.             *ptr_to_slot(Before(rest_args_pointer),slotinfo) = value1;
  997.           }
  998.           slot_done: ;
  999.     }   }
  1000.     value1 = Before(rest_args_pointer); mv_count=1; # Instanz als Wert
  1001.     set_args_end_pointer(rest_args_pointer STACKop 1); # STACK aufräumen
  1002.   }
  1003.  
  1004. #ifdef RISCOS_CCBUG
  1005.   #pragma -z0
  1006. #endif
  1007. LISPFUN(make_instance,1,0,rest,nokey,0,NIL)
  1008. # (CLOS::%MAKE-INSTANCE class &rest initargs)
  1009. # class ist eine Instanz der <standard-class>,
  1010. # initargs eine (hoffentlich paarige) Liste.
  1011. # vgl. clos.lsp
  1012. # (defun %make-instance (class &rest initargs)
  1013. #   ; 28.1.9.3., 28.1.9.4. default-initargs zur Kenntnis nehmen:
  1014. #   (dolist (default-initarg (class-default-initargs class))
  1015. #     (let ((nothing default-initarg))
  1016. #       (when (eq (getf initargs (car default-initarg) nothing) nothing)
  1017. #         (setq initargs
  1018. #               (append initargs
  1019. #                 (list (car default-initarg)
  1020. #                       (let ((init (cdr default-initarg)))
  1021. #                         (if (car init) (funcall (car init)) (cdr init))
  1022. #   ) ) ) )     ) )     )
  1023. #   (let ((h (gethash class *make-instance-table*)))
  1024. #     (if h
  1025. #       (progn
  1026. #         ; 28.1.9.2. validity of initialization arguments
  1027. #         (let ((valid-keywords (car h)))
  1028. #           (sys::keyword-test initargs valid-keywords)
  1029. #         )
  1030. #         (let ((instance (std-allocate-instance class)))
  1031. #           (if (not (eq (cadr h) #'clos::%initialize-instance))
  1032. #             ; effektive Methode von initialize-instance anwenden:
  1033. #             (apply (cadr h) instance initargs)
  1034. #             ; clos::%initialize-instance läßt sich vereinfachen (man braucht
  1035. #             ; nicht nochmal in *make-instance-table* nachzusehen):
  1036. #             (if (not (eq (cddr h) #'clos::%shared-initialize))
  1037. #               ; effektive Methode von shared-initialize anwenden:
  1038. #               (apply (cddr h) instance 'T initargs)
  1039. #               ...
  1040. #             )
  1041. #       ) ) )
  1042. #       (apply #'initial-make-instance class initargs)
  1043. # ) ) )
  1044. { if (!((argcount%2) == 0))
  1045.     { var reg1 object arglist = listof(argcount);
  1046.       pushSTACK(arglist);
  1047.       //: DEUTSCH "MAKE-INSTANCE: Keyword-Argumentliste ~ hat ungerade Länge."
  1048.       //: ENGLISH "MAKE-INSTANCE: keyword argument list ~ has an odd length"
  1049.       //: FRANCAIS "MAKE-INSTANCE : La liste de mots clé ~ est de longueur impaire."
  1050.       fehler(error, GETTEXT("MAKE-INSTANCE: keyword argument list ~ has an odd length"));
  1051.     }
  1052.   argcount = argcount/2; # Anzahl der Initarg/Wert-Paare
  1053.   # Stackaufbau: class, argcount Initarg/Wert-Paare.
  1054.   # Default-Initargs anfügen:
  1055.   { var reg6 object class = Before(rest_args_pointer);
  1056.     var reg5 object l = TheClass(class)->default_initargs;
  1057.     while (consp(l))
  1058.       { var reg4 object default_initarg = Car(l);
  1059.         l = Cdr(l);
  1060.        {var reg3 object key = Car(default_initarg);
  1061.         # Suche key unter den bisherigen Initargs:
  1062.         { var reg1 object* ptr = rest_args_pointer;
  1063.           var reg2 uintC count;
  1064.           dotimesC(count,argcount,
  1065.             { if (eq(NEXT(ptr),key)) goto key_found;
  1066.               NEXT(ptr);
  1067.             });
  1068.         }
  1069.         # Nicht gefunden
  1070.         pushSTACK(key); # Initarg in den Stack
  1071.         { var reg1 object init = Cdr(default_initarg);
  1072.           if (!nullp(Car(init)))
  1073.             { pushSTACK(l);
  1074.               funcall(Car(init),0); # Default auswerten
  1075.               l = STACK_0;
  1076.               STACK_0 = value1; # Wert in den Stack
  1077.             }
  1078.             else
  1079.             { pushSTACK(Cdr(init)); } # Default in den Stack
  1080.         }
  1081.         argcount++;
  1082.         key_found: ;
  1083.       }}
  1084.   }
  1085.   # (GETHASH class *MAKE-INSTANCE-TABLE*) suchen:
  1086.   { var reg6 object class = Before(rest_args_pointer);
  1087.     var reg7 object info = gethash(class,Symbol_value(S(make_instance_table)));
  1088.     if (eq(info,nullobj))
  1089.       # Hash-Tabellen-Eintrag neu berechnen. Siehe clos.lsp.
  1090.       { return_Values funcall(S(initial_make_instance),2*argcount+1); }
  1091.       else
  1092.       { # Keywords überprüfen:
  1093.         keyword_test(S(make_instance),rest_args_pointer,argcount,Car(info));
  1094.         # (CLOS::ALLOCATE-STD-INSTANCE class (class-instance-slot-count class))
  1095.         pushSTACK(info);
  1096.         pushSTACK(class); pushSTACK(TheClass(class)->instance_slot_count);
  1097.         C_allocate_std_instance();
  1098.         info = popSTACK();
  1099.         # Effektive Methode von INITIALIZE-INSTANCE anwenden:
  1100.         Before(rest_args_pointer) = value1; # instance als 1. Argument statt class
  1101.        {var reg1 object fun = Car(Cdr(info));
  1102.         if (!eq(fun,L(initialize_instance)))
  1103.           { return_Values funcall(fun,2*argcount+1); }
  1104.           else
  1105.           # CLOS::%INITIALIZE-INSTANCE läßt sich vereinfachen (man braucht
  1106.           # nicht nochmal in *make-instance-table* nachzusehen):
  1107.           { return_Values do_initialize_instance(info,rest_args_pointer,argcount); }
  1108.         # Deren Wert ist die Instanz.
  1109.       }}
  1110. } }
  1111. #ifdef RISCOS_CCBUG
  1112.   #pragma -z1
  1113. #endif
  1114.  
  1115. # ==============================================================================
  1116.  
  1117.