home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / clos.lsp < prev    next >
Lisp/Scheme  |  1977-12-31  |  175KB  |  4,077 lines

  1. ;;;; Common Lisp Object System für CLISP
  2. ;;;; Bruno Haible 21.8.1993
  3.  
  4. ; Zur Benutzung reicht ein einfaches (USE-PACKAGE "CLOS").
  5.  
  6.  
  7. (in-package "LISP")
  8. (export '(clos))
  9. (pushnew 'clos *features*)
  10.  
  11.  
  12. (in-package "SYSTEM") ; Trotz DEFPACKAGE nötig!
  13.  
  14. (defpackage "CLOS"
  15.  
  16. (:import-from "SYSTEM"
  17.   ;; Import:
  18.   sys::error-of-type                                 ; in error.d definiert
  19.   sys::function-name-p                               ; in control.d definiert
  20.   sys::block-name                                    ; in init.lsp definiert
  21. ; clos::generic-function-p                           ; in predtype.d definiert
  22. ; clos::class-p clos:class-of clos:find-class        ; in predtype.d definiert
  23. ; clos::std-instance-p clos::allocate-std-instance   ; in record.d definiert
  24. ; clos:slot-value clos::set-slot-value               ; in record.d definiert
  25. ; clos:slot-boundp clos:slot-makunbound              ; in record.d definiert
  26. ; clos:slot-exists-p                                 ; in record.d definiert
  27. ; clos::class-gethash clos::class-tuple-gethash      ; in hashtabl.d definiert
  28.   compiler::memq compiler::*keyword-package*         ; in compiler.lsp definiert
  29.   compiler::%generic-function-lambda                 ; in compiler.lsp definiert
  30.   compiler::%optimize-function-lambda                ; in compiler.lsp definiert
  31. ; clos:generic-flet clos:generic-labels              ; in compiler.lsp behandelt
  32.   ;; Export:
  33. ; clos::class    ; als Property in predtype.d und type.lsp, compiler.lsp benutzt
  34. ; clos:standard-generic-function ; in predtype.d, type.lsp, compiler.lsp benutzt
  35. ; clos:slot-missing clos:slot-unbound  ; von record.d aufgerufen
  36. ; clos::*make-instance-table*          ; von record.d benutzt
  37. ; clos::*reinitialize-instance-table*  ; von record.d benutzt
  38. ; clos::initial-reinitialize-instance  ; von record.d aufgerufen
  39. ; clos::initial-initialize-instance    ; von record.d aufgerufen
  40. ; clos::initial-make-instance          ; von record.d aufgerufen
  41. ; clos:print-object                    ; von io.d aufgerufen
  42. ; clos:describe-object                 ; von user2.lsp aufgerufen
  43. ; clos::define-structure-class         ; von defstruc.lsp aufgerufen
  44. ; clos::built-in-class-p               ; von type.lsp aufgerufen
  45. ; clos::subclassp                      ; von type.lsp aufgerufen, in compiler.lsp benutzt
  46. ; clos:class-name                      ; in type.lsp, compiler.lsp benutzt
  47. ; clos:find-class                      ; in compiler.lsp benutzt
  48. ; clos::defgeneric-lambdalist-callinfo ; von compiler.lsp aufgerufen
  49. ; clos::make-generic-function-form     ; von compiler.lsp aufgerufen
  50. )
  51.  
  52. ) ; defpackage
  53.  
  54. (in-package "CLOS")
  55.  
  56. ;;; Exportierungen: ** auch in init.lsp ** !
  57. (export '(
  58.   ;; Namen von Funktionen und Macros:
  59.   slot-value slot-boundp slot-makunbound slot-exists-p with-slots with-accessors
  60.   find-class class-of defclass defmethod call-next-method next-method-p
  61.   defgeneric generic-function generic-flet generic-labels
  62.   class-name
  63.   no-applicable-method no-primary-method no-next-method
  64.   find-method add-method remove-method
  65.   compute-applicable-methods method-qualifiers function-keywords
  66.   slot-missing slot-unbound
  67.   print-object describe-object
  68.   make-instance initialize-instance reinitialize-instance shared-initialize
  69.   ;; Namen von Klassen:
  70.   standard-class structure-class built-in-class
  71.   standard-object standard-generic-function standard-method
  72.   ;; andere Symbole:
  73.   standard ; Methoden-Kombination
  74. ))
  75.  
  76.  
  77. ;;; Vorbemerkungen:
  78.  
  79. ;; Abkürzungen:
  80. ;; std = standard
  81. ;; gf = generic function
  82. ;; <...> = (class ...), meist = (find-class '...)
  83. ;; em = effective method
  84.  
  85.  
  86. ;;; Vordefinierte Klassen:
  87. ; Metaklassen:
  88. (defvar <standard-class>)              ; hier <structure-class>
  89. (defvar <structure-class>)             ; hier <structure-class>
  90. (defvar <built-in-class>)              ; hier <structure-class>
  91. ; Klassen:
  92. (defvar <standard-object>)             ; <standard-class>
  93. (defvar <standard-generic-function>)   ; <built-in-class>
  94. (defvar <standard-method>)             ; hier <structure-class>
  95. (defvar <array>)                       ; <built-in-class>
  96. (defvar <bit-vector>)                  ; <built-in-class>
  97. (defvar <character>)                   ; <built-in-class>
  98. (defvar <complex>)                     ; <built-in-class>
  99. (defvar <cons>)                        ; <built-in-class>
  100. (defvar <float>)                       ; <built-in-class>
  101. (defvar <function>)                    ; <built-in-class>
  102. (defvar <hash-table>)                  ; <built-in-class>
  103. (defvar <integer>)                     ; <built-in-class>
  104. (defvar <list>)                        ; <built-in-class>
  105. (defvar <null>)                        ; <built-in-class>
  106. (defvar <number>)                      ; <built-in-class>
  107. (defvar <package>)                     ; <built-in-class>
  108. (defvar <pathname>)                    ; <built-in-class>
  109. #+LOGICAL-PATHNAMES
  110. (defvar <logical-pathname>)            ; <built-in-class>
  111. (defvar <random-state>)                ; <built-in-class>
  112. (defvar <ratio>)                       ; <built-in-class>
  113. (defvar <rational>)                    ; <built-in-class>
  114. (defvar <readtable>)                   ; <built-in-class>
  115. (defvar <real>)                        ; <built-in-class>
  116. (defvar <sequence>)                    ; <built-in-class>
  117. (defvar <stream>)                      ; <built-in-class>
  118. (defvar <file-stream>)                 ; <built-in-class>
  119. (defvar <synonym-stream>)              ; <built-in-class>
  120. (defvar <broadcast-stream>)            ; <built-in-class>
  121. (defvar <concatenated-stream>)         ; <built-in-class>
  122. (defvar <two-way-stream>)              ; <built-in-class>
  123. (defvar <echo-stream>)                 ; <built-in-class>
  124. (defvar <string-stream>)               ; <built-in-class>
  125. (defvar <string>)                      ; <built-in-class>
  126. (defvar <symbol>)                      ; <built-in-class>
  127. (defvar <t>)                           ; <built-in-class>
  128. (defvar <vector>)                      ; <built-in-class>
  129.  
  130.  
  131. ;;; Low-Level-Repräsentation:
  132.  
  133. ;; Im Runtime-System gibt es den Typ "CLOS-Instanz".
  134. ;; Erste Komponente ist die Klasse.
  135.  
  136. ;; Klassen sind Structures vom Typ CLASS,
  137. ;;   erste Komponente ist die Metaklasse, zweite Komponente der Name.
  138.  
  139. ;; Der "Wert" eines Slots, der unbound ist, ist #<UNBOUND> - was sonst?
  140.  
  141. ;; siehe RECORD.D :
  142. ; (STD-INSTANCE-P obj) testet, ob ein Objekt eine CLOS-Instanz ist.
  143. ; (ALLOCATE-STD-INSTANCE class n) liefert eine CLOS-Instanz mit Klasse class
  144. ; und n-1 zusätzlichen Slots.
  145. ;; siehe IO.D :
  146. ; CLOS-Instanzen werden via (PRINT-OBJECT object stream) ausgegeben.
  147.  
  148. ; Eine Instanz für ein Objekt der Metaklasse <standard-class> besorgen:
  149. (defmacro std-allocate-instance (class)
  150.   `(allocate-std-instance ,class (class-instance-slot-count ,class))
  151. )
  152.  
  153.  
  154. ;;; globale Verwaltung von Klassen und ihren Namen:
  155.  
  156. #| ; siehe PREDTYPE.D
  157. (defun find-class (symbol &optional (errorp t) environment)
  158.   (declare (ignore environment)) ; was sollte das Environment bedeuten?
  159.   (unless (symbolp symbol)
  160.     (error-of-type 'type-error
  161.       :datum symbol :expected-type 'symbol
  162.       #L{
  163.       DEUTSCH "~S: Argument ~S ist kein Symbol."
  164.       ENGLISH "~S: argument ~S is not a symbol"
  165.       FRANCAIS "~S : L'argument ~S n'est pas un symbole."
  166.       }
  167.       'find-class symbol
  168.   ) )
  169.   (let ((class (get symbol 'CLASS)))
  170.     (if (not (class-p class))
  171.       (if errorp
  172.         (error-of-type 'error
  173.           #L{
  174.           DEUTSCH "~S: ~S benennt keine Klasse."
  175.           ENGLISH "~S: ~S does not name a class"
  176.           FRANCAIS "~S : ~S n'est pas le nom d'une classe."
  177.           }
  178.           'find-class symbol
  179.         )
  180.         nil
  181.       )
  182.       class
  183. ) ) )
  184. |#
  185.  
  186. (defun (setf find-class) (new-value symbol &optional errorp environment)
  187.   (declare (ignore errorp environment)) ; was sollte das Environment bedeuten?
  188.   (unless (symbolp symbol)
  189.     (error-of-type 'type-error
  190.       :datum symbol :expected-type 'symbol
  191.       #L{
  192.       DEUTSCH "~S: Argument ~S ist kein Symbol."
  193.       ENGLISH "~S: argument ~S is not a symbol"
  194.       FRANCAIS "~S : L'argument ~S n'est pas un symbole."
  195.       }
  196.       '(setf find-class) symbol
  197.   ) )
  198.   (unless (class-p new-value)
  199.     (error-of-type 'type-error
  200.       :datum new-value :expected-type 'class
  201.       #L{
  202.       DEUTSCH "~S: ~S ist keine Klasse."
  203.       ENGLISH "~S: ~S is not a class"
  204.       FRANCAIS "~S : ~S n'est pas une classe."
  205.       }
  206.       '(setf find-class) new-value
  207.   ) )
  208.   (let ((h (get symbol 'CLASS)))
  209.     (when (class-p h)
  210.       (when (and (built-in-class-p h) (eq (class-name h) symbol)) ; auch Structure-Klassen schützen??
  211.         (error-of-type 'error
  212.           #L{
  213.           DEUTSCH "~S: Built-In-Klasse ~S kann nicht umdefiniert werden."
  214.           ENGLISH "~S: cannot redefine built-in class ~S"
  215.           FRANCAIS "~S : La classe prédéfinie ~S ne peut être redéfinie."
  216.           }
  217.           '(setf find-class) h
  218.       ) )
  219.       (when (sys::exported-lisp-symbol-p symbol)
  220.         (cerror 
  221.                 #L{
  222.                 DEUTSCH "Die alte Definition wird weggeworfen."
  223.                 ENGLISH "The old definition will be lost"
  224.                 FRANCAIS "L'ancienne définition sera perdue."
  225.                 }
  226.                 #L{
  227.                 DEUTSCH "~S: Die COMMON-LISP-Klasse ~S wird umdefiniert."
  228.                 ENGLISH "~S: Redefining the COMMON LISP class ~S"
  229.                 FRANCAIS "~S : La classe ~S de COMMON-LISP va être redéfinie."
  230.                 }
  231.                 '(setf find-class) symbol
  232.   ) ) ) )
  233.   (setf (get symbol 'CLASS) new-value)
  234. )
  235.  
  236. ; (CLASS-OF object) siehe PREDTYPE.D, benutzt Property CLASS.
  237.  
  238.  
  239. ;;; Slots:
  240.  
  241. #|
  242. ;; So könnten die Zugriffsfunktionen aussehen, wenn man SLOT-VALUE-USING-CLASS
  243. ;; verwendet.
  244.  
  245. ; Zugriff auf Slots von Objekten der Metaklasse <standard-class>:
  246. (defun std-slot-value (instance slot-name)
  247.   (declare (compile))
  248.   (let* ((class (class-of instance))
  249.          (slot-location (gethash slot-name (class-slot-location-table class))))
  250.     ((lambda (value)
  251.        (if (eq value unbound)
  252.          (slot-unbound class instance slot-name)
  253.          value
  254.      ) )
  255.      (cond ((null slot-location)
  256.             (slot-missing class instance slot-name 'slot-value)
  257.            )
  258.            ((atom slot-location)
  259.             ; access local slot
  260.             (sys::%record-ref instance slot-location)
  261.            )
  262.            (t
  263.             ; access shared slot
  264.             (svref (class-shared-slots (car slot-location)) (cdr slot-location))
  265.            )
  266.     ))
  267. ) )
  268. (defun std-setf-slot-value (instance slot-name new-value)
  269.   (let* ((class (class-of instance))
  270.          (slot-location (gethash slot-name (class-slot-location-table class))))
  271.     (cond ((null slot-location)
  272.            (slot-missing class instance slot-name 'setf new-value)
  273.           )
  274.           ((atom slot-location)
  275.            ; access local slot
  276.            (sys::%record-store instance slot-location new-value)
  277.           )
  278.           (t
  279.            ; access shared slot
  280.            (setf (svref (class-shared-slots (car slot-location)) (cdr slot-location))
  281.                  new-value
  282.           ))
  283. ) ) )
  284. (defun std-slot-boundp (instance slot-name)
  285.   (declare (compile))
  286.   (let* ((class (class-of instance))
  287.          (slot-location (gethash slot-name (class-slot-location-table class))))
  288.     (cond ((null slot-location)
  289.            (slot-missing class instance slot-name 'slot-boundp)
  290.           )
  291.           ((atom slot-location)
  292.            ; access local slot
  293.            (not (eq (sys::%record-ref instance slot-location) unbound))
  294.           )
  295.           (t
  296.            ; access shared slot
  297.            (not (eq (svref (class-shared-slots (car slot-location)) (cdr slot-location)) unbound))
  298.           )
  299. ) ) )
  300. (defun std-slot-makunbound (instance slot-name)
  301.   (declare (compile))
  302.   (let* ((class (class-of instance))
  303.          (slot-location (gethash slot-name (class-slot-location-table class))))
  304.     (cond ((null slot-location)
  305.            (slot-missing class instance slot-name 'slot-makunbound)
  306.           )
  307.           ((atom slot-location)
  308.            ; access local slot
  309.            (sys::%record-store instance slot-location unbound)
  310.           )
  311.           (t
  312.            ; access shared slot
  313.            (setf (svref (class-shared-slots (car slot-location)) (cdr slot-location))
  314.                  unbound
  315.           ))
  316. ) ) )
  317. (defun std-slot-exists-p (instance slot-name)
  318.   (and (gethash slot-name (class-slot-location-table (class-of instance))) t)
  319. )
  320.  
  321. ;; Zugriff auf Slots allgemein:
  322. (defun slot-value (object slot-name)
  323.   (let ((class (class-of object)))
  324.     ; Metaklasse <standard-class> gesondert betrachten
  325.     ; aus Effizienzgründen und wegen Bootstrapping
  326.     (if (eq (class-of class) <standard-class>)
  327.       (std-slot-value object slot-name)
  328.       (slot-value-using-class class object slot-name)
  329. ) ) )
  330. (defun (setf slot-value) (new-value object slot-name)
  331.   (let ((class (class-of object)))
  332.     ; Metaklasse <standard-class> gesondert betrachten
  333.     ; aus Effizienzgründen und wegen Bootstrapping
  334.     (if (eq (class-of class) <standard-class>)
  335.       (std-setf-slot-value object slot-name new-value)
  336.       (setf-slot-value-using-class new-value class object slot-name)
  337. ) ) )
  338. (defun slot-boundp (object slot-name)
  339.   (let ((class (class-of object)))
  340.     ; Metaklasse <standard-class> gesondert betrachten
  341.     ; aus Effizienzgründen und wegen Bootstrapping
  342.     (if (eq (class-of class) <standard-class>)
  343.       (std-slot-boundp object slot-name)
  344.       (slot-boundp-using-class class object slot-name)
  345. ) ) )
  346. (defun slot-makunbound (object slot-name)
  347.   (let ((class (class-of object)))
  348.     ; Metaklasse <standard-class> gesondert betrachten
  349.     ; aus Effizienzgründen und wegen Bootstrapping
  350.     (if (eq (class-of class) <standard-class>)
  351.       (std-slot-makunbound object slot-name)
  352.       (slot-makunbound-using-class class object slot-name)
  353. ) ) )
  354. (defun slot-exists-p (object slot-name)
  355.   (let ((class (class-of object)))
  356.     ; Metaklasse <standard-class> gesondert betrachten
  357.     ; aus Effizienzgründen und wegen Bootstrapping
  358.     (if (eq (class-of class) <standard-class>)
  359.       (std-slot-exists-p object slot-name)
  360.       (slot-exists-p-using-class class object slot-name)
  361. ) ) )
  362.  
  363. (defun slot-value-using-class (class object slot-name)
  364.   (no-slot-error class object slot-name)
  365. )
  366. (defun setf-slot-value-using-class (new-value class object slot-name)
  367.   (declare (ignore new-value))
  368.   (no-slot-error class object slot-name)
  369. )
  370. (defun slot-boundp-using-class (class object slot-name)
  371.   (no-slot-error class object slot-name)
  372. )
  373. (defun slot-makunbound-using-class (class object slot-name)
  374.   (no-slot-error class object slot-name)
  375. )
  376. (defun slot-exists-p-using-class (class object slot-name)
  377.   (no-slot-error class object slot-name)
  378. )
  379.  
  380. (defun no-slot-error (class object slot-name)
  381.   (declare (ignore slot-name))
  382.   (error-of-type 'error
  383.     #L{
  384.     DEUTSCH "Instanz ~S der Klasse ~S hat keine Slots (falsche Metaklasse)"
  385.     ENGLISH "instance ~S of class ~S has no slots (wrong metaclass)"
  386.     FRANCAIS "L'objet ~S appartenant à la classe ~S n'a pas de composants (mauvaise classe méta)"
  387.     }
  388.     object class
  389. ) )
  390. |#
  391.  
  392. ;; Der Effizienz halber - wir wollen den Test auf <standard-class> umgehen -
  393. ;; bekommen alle Klassen (egal ob standard- oder built-in-) eine
  394. ;; slot-location-table. Außerdem können wir hier mit unbound schlecht umgehen.
  395. ;; Daher sind
  396. ;;   slot-value, set-slot-value, slot-boundp, slot-makunbound, slot-exists-p
  397. ;; nun bereits in RECORD.D enthalten.
  398.  
  399. (defsetf slot-value set-slot-value)
  400.  
  401. ;; WITH-SLOTS
  402.  
  403. (defmacro with-slots (slot-entries instance-form &body body &environment env)
  404.   (let ((vars '())
  405.         (slots '()))
  406.     (unless (listp slot-entries)
  407.       (error-of-type 'program-error
  408.         #L{
  409.         DEUTSCH "~S: Das ist keine Liste von Slots: ~S"
  410.         ENGLISH "~S: not a list of slots: ~S"
  411.         FRANCAIS "~S : Pas une liste de composants: ~S"
  412.         }
  413.         'with-slots slot-entries
  414.     ) )
  415.     (dolist (slot slot-entries)
  416.       (let ((var slot))
  417.         (when (consp slot)
  418.           (unless (eql (length slot) 2)
  419.             (error-of-type 'program-error
  420.               #L{
  421.               DEUTSCH "~S: unzulässige Slot/Variablen-Bezeichnung ~S"
  422.               ENGLISH "~S: invalid slot and variable specification ~S"
  423.               FRANCAIS "~S : spécification invalide de composant et variable: ~S"
  424.               }
  425.               'with-slots slot
  426.           ) )
  427.           (setq var (first slot) slot (second slot))
  428.           (unless (symbolp var)
  429.             (error-of-type 'program-error
  430.               #L{
  431.               DEUTSCH "~S: Variable ~S sollte ein Symbol sein."
  432.               ENGLISH "~S: variable ~S should be a symbol"
  433.               FRANCAIS "~S : La variable ~S devrait être un symbole."
  434.               }
  435.               'with-slots var
  436.           ) )
  437.         )
  438.         (unless (symbolp slot)
  439.           (error-of-type 'program-error
  440.             #L{
  441.             DEUTSCH "~S: Slot-Name ~S sollte ein Symbol sein."
  442.             ENGLISH "~S: slot name ~S should be a symbol"
  443.             FRANCAIS "~S : Le nom de composant ~S devrait être un symbole."
  444.             }
  445.             'with-slots slot
  446.         ) )
  447.         (push var vars)
  448.         (push slot slots)
  449.     ) )
  450.     (multiple-value-bind (body-rest declarations) (sys::parse-body body nil env)
  451.       (let ((instance-var (gensym)))
  452.         `(LET ((,instance-var ,instance-form))
  453.            (SYMBOL-MACROLET
  454.              ,(mapcar #'(lambda (var slot)
  455.                           `(,var (SLOT-VALUE ,instance-var ',slot))
  456.                         )
  457.                       (nreverse vars) (nreverse slots)
  458.               )
  459.              ,@(if declarations `((DECLARE ,@declarations)))
  460.              ,@body-rest
  461.          ) )
  462. ) ) ) )
  463.  
  464. ;; WITH-ACCESSORS
  465.  
  466. (defmacro with-accessors (slot-entries instance-form &body body &environment env)
  467.   (unless (listp slot-entries)
  468.     (error-of-type 'program-error
  469.       #L{
  470.       DEUTSCH "~S: Das ist keine Liste von Slots: ~S"
  471.       ENGLISH "~S: not a list of slots: ~S"
  472.       FRANCAIS "~S : Pas une liste de composants: ~S"
  473.       }
  474.       'with-accessors slot-entries
  475.   ) )
  476.   (dolist (slot-entry slot-entries)
  477.     (unless (and (consp slot-entry) (eql (length slot-entry) 2))
  478.       (error-of-type 'program-error
  479.         #L{
  480.         DEUTSCH "~S: unzulässige Slot/Accessor-Bezeichnung ~S"
  481.         ENGLISH "~S: invalid slot and accessor specification ~S"
  482.         FRANCAIS "~S : spécification invalide de composant et accesseur: ~S"
  483.         }
  484.         'with-accessors slot-entry
  485.     ) )
  486.     (unless (symbolp (first slot-entry))
  487.       (error-of-type 'program-error
  488.         #L{
  489.         DEUTSCH "~S: Variable ~S sollte ein Symbol sein."
  490.         ENGLISH "~S: variable ~S should be a symbol"
  491.         FRANCAIS "~S : La variable ~S devrait être un symbole."
  492.         }
  493.         'with-accessors (first slot-entry)
  494.     ) )
  495.     (unless (symbolp (second slot-entry))
  496.       (error-of-type 'program-error
  497.         #L{
  498.         DEUTSCH "~S: Accessor-Name ~S sollte ein Symbol sein."
  499.         ENGLISH "~S: accessor name ~S should be a symbol"
  500.         FRANCAIS "~S : Le nom d'accesseur ~S devrait être un symbole."
  501.         }
  502.         'with-accessors (second slot-entry)
  503.     ) )
  504.   )
  505.   (multiple-value-bind (body-rest declarations) (sys::parse-body body nil env)
  506.     (let ((instance-var (gensym)))
  507.       `(LET ((,instance-var ,instance-form))
  508.          (SYMBOL-MACROLET
  509.            ,(mapcar #'(lambda (slot-entry)
  510.                         `(,(first slot-entry) (,(second slot-entry) ,instance-var))
  511.                       )
  512.                     slot-entries
  513.             )
  514.            ,@(if declarations `((DECLARE ,@declarations)))
  515.            ,@body-rest
  516.        ) )
  517. ) ) )
  518.  
  519.  
  520. ;;; Klassen
  521.  
  522. ; zum Bootstrappen
  523. (eval-when (compile load eval)
  524.   (defun define-structure-class (name) (declare (ignore name)) ) ; vorläufig
  525. )
  526. ; alle Spuren eines früher geladenen CLOS ausmerzen
  527. (eval-when (load eval)
  528.   (do-all-symbols (s) (remprop s 'CLASS))
  529. )
  530.  
  531. (defconstant empty-ht (make-hash-table :test #'eq :size 0))
  532.  
  533. (defstruct (class (:predicate nil) (:print-function print-class))
  534.   metaclass ; (class-of class) = (class-metaclass class), eine Klasse
  535.   classname ; (class-name class) = (class-classname class), ein Symbol
  536.   direct-superclasses ; Liste aller direkten Oberklassen
  537.   all-superclasses ; Hash-Tabelle aller Oberklassen (inkl. der Klasse selbst)
  538.   precedence-list ; angeordnete Liste aller Oberklassen (Klasse selbst zuerst)
  539.   (slot-location-table empty-ht) ; Hashtabelle Slotname -> wo der Slot sitzt
  540. )
  541.  
  542. (defstruct (built-in-class (:inherit class) (:conc-name "CLASS-") (:print-function print-class))
  543. )
  544. (proclaim '(notinline built-in-class-p))
  545.  
  546. (defstruct (structure-class (:inherit class) (:conc-name "CLASS-") (:print-function print-class))
  547. )
  548.  
  549. (defstruct (standard-class (:inherit class) (:conc-name "CLASS-") (:print-function print-class))
  550.   direct-slots             ; Liste der neu hinzugekommenen Slots (als Plisten)
  551.   slots                    ; Liste aller Slots (als Slot-Definitionen)
  552.   instance-slot-count      ; Anzahl der Slots der direkten Instanzen + 1
  553.   shared-slots             ; Simple-Vector mit den Werten aller Shared Slots
  554.   direct-default-initargs  ; Neu hinzugekommene Default-Initargs (als Pliste)
  555.   default-initargs         ; Default-Initargs (als Aliste Initarg -> Initer)
  556.   valid-initargs           ; Liste der gültigen Initargs
  557. )
  558.  
  559. ; Zugriff auf Slots von Instanzen der Klasse <class> mittels der
  560. ; defstruct-Accessoren, daher hier keine Bootstrapping-Probleme.
  561.  
  562. ; Weiter Bootstrapping
  563. (%defclos
  564.   ; Erkennungszeichen für CLASS-P
  565.   (svref (get 'class 'sys::defstruct-description) 0)
  566.   ; Built-In-Klassen für CLASS-OF
  567.   (vector 'array 'bit-vector 'character 'complex 'cons 'float 'function
  568.           'hash-table 'integer 'null 'package 'pathname
  569.           #+LOGICAL-PATHNAMES 'logical-pathname
  570.           'random-state 'ratio 'readtable 'standard-generic-function
  571.           'stream 'file-stream 'synonym-stream 'broadcast-stream
  572.           'concatenated-stream 'two-way-stream 'echo-stream 'string-stream
  573.           'string 'symbol 't 'vector
  574. ) )
  575.  
  576. (defun print-class (class stream depth)
  577.   (declare (ignore depth))
  578.   (print-unreadable-object (class stream :type t)
  579.     (write (class-classname class) :stream stream)
  580. ) )
  581.  
  582.  
  583. ;;; DEFCLASS
  584.  
  585. (defmacro defclass (name superclass-specs slot-specs &rest options)
  586.   (unless (symbolp name)
  587.     (error-of-type 'program-error
  588.       #L{
  589.       DEUTSCH "~S: Klassenname muß ein Symbol sein, nicht ~S"
  590.       ENGLISH "~S: class name ~S should be a symbol"
  591.       FRANCAIS "~S : Le nom de classe ~S devrait être un symbole."
  592.       }
  593.       'defclass name
  594.   ) )
  595.   (let* ((superclass-forms
  596.            (progn
  597.              (unless (listp superclass-specs)
  598.                (error-of-type 'program-error
  599.                  #L{
  600.                  DEUTSCH "~S ~S: Superklassen-Liste erwartet statt ~S"
  601.                  ENGLISH "~S ~S: expecting list of superclasses instead of ~S"
  602.                  FRANCAIS "~S ~S : on s'attend à une liste de classes supérieures au lieu de ~S"
  603.                  }
  604.                  'defclass name superclass-specs
  605.              ) )
  606.              (mapcar #'(lambda (superclass)
  607.                          (unless (symbolp superclass)
  608.                            (error-of-type 'program-error
  609.                              #L{
  610.                              DEUTSCH "~S ~S: Oberklassenname muß ein Symbol sein, nicht ~S"
  611.                              ENGLISH "~S ~S: superclass name ~S should be a symbol"
  612.                              FRANCAIS "~S ~S : Le nom d'une classe supérieure doit être un symbole et non ~S"
  613.                              }
  614.                              'defclass name superclass
  615.                          ) )
  616.                          `(FIND-CLASS ',superclass)
  617.                        )
  618.                      superclass-specs
  619.          ) ) )
  620.          (accessor-def-forms '())
  621.          (slot-forms
  622.            (let ((slot-names '()))
  623.              (unless (listp slot-specs)
  624.                (error-of-type 'program-error
  625.                  #L{
  626.                  DEUTSCH "~S ~S: Slotspezifikationen-Liste erwartet statt ~S"
  627.                  ENGLISH "~S ~S: expecting list of slot specifications instead of ~S"
  628.                  FRANCAIS "~S ~S : on s'attend à une liste de spécifications de composants au lieu de ~S"
  629.                  }
  630.                  'defclass name slot-specs
  631.              ) )
  632.              (mapcar #'(lambda (slot-spec)
  633.                          (let ((slot-name slot-spec) (slot-options '()))
  634.                            (when (consp slot-spec)
  635.                              (setq slot-name (car slot-spec) slot-options (cdr slot-spec))
  636.                            )
  637.                            (unless (symbolp slot-name)
  638.                              (error-of-type 'program-error
  639.                                #L{
  640.                                DEUTSCH "~S ~S: Slotname muß ein Symbol sein, nicht ~S"
  641.                                ENGLISH "~S ~S: slot name ~S should be a symbol"
  642.                                FRANCAIS "~S ~S : Le nom de composant ~S doit être un symbole et non ~S"
  643.                                }
  644.                                'defclass name slot-name
  645.                            ) )
  646.                            (if (member slot-name slot-names :test #'eq)
  647.                              (error-of-type 'program-error
  648.                                #L{
  649.                                DEUTSCH "~S ~S: Es kann nicht mehrere direkte Slots mit demselben Namen ~S geben."
  650.                                ENGLISH "~S ~S: There may be only one direct slot with the name ~S."
  651.                                FRANCAIS "~S ~S : Il ne peut pas y avoir plusieurs composants directs avec le même nom ~S."
  652.                                }
  653.                                'defclass name slot-name
  654.                              )
  655.                              (push slot-name slot-names)
  656.                            )
  657.                            (let ((accessors '())
  658.                                  (readers '())
  659.                                  (writers '())
  660.                                  (allocation '())
  661.                                  (initargs '())
  662.                                  (initform nil) (initer nil)
  663.                                  (types '())
  664.                                  (documentation nil))
  665.                              (when (oddp (length slot-options))
  666.                                (error-of-type 'program-error
  667.                                  #L{
  668.                                  DEUTSCH "~S ~S: Slot-Optionen zu Slot ~S sind nicht paarig."
  669.                                  ENGLISH "~S ~S: slot options for slot ~S don't come in pairs"
  670.                                  FRANCAIS "~S ~S : Les options pour le composant ~S ne viennent pas deux à deux."
  671.                                  }
  672.                                  'defclass name slot-name
  673.                              ) )
  674.                              (do ((optionsr slot-options (cddr optionsr)))
  675.                                  ((atom optionsr))
  676.                                (let ((optionkey (first optionsr))
  677.                                      (argument (second optionsr)))
  678.                                  (case optionkey
  679.                                    ((:READER :WRITER)
  680.                                     (unless (function-name-p argument)
  681.                                       (error-of-type 'program-error
  682.                                         #L{
  683.                                         DEUTSCH "~S ~S, Slot-Option zu Slot ~S: ~S ist kein Funktionsname."
  684.                                         ENGLISH "~S ~S, slot option for slot ~S: ~S is not a function name"
  685.                                         FRANCAIS "~S ~S, option pour composant ~S : ~S n'est pas le nom d'une fonction."
  686.                                         }
  687.                                         'defclass name slot-name argument
  688.                                     ) )
  689.                                     (case optionkey
  690.                                       (:READER (push argument readers))
  691.                                       (:WRITER (push argument writers))
  692.                                    ))
  693.                                    (:ACCESSOR
  694.                                     (unless (symbolp argument)
  695.                                       (error-of-type 'program-error
  696.                                         #L{
  697.                                         DEUTSCH "~S ~S, Slot-Option zu Slot ~S: ~S ist kein Symbol."
  698.                                         ENGLISH "~S ~S, slot option for slot ~S: ~S is not a symbol"
  699.                                         FRANCAIS "~S ~S, option pour composant ~S : ~S n'est pas un symbole."
  700.                                         }
  701.                                         'defclass name slot-name argument
  702.                                     ) )
  703.                                     (push argument accessors)
  704.                                     (push argument readers)
  705.                                     (push `(SETF ,argument) writers)
  706.                                    )
  707.                                    (:ALLOCATION
  708.                                     (when allocation
  709.                                       (error-of-type 'program-error
  710.                                         #L{
  711.                                         DEUTSCH "~S ~S, Slot-Option ~S zu Slot ~S darf nur einmal angegeben werden."
  712.                                         ENGLISH "~S ~S, slot option ~S for slot ~S may only be given once"
  713.                                         FRANCAIS "~S ~S, l'option ~S pour le composant ~S ne peut être spécifiée qu'une seule fois."
  714.                                         }
  715.                                         'defclass name ':allocation slot-name
  716.                                     ) )
  717.                                     (case argument
  718.                                       ((:INSTANCE :CLASS) (setq allocation argument))
  719.                                       (t (error-of-type 'program-error
  720.                                            #L{
  721.                                            DEUTSCH "~S ~S, Slot-Option zu Slot ~S muß den Wert ~S oder ~S haben, nicht ~S"
  722.                                            ENGLISH "~S ~S, slot option for slot ~S must have the value ~S or ~S, not ~S"
  723.                                            FRANCAIS "~S ~S, l'option ~S pour le composant ~S doit avoir la valeur ~S ou ~S et non ~S"
  724.                                            }
  725.                                            'defclass name slot-name ':instance ':class argument
  726.                                    )) )  )
  727.                                    (:INITARG
  728.                                     (unless (symbolp argument)
  729.                                       (error-of-type 'program-error
  730.                                         #L{
  731.                                         DEUTSCH "~S ~S, Slot-Option zu Slot ~S: ~S ist kein Symbol."
  732.                                         ENGLISH "~S ~S, slot option for slot ~S: ~S is not a symbol"
  733.                                         FRANCAIS "~S ~S, option pour composant ~S : ~S n'est pas un symbole."
  734.                                         }
  735.                                         'defclass name slot-name argument
  736.                                     ) )
  737.                                     (push argument initargs)
  738.                                    )
  739.                                    (:INITFORM
  740.                                     (when initform
  741.                                       (error-of-type 'program-error
  742.                                         #L{
  743.                                         DEUTSCH "~S ~S, Slot-Option ~S zu Slot ~S darf nur einmal angegeben werden."
  744.                                         ENGLISH "~S ~S, slot option ~S for slot ~S may only be given once"
  745.                                         FRANCAIS "~S ~S, l'option ~S pour le composant ~S ne peut être spécifiée qu'une seule fois."
  746.                                         }
  747.                                         'defclass name ':initform slot-name
  748.                                     ) )
  749.                                     (setq initform `(QUOTE ,argument)
  750.                                           initer (make-initer argument)
  751.                                    ))
  752.                                    (:TYPE
  753.                                     (when types
  754.                                       (error-of-type 'program-error
  755.                                         #L{
  756.                                         DEUTSCH "~S ~S, Slot-Option ~S zu Slot ~S darf nur einmal angegeben werden."
  757.                                         ENGLISH "~S ~S, slot option ~S for slot ~S may only be given once"
  758.                                         FRANCAIS "~S ~S, l'option ~S pour le composant ~S ne peut être spécifiée qu'une seule fois."
  759.                                         }
  760.                                         'defclass name ':type slot-name
  761.                                     ) )
  762.                                     (setq types (list argument))
  763.                                    )
  764.                                    (:DOCUMENTATION
  765.                                     (when documentation
  766.                                       (error-of-type 'program-error
  767.                                         #L{
  768.                                         DEUTSCH "~S ~S, Slot-Option ~S zu Slot ~S darf nur einmal angegeben werden."
  769.                                         ENGLISH "~S ~S, slot option ~S for slot ~S may only be given once"
  770.                                         FRANCAIS "~S ~S, l'option ~S pour le composant ~S ne peut être spécifiée qu'une seule fois."
  771.                                         }
  772.                                         'defclass name ':documentation slot-name
  773.                                     ) )
  774.                                     (unless (stringp argument)
  775.                                       (error-of-type 'program-error
  776.                                         #L{
  777.                                         DEUTSCH "~S ~S, Slot-Option zu Slot ~S: ~S ist kein String."
  778.                                         ENGLISH "~S ~S, slot option for slot ~S: ~S is not a string"
  779.                                         FRANCAIS "~S ~S, option pour composant ~S : ~S n'est pas une chaîne."
  780.                                         }
  781.                                         'defclass name slot-name argument
  782.                                     ) )
  783.                                     (setq documentation argument)
  784.                                    )
  785.                                    (t
  786.                                      (error-of-type 'program-error
  787.                                        #L{
  788.                                        DEUTSCH "~S ~S, Slot-Option zu Slot ~S: ~S ist keine gültige Slot-Option."
  789.                                        ENGLISH "~S ~S, slot option for slot ~S: ~S is not a valid slot option"
  790.                                        FRANCAIS "~S ~S, option pour composant ~S : ~S n'est pas une option valable."
  791.                                        }
  792.                                        'defclass name slot-name optionkey
  793.                                    ) )
  794.                              ) ) )
  795.                              (setq readers (nreverse readers))
  796.                              (setq writers (nreverse writers))
  797.                              (dolist (funname readers)
  798.                                (push `(DEFMETHOD ,funname ((OBJECT ,name))
  799.                                         (SLOT-VALUE OBJECT ',slot-name)
  800.                                       )
  801.                                      accessor-def-forms
  802.                              ) )
  803.                              (dolist (funname writers)
  804.                                (push `(DEFMETHOD ,funname (NEW-VALUE (OBJECT ,name))
  805.                                         (SETF (SLOT-VALUE OBJECT ',slot-name) NEW-VALUE)
  806.                                       )
  807.                                      accessor-def-forms
  808.                              ) )
  809.                              `(LIST
  810.                                 :NAME ',slot-name
  811.                                 ,@(when accessors `(:ACCESSORS ',(nreverse accessors)))
  812.                                 ,@(when readers `(:READERS ',readers))
  813.                                 ,@(when writers `(:WRITERS ',writers))
  814.                                 ,@(when (eq allocation ':class) `(:ALLOCATION :CLASS))
  815.                                 ,@(when initargs `(:INITARGS ',(nreverse initargs)))
  816.                                 ,@(when initform `(#| :INITFORM ,initform |# :INITER ,initer))
  817.                                 ,@(when types `(:TYPE ',(first types)))
  818.                                 ,@(when documentation `(:DOCUMENTATION ',documentation))
  819.                               )
  820.                        ) ) )
  821.                      slot-specs
  822.         )) ) )
  823.     `(LET ()
  824.        (EVAL-WHEN (COMPILE LOAD EVAL)
  825.          (ENSURE-CLASS
  826.            ',name
  827.            :DIRECT-SUPERCLASSES (LIST ,@superclass-forms)
  828.            :DIRECT-SLOTS (LIST ,@slot-forms)
  829.            ,@(let ((metaclass nil)
  830.                    (direct-default-initargs nil)
  831.                    (documentation nil))
  832.                (dolist (option options)
  833.                  (block nil
  834.                    (when (listp option)
  835.                      (let ((optionkey (first option)))
  836.                        (when (case optionkey
  837.                                (:METACLASS metaclass)
  838.                                (:DEFAULT-INITARGS direct-default-initargs)
  839.                                (:DOCUMENTATION documentation)
  840.                              )
  841.                          (error-of-type 'program-error
  842.                            #L{
  843.                            DEUTSCH "~S ~S, Option ~S darf nur einmal angegeben werden."
  844.                            ENGLISH "~S ~S, option ~S may only be given once"
  845.                            FRANCAIS "~S ~S, l'option ~S ne peut être spécifiée qu'une seule fois."
  846.                            }
  847.                            'defclass name optionkey
  848.                        ) )
  849.                        (case optionkey
  850.                          (:METACLASS
  851.                           (when (eql (length option) 2)
  852.                             (let ((argument (second option)))
  853.                               (unless (symbolp argument)
  854.                                 (error-of-type 'program-error
  855.                                   #L{
  856.                                   DEUTSCH "~S ~S, Option ~S: ~S ist kein Symbol."
  857.                                   ENGLISH "~S ~S, option ~S: ~S is not a symbol"
  858.                                   FRANCAIS "~S ~S, option ~S : ~S n'est pas un symbole."
  859.                                   }
  860.                                   'defclass name option argument
  861.                               ) )
  862.                               (setq metaclass `(:METACLASS (FIND-CLASS ',argument)))
  863.                             )
  864.                             (return)
  865.                          ))
  866.                          (:DEFAULT-INITARGS
  867.                           (let ((list (rest option)))
  868.                             (when (and (consp list) (null (cdr list)) (listp (car list)))
  869.                               (setq list (car list))
  870.                               (warn 
  871.                                     #L{
  872.                                     DEUTSCH "~S ~S: Option ~S sollte als ~S geschrieben werden."
  873.                                     ENGLISH "~S ~S: option ~S should be written ~S"
  874.                                     FRANCAIS "~S ~S : L'option ~S devrait être écrite ~S."
  875.                                     }
  876.                                     'defclass name option (cons ':DEFAULT-INITARGS list)
  877.                             ) )
  878.                             (when (oddp (length list))
  879.                               (error-of-type 'program-error
  880.                                 #L{
  881.                                 DEUTSCH "~S ~S, Option ~S: Argumente sind nicht paarig."
  882.                                 ENGLISH "~S ~S, option ~S: arguments don't come in pairs"
  883.                                 FRANCAIS "~S ~S, option ~S : Les arguments ne viennent pas deux à deux."
  884.                                 }
  885.                                 'defclass name option
  886.                             ) )
  887.                             (setq direct-default-initargs
  888.                                   `(:DIRECT-DEFAULT-INITARGS
  889.                                     (LIST
  890.                                      ,@(let ((arglist nil) (formlist nil))
  891.                                          (do ((list list (cddr list)))
  892.                                              ((atom list))
  893.                                            (unless (symbolp (first list))
  894.                                              (error-of-type 'program-error
  895.                                                #L{
  896.                                                DEUTSCH "~S ~S, Option ~S: ~S ist kein Symbol."
  897.                                                ENGLISH "~S ~S, option ~S: ~S is not a symbol"
  898.                                                FRANCAIS "~S ~S, option ~S : ~S n'est pas un symbole."
  899.                                                }
  900.                                                'defclass name option (first list)
  901.                                            ) )
  902.                                            (when (member (first list) arglist)
  903.                                              (error-of-type 'program-error
  904.                                                #L{
  905.                                                DEUTSCH "~S ~S, Option ~S: ~S darf nur einmal angegeben werden."
  906.                                                ENGLISH "~S ~S, option ~S: ~S may only be given once"
  907.                                                FRANCAIS "~S ~S, option ~S : ~S ne peut être spécifié qu'une seule fois."
  908.                                                }
  909.                                                'defclass name option (first list)
  910.                                            ) )
  911.                                            (push (first list) arglist)
  912.                                            (push (second list) formlist)
  913.                                          )
  914.                                          (mapcan #'(lambda (arg form)
  915.                                                      `(',arg ,(make-initer form))
  916.                                                    )
  917.                                                  (nreverse arglist) (nreverse formlist)
  918.                                        ) )
  919.                                    ))
  920.                           ) )
  921.                           (return)
  922.                          )
  923.                          (:DOCUMENTATION
  924.                           (when (eql (length option) 2)
  925.                             (let ((argument (second option)))
  926.                               (unless (stringp argument)
  927.                                 (error-of-type 'program-error
  928.                                   #L{
  929.                                   DEUTSCH "~S ~S, Option ~S: ~S ist kein String."
  930.                                   ENGLISH "~S ~S, option ~S: ~S is not a string"
  931.                                   FRANCAIS "~S ~S, option ~S : ~S n'est pas une chaîne."
  932.                                   }
  933.                                   'defclass name option argument
  934.                               ) )
  935.                               (setq documentation `(:DOCUMENTATION ',argument))
  936.                             )
  937.                             (return)
  938.                          ))
  939.                    ) ) )
  940.                    (error-of-type 'program-error
  941.                      #L{
  942.                      DEUTSCH "~S ~S: Ungültige Option ~S"
  943.                      ENGLISH "~S ~S: invalid option ~S"
  944.                      FRANCAIS "~S ~S : option invalide ~S"
  945.                      }
  946.                      'defclass name option
  947.                ) ) )
  948.                `(,@metaclass ,@direct-default-initargs ,@documentation)
  949.              )
  950.        ) )
  951.        ,@(nreverse accessor-def-forms) ; die DEFMETHODs
  952.        (FIND-CLASS ',name)
  953.      )
  954. ) )
  955. ; Ein Initer zur Laufzeit ist - um Funktionsaufrufe zu sparen -
  956. ; i.a. ein Cons (init-function . nil), bei Konstanten aber (nil . init-value).
  957. (defun make-initer (form)
  958.   (if (constantp form)
  959.     `(CONS 'NIL ,form)
  960.     `(CONS (FUNCTION (LAMBDA () ,form)) 'NIL)
  961. ) )
  962.  
  963. ; DEFCLASS-Ausführung:
  964.  
  965. ; Zur Laufzeit noch bedeutsame Information eines Slots:
  966. (defstruct (slot-definition
  967.             (:conc-name "SLOTDEF-")
  968.             (:type vector) (:predicate nil)
  969.             (:constructor make-slot-definition (name allocation initargs location initer)))
  970.   (name nil :type symbol)
  971.   (allocation :instance :type (or (member :class :instance) class))
  972.   (initargs '() :type list)
  973.   (location nil :type (or null integer cons))
  974.   (initer nil :type (or null cons))
  975. )
  976.  
  977. (defun make-slotdef (&key name (allocation ':instance) (initargs '()) location (initer nil) (initform nil) (accessors '()) (readers '()) (writers '()) type documentation)
  978.   (declare (ignore initform accessors readers writers type documentation))
  979.   (make-slot-definition name allocation initargs location initer)
  980. )
  981.  
  982. (defun ensure-class (name &rest all-keys
  983.                           &key (metaclass <standard-class>)
  984.                                (direct-superclasses '())
  985.                                (direct-slots '())
  986.                                (direct-default-initargs '())
  987.                                (documentation nil)
  988.                           &allow-other-keys
  989.                     )
  990.   (let ((class (find-class name nil)))
  991.     (if class
  992.       ; Die einzige Modifikationen, die wir bei Klassen zulassen, sind die,
  993.       ; die bei doppeltem Laden desselben Codes auftreten können:
  994.       ; veränderte Slot-Optionen :initform, :documentation,
  995.       ; veränderte Klassen-Optionen :default-initargs, :documentation.
  996.       (if (and (eq metaclass <standard-class>)
  997.                (eq metaclass (class-of class))
  998.                (equal direct-superclasses (class-direct-superclasses class))
  999.                (equal-slots direct-slots (class-direct-slots class))
  1000.                (equal-default-initargs direct-default-initargs (class-direct-default-initargs class))
  1001.           )
  1002.         (progn
  1003.           ; neue Slot-Inits eintragen:
  1004.           (do ((l-old (class-direct-slots class) (cdr l-old))
  1005.                (l-new direct-slots (cdr l-new)))
  1006.               ((null l-new))
  1007.             (let ((old (getf (car l-old) ':initer))
  1008.                   (new (getf (car l-new) ':initer)))
  1009.               (when old
  1010.                 ; Slot-Initer new destruktiv in den Slot-Initer old umfüllen:
  1011.                 (setf (car old) (car new))
  1012.                 (setf (cdr old) (cdr new))
  1013.           ) ) )
  1014.           ; neue Default-Initargs eintragen:
  1015.           (do ((l-old (class-direct-default-initargs class) (cddr l-old))
  1016.                (l-new direct-default-initargs (cddr l-new)))
  1017.               ((null l-new))
  1018.             (let ((old (second l-old))
  1019.                   (new (second l-new)))
  1020.               ; Initer new destruktiv in den Initer old umfüllen:
  1021.               (setf (car old) (car new))
  1022.               (setf (cdr old) (cdr new))
  1023.           ) )
  1024.           ; NB: Diese Modifikationen vererben sich auch automatisch auf die
  1025.           ; Unterklassen von class!
  1026.           ; neue Dokumentation eintragen:
  1027.           (when documentation (setf (documentation name 'TYPE) documentation))
  1028.           ; modifizierte Klasse als Wert:
  1029.           class
  1030.         )
  1031.         (error-of-type 'error
  1032.           #L{
  1033.           DEUTSCH "~S: Klasse ~S kann nicht umdefiniert werden."
  1034.           ENGLISH "~S: Cannot redefine class ~S"
  1035.           FRANCAIS "~S : La classe ~S ne peut pas être redéfinie."
  1036.           }
  1037.           'defclass name
  1038.       ) )
  1039.       (progn
  1040.         (when documentation (setf (documentation name 'TYPE) documentation))
  1041.         (setf (find-class name)
  1042.               (apply (cond ((eq metaclass <standard-class>) #'make-instance-standard-class)
  1043.                            ((eq metaclass <built-in-class>) #'make-instance-built-in-class) ; ??
  1044.                            ((eq metaclass <structure-class>) #'make-instance-structure-class)
  1045.                            (t #'make-instance)
  1046.                      )
  1047.                      metaclass
  1048.                      :name name
  1049.                      all-keys
  1050.       ) )     )
  1051. ) ) )
  1052. (defun equal-slots (slots1 slots2)
  1053.   (or (and (null slots1) (null slots2))
  1054.       (and (consp slots1) (consp slots2)
  1055.            (equal-slot (first slots1) (first slots2))
  1056.            (equal-slots (rest slots1) (rest slots2))
  1057. ) )   )
  1058. (defun equal-slot (slot1 slot2) ; slot1, slot2 Plisten
  1059.   (or (and (null slot1) (null slot2))
  1060.       (and #| (consp slot1) (consp slot2) |#
  1061.            (eq (first slot1) (first slot2))
  1062.            (or (memq (first slot1) '(#| :initform |# :initer #| :documentation |# ))
  1063.                (equal (second slot1) (second slot2))
  1064.            )
  1065.            (equal-slot (cddr slot1) (cddr slot2))
  1066. ) )   )
  1067. (defun equal-default-initargs (initargs1 initargs2)
  1068.   (or (and (null initargs1) (null initargs2))
  1069.       (and (consp initargs1) (consp initargs2)
  1070.            (eq (first initargs1) (first initargs2))
  1071.            (equal-default-initargs (cddr initargs1) (cddr initargs2))
  1072. ) )   )
  1073.  
  1074. (defun add-default-superclass (direct-superclasses default-superclass)
  1075.   ; Manchmal will man eine bestimmte Oberklasse erzwingen.
  1076.   ; Sie darf aber nicht zweimal angegeben werden.
  1077.   (if (member default-superclass direct-superclasses :test #'eq)
  1078.     direct-superclasses
  1079.     (append direct-superclasses (list default-superclass))
  1080. ) )
  1081.  
  1082. ; Erzeugung einer Instanz von <standard-class>:
  1083.  
  1084. (let (unbound) (declare (compile)) ; unbound = #<unbound>
  1085. (defun def-unbound (x) (declare (compile)) (setq unbound x))
  1086. (defun make-instance-standard-class
  1087.        (metaclass &key name (direct-superclasses '()) (direct-slots '())
  1088.                             (direct-default-initargs '())
  1089.                   &allow-other-keys
  1090.        )
  1091.   ; metaclass = <standard-class>
  1092.   (unless (every #'standard-class-p direct-superclasses)
  1093.     (error-of-type 'error
  1094.       #L{
  1095.       DEUTSCH "~S ~S: Oberklasse ~S sollte zur Klasse STANDARD-CLASS gehören."
  1096.       ENGLISH "~S ~S: superclass ~S should belong to class STANDARD-CLASS"
  1097.       FRANCAIS "~S ~S : La classe supérieure ~S n'appartient pas à la classe STANDARD-CLASS."
  1098.       }
  1099.       'defclass name (find-if-not #'standard-class-p direct-superclasses)
  1100.   ) )
  1101.   (let ((class (make-standard-class :classname name :metaclass metaclass)))
  1102.     (setf (class-direct-superclasses class) (copy-list direct-superclasses))
  1103.     (setf (class-precedence-list class)
  1104.           (std-compute-cpl class
  1105.             (add-default-superclass direct-superclasses <standard-object>)
  1106.     )     )
  1107.     (setf (class-all-superclasses class)
  1108.           (std-compute-superclasses (class-precedence-list class))
  1109.     )
  1110.     (setf (class-direct-slots class) direct-slots)
  1111.     (setf (class-slots class) (std-compute-slots class))
  1112.     (let ((ht (make-hash-table :test #'eq))
  1113.           (local-index 1) ; Index 0 wird von der Klasse belegt
  1114.           (shared-index 0))
  1115.       (mapc #'(lambda (slot)
  1116.                 (let* ((name (slotdef-name slot))
  1117.                        (allocation (slotdef-allocation slot))
  1118.                        (location
  1119.                          (cond ((eq allocation ':instance) ; local slot
  1120.                                 (prog1 local-index (incf local-index))
  1121.                                )
  1122.                                ((eq allocation class) ; new shared slot
  1123.                                 (prog1 (cons class shared-index) (incf shared-index))
  1124.                                )
  1125.                                (t ; inherited shared slot
  1126.                                 (gethash name (class-slot-location-table allocation))
  1127.                       )) )     )
  1128.                   (setf (slotdef-location slot) location)
  1129.                   (setf (gethash name ht) location)
  1130.               ) )
  1131.             (class-slots class)
  1132.       )
  1133.       (setf (class-slot-location-table class) ht)
  1134.       (setf (class-instance-slot-count class) local-index)
  1135.       (when (plusp shared-index)
  1136.         (setf (class-shared-slots class)
  1137.               (let ((v (make-array shared-index))
  1138.                     (i 0))
  1139.                 (mapc #'(lambda (slot)
  1140.                           (when (eq (slotdef-allocation slot) class)
  1141.                             (setf (svref v i)
  1142.                               (let ((init (slotdef-initer slot)))
  1143.                                 (if init
  1144.                                   (if (car init) (funcall (car init)) (cdr init))
  1145.                                   unbound
  1146.                             ) ) )
  1147.                             (incf i)
  1148.                         ) )
  1149.                       (class-slots class)
  1150.                 )
  1151.                 v
  1152.       ) )     )
  1153.     )
  1154.     (setf (class-direct-default-initargs class) direct-default-initargs)
  1155.     (setf (class-default-initargs class) ; 28.1.3.3.
  1156.           (remove-duplicates
  1157.             (mapcan
  1158.               #'(lambda (c)
  1159.                   (when (standard-class-p c)
  1160.                     (plist-to-alist (class-direct-default-initargs c))
  1161.                 ) )
  1162.               (class-precedence-list class)
  1163.             )
  1164.             :key #'car
  1165.             :from-end t
  1166.     )     )
  1167.     (setf (class-valid-initargs class)
  1168.           (remove-duplicates (mapcap #'slotdef-initargs (class-slots class)))
  1169.     )
  1170.     class
  1171. ) )
  1172. ) ; let
  1173.  
  1174. ;; 28.1.5. Determining the Class Precedence List
  1175. ;
  1176. ; Die Menge aller Klassen bildet einen gerichteten Graphen: Klasse C sitzt
  1177. ; unterhalb der direkten Oberklassen von C. Dieser Graph ist azyklisch, weil
  1178. ; zum Zeitpunkt Definition der Klasse C alle direkten Oberklassen bereits
  1179. ; vorhanden sein müssen.
  1180. ;
  1181. ; Man kann daher noethersche Induktion (Induktion von oben nach unten im
  1182. ; Klassengraphen) verwenden.
  1183. ;
  1184. ; Zu einer Klasse C sei DS(n) die Liste aller direkten Oberklassen von C.
  1185. ; Die Menge aller Oberklassen (inkl. C selbst) ist induktiv definiert als
  1186. ; S(C) := {C} union union_{D in DS(C)} S(D).
  1187. ;
  1188. ; Anders ausgedrückt:
  1189. ; S(C) = { C_n : C_n in DS(C_{n-1}), ..., C_1 in DS(C_0), C_0 = C }
  1190. ;
  1191. ; Lemma 1: (a) C in S(C).
  1192. ;          (b) DS(C) subset S(C).
  1193. ;          (c) D in DS(C) ==> S(D) subset S(C).
  1194. ;          (d) D in S(C) ==> S(D) subset S(C).
  1195. ; Beweis: (a) Aus der Definition.
  1196. ;         (b) Aus (a) und der Definition.
  1197. ;         (c) Aus der Definition.
  1198. ;         (d) Aus (c) bei festem D mit Induktion über C.
  1199. ;
  1200. ; Die CPL einer Klasse C ist eine Anordnung der Menge S(C).
  1201. ; Falls CPL(C) = (... D1 ... D2 ...), schreibt man D1 < D2. Die so eingeführte
  1202. ; Relation ist eine Totalordnung auf S(C).
  1203. ; Dabei ist die folgende Menge von Restriktionen zu berücksichtigen:
  1204. ; R(C) := union_{D in S(C)} DR(D)  mit
  1205. ; DR(C) := { C < C1, C1 < C2, ..., C{n-1} < C_n } falls DS(C) = (C1, ..., Cn).
  1206. ; Falls R(C) einen Zyklus enthält, kann natürlich R(C) nicht zu einer
  1207. ; Totalordnung vervollständigt werden. Dann heißt R(C) inkonsistent.
  1208. ; CPL(C) wird folgendermaßen konstruiert:
  1209. ;   L := (), R := R(C).
  1210. ;   L := (L | C), entferne alle (C < ..) aus R.
  1211. ;   Solange R /= {}, betrachte die Menge M aller minimalen Elemente von R
  1212. ;     (das sind diejenigen Klassen, die man, ohne R(C) zu verletzen, zu L
  1213. ;     hinzufügen könnte). Ist M leer, so hat man einen Zyklus in R(C) und
  1214. ;     bricht den Algorithmus ab. Sonst wähle unter den Elementen E von M
  1215. ;     dasjenige aus, das ein möglichst weit rechts in L gelegenes D mit
  1216. ;     E in DS(D) besitzt.
  1217. ;     L := (L | E), entferne alle (E < ..) aus R.
  1218. ;   CPL(C) := L.
  1219. ; L wird schrittweise um ein Element verlängert, R wird schrittweise
  1220. ; verkleinert, und R besteht immer nur aus Relationen zwischen Elementen
  1221. ; von S(C)\L.
  1222. ;
  1223. ; Lemma 2: (a) CPL(C) = (C ...).
  1224. ;          (b) Ist DS(C) = (C1, ..., Cn), so ist
  1225. ;              CPL(C) = (C ... C1 ... C2 ... ... Cn ...).
  1226. ; Beweis: (a) Klar nach Konstruktion.
  1227. ;         (b) Wenn Ci in die CPL aufgenommen wird, kann die Restriktion
  1228. ;             C{i-1} < Ci nicht mehr in R sein, also muß C{i-1} schon in
  1229. ;             der CPL sein.
  1230. ;
  1231. ; Folgende Aussage ist falsch:
  1232. ; (*) Ist D in DS(C) und CPL(D) = (D1, ..., Dn), so ist
  1233. ;     CPL(C) = (C ... D1 ... D2 ... ... Dn ...).
  1234. ; Beispiel:
  1235. ;     z
  1236. ;    /|\             CPL(z) = (z)
  1237. ;   / | \            CPL(x) = (x z)
  1238. ;  x  |  x           CPL(y) = (y z)
  1239. ;  |  |  |           CPL(d) = (d x z)
  1240. ;  d  y  e           CPL(e) = (e x z)
  1241. ;   \/ \/            CPL(b) = (b d x y z)
  1242. ;   b   c            CPL(c) = (c y e x z)
  1243. ;    \ /             CPL(a) = (a b d c y e x z)
  1244. ;     a
  1245. ;                    CPL(a) enthält CPL(b) nicht!
  1246. ;
  1247. #|
  1248. (defclass z () ())
  1249. (defclass x (z) ())
  1250. (defclass y (z) ())
  1251. (defclass d (x z) ())
  1252. (defclass e (x z) ())
  1253. (defclass b (d y) ())
  1254. (defclass c (y e) ())
  1255. (defclass a (b c) ())
  1256. (mapcar #'find-class '(z x y d e b c a))
  1257. |#
  1258.  
  1259. (defun std-compute-cpl (class direct-superclasses)
  1260.   (let* ((superclasses ; Liste aller Oberklassen in irgendeiner Reihenfolge
  1261.            (remove-duplicates
  1262.              (mapcap #'class-precedence-list direct-superclasses)
  1263.          ) )
  1264.          (L '())
  1265.          (R1 (list (cons class direct-superclasses)))
  1266.          (R2 (mapcar #'(lambda (D) (cons D (class-direct-superclasses D)))
  1267.                      superclasses
  1268.         ))   )
  1269.     (loop
  1270.       ; L ist die umgedrehte bisher konstruierte CPL.
  1271.       ; R1 ist die Liste der bisher relevanten Restriktionen, in der Form
  1272.       ; R1 = (... (Dj ... Dn) ...) wenn aus DR(D) = (D1 ... Dn) nur noch
  1273.       ; Dj,...,Dn übrig sind. Die Reihenfolge in R1 entspricht der in L.
  1274.       ; R2 ist die Liste der bisher irrelevanten Restriktionen.
  1275.       (when (null R1)
  1276.         (return) ; R1 = R2 = () -> fertig
  1277.       )
  1278.       (let ((M (remove-duplicates (mapcar #'first R1) :from-end t)))
  1279.         (setq M
  1280.           (remove-if
  1281.             #'(lambda (E)
  1282.                 (or (dolist (r R1 nil) (when (member E (cdr r)) (return t)))
  1283.                     (dolist (r R2 nil) (when (member E (cdr r)) (return t)))
  1284.               ) )
  1285.             M
  1286.         ) )
  1287.         (when (null M)
  1288.           (error-of-type 'error
  1289.             #L{
  1290.             DEUTSCH "~S ~S: Inkonsistenter Präzedenz-Graph, Zyklus ~S"
  1291.             ENGLISH "~S ~S: inconsistent precedence graph, cycle ~S"
  1292.             FRANCAIS "~S ~S : graphe de précédences contradictoire, cycle ~S"
  1293.             }
  1294.             'defclass (class-classname class)
  1295.             ; Zyklus finden: mit Hilfe der Restriktionen zu immer
  1296.             ; kleineren Elementen voranschreiten.
  1297.             (let* ((R0 (append R1 R2))
  1298.                    (cycle (list (car (first R0)))))
  1299.               (loop
  1300.                 (let* ((last (car cycle))
  1301.                        (next (dolist (r R0 nil)
  1302.                                (when (member last (cdr r))
  1303.                                  (return (nth (position last (cdr r)) r))
  1304.                       ))     ) )
  1305.                   (when (null next)
  1306.                     ; Offenbar ist last nun doch ein minimales Element!
  1307.                     (return '??)
  1308.                   )
  1309.                   (when (member next cycle)
  1310.                     (setf (cdr (member next cycle)) nil)
  1311.                     (return cycle)
  1312.                   )
  1313.                   (push next cycle)
  1314.             ) ) )
  1315.         ) )
  1316.         (let ((E (first M)))
  1317.           (push E L)
  1318.           (push (assoc E R2) R1)
  1319.           (setq R2 (delete E R2 :key #'first))
  1320.           (mapl #'(lambda (r) (when (eq (first (car r)) E) (pop (car r)))) R1)
  1321.           (setq R1 (delete-if #'null R1))
  1322.     ) ) )
  1323.     (setq L (nreverse L))
  1324.     ; Teste, ob L mit den CPL(D), D in direct-superclasses, verträglich ist:
  1325.     (mapc #'(lambda (D)
  1326.               (unless ; Ist (class-precedence-list D) Teil-Liste von L ?
  1327.                 (do ((CL L)
  1328.                      (DL (class-precedence-list D) (cdr DL)))
  1329.                     ((null DL) t)
  1330.                   (when (null (setq CL (member (car DL) CL))) (return nil))
  1331.                 )
  1332.                 (warn 
  1333.                       #L{
  1334.                       DEUTSCH "(class-precedence-list ~S) und (class-precedence-list ~S) sind nicht verträglich."
  1335.                       ENGLISH "(class-precedence-list ~S) and (class-precedence-list ~S) are inconsistent"
  1336.                       FRANCAIS "(class-precedence-list ~S) et (class-precedence-list ~S) sont contradictoires."
  1337.                       }
  1338.                       class D
  1339.             ) ) )
  1340.           direct-superclasses
  1341.     )
  1342.     L
  1343. ) )
  1344.  
  1345. ; Stopft alle Oberklassen (aus der precedence-list) in eine Hash-Tabelle.
  1346. (defun std-compute-superclasses (precedence-list)
  1347.   (let ((ht (make-hash-table :test #'eq)))
  1348.     (mapc #'(lambda (superclass) (setf (gethash superclass ht) t))
  1349.           precedence-list
  1350.     )
  1351.     ht
  1352. ) )
  1353.  
  1354. ; Hilfsfunktion (p1 v1 ... pn vn) -> ((p1 . v1) ... (pn . vn))
  1355. (defun plist-to-alist (pl &aux (al '()))
  1356.   (loop
  1357.     (when (null pl) (return))
  1358.     (setq al (acons (first pl) (second pl) al))
  1359.     (setq pl (cddr pl))
  1360.   )
  1361.   (nreverse al)
  1362. )
  1363.  
  1364. ; Hilfsfunktion ((p1 . v1) ... (pn . vn)) -> (p1 v1 ... pn vn)
  1365. (defun alist-to-plist (al)
  1366.   (mapcan #'(lambda (pv) (list (car pv) (cdr pv))) al)
  1367. )
  1368.  
  1369. ;; 28.1.3.2. Inheritance of Slots and Slot Options
  1370.  
  1371. (defun std-compute-slots (class)
  1372.   ; Alle Slot-Specifier sammeln, geordnet nach Präzedenz:
  1373.   (let ((all-slots
  1374.           (mapcan
  1375.             #'(lambda (c)
  1376.                 (if (standard-class-p c)
  1377.                   (mapcar #'(lambda (slot)
  1378.                               (setq slot (plist-to-alist slot))
  1379.                               (when (eq (cdr (assoc ':allocation slot)) ':class)
  1380.                                 (setf (cdr (assoc ':allocation slot)) c)
  1381.                               )
  1382.                               slot
  1383.                             )
  1384.                     (class-direct-slots c)
  1385.               ) ) )
  1386.             (class-precedence-list class)
  1387.        )) )
  1388.     ; Aufspalten nach Slot-Namen:
  1389.     (setq all-slots
  1390.       (let ((ht (make-hash-table :test #'eq)))
  1391.         (dolist (slot all-slots)
  1392.           (assert (eq (caar slot) ':name))
  1393.           (push (cdr slot) (gethash (cdar slot) ht nil))
  1394.         )
  1395.         (let ((L nil))
  1396.           (maphash #'(lambda (name slots) (push (cons name (nreverse slots)) L)) ht)
  1397.           L ; nicht (nreverse L), da maphash die Reihenfolge umdreht
  1398.     ) ) )
  1399.     ; all-slots ist nun eine Liste von Listen der Form
  1400.     ; (name most-specific-slotspec ... least-specific-slotspec).
  1401.     (mapcar #'(lambda (slot)
  1402.                 (let ((name (car slot))
  1403.                       (slotspecs (cdr slot)))
  1404.                   (apply #'make-slotdef
  1405.                     :name name
  1406.                     (alist-to-plist
  1407.                       `(,(or (assoc ':allocation (first slotspecs))
  1408.                              `(:allocation . :instance)
  1409.                          )
  1410.                         #|
  1411.                         ,@(let ((accessors
  1412.                                   (mapcap #'(lambda (slotspec) (cdr (assoc ':accessors slotspec)))
  1413.                                           slotspecs
  1414.                                )) )
  1415.                             (if accessors `((:accessors . ,accessors)))
  1416.                           )
  1417.                         |#
  1418.                         ,@(let ((initargs
  1419.                                   (remove-duplicates
  1420.                                     (mapcap #'(lambda (slotspec) (cdr (assoc ':initargs slotspec)))
  1421.                                             slotspecs
  1422.                                     )
  1423.                                     :from-end t
  1424.                                )) )
  1425.                             (if initargs `((:initargs . ,initargs)))
  1426.                           )
  1427.                         ,@(dolist (slotspec slotspecs '())
  1428.                             (when (assoc ':initer slotspec)
  1429.                               (return `(#| ,(assoc ':initform slotspec) |# ,(assoc ':initer slotspec)))
  1430.                           ) )
  1431.                         #|
  1432.                         ,(let ((types '()))
  1433.                            (dolist (slotspec slotspecs)
  1434.                              (when (assoc ':type slotspec)
  1435.                                (push (cdr (assoc ':type slotspec)) types)
  1436.                            ) )
  1437.                            `(:type . ,(if types `(AND ,@(nreverse types)) 'T))
  1438.                          )
  1439.                         |#
  1440.                         #|
  1441.                         ,@(dolist (slotspec slotspecs '())
  1442.                             (when (assoc ':documentation slotspec)
  1443.                               (return `(,(assoc ':documentation slotspec)))
  1444.                           ) )
  1445.                         |#
  1446.                        )
  1447.               ) ) ) )
  1448.             all-slots
  1449.     )
  1450. ) )
  1451.  
  1452.  
  1453. ; Erzeugung einer Instanz von <built-in-class>:
  1454.  
  1455. (defun make-instance-built-in-class
  1456.        (metaclass &key name (direct-superclasses '())
  1457.                   &allow-other-keys
  1458.        )
  1459.   ; metaclass = <built-in-class>
  1460.   (unless (every #'built-in-class-p direct-superclasses)
  1461.     (error-of-type 'error
  1462.       #L{
  1463.       DEUTSCH "~S: Oberklasse ~S sollte zur Klasse BUILT-IN-CLASS gehören."
  1464.       ENGLISH "~S: superclass ~S should belong to class BUILT-IN-CLASS"
  1465.       FRANCAIS "~S : La classe supérieure ~S n'appartient pas à la classe BUILT-IN-CLASS."
  1466.       }
  1467.       name (find-if-not #'built-in-class-p direct-superclasses)
  1468.   ) )
  1469.   (let ((class (make-built-in-class :classname name :metaclass metaclass)))
  1470.     (setf (class-direct-superclasses class) (copy-list direct-superclasses))
  1471.     (setf (class-precedence-list class)
  1472.           (std-compute-cpl class direct-superclasses)
  1473.     )
  1474.     (setf (class-all-superclasses class)
  1475.           (std-compute-superclasses (class-precedence-list class))
  1476.     )
  1477.     class
  1478. ) )
  1479.  
  1480.  
  1481. ; Erzeugung einer Instanz von <structure-class>:
  1482.  
  1483. (defun make-instance-structure-class
  1484.        (metaclass &key name (direct-superclasses '()) (slots '())
  1485.                   &allow-other-keys
  1486.        )
  1487.   ; metaclass = <structure-class>
  1488.   (unless (null (cdr direct-superclasses))
  1489.     (error-of-type 'error
  1490.       #L{
  1491.       DEUTSCH "~S: Metaklasse STRUCTURE-CLASS läßt nur eine direkte Oberklasse zu."
  1492.       ENGLISH "~S: metaclass STRUCTURE-CLASS forbids more than one direct superclass"
  1493.       FRANCAIS "~S : La classe méta STRUCTURE-CLASS ne permet qu'une seule classe supérieure."
  1494.       }
  1495.       name
  1496.   ) )
  1497.   (unless (every #'structure-class-p direct-superclasses)
  1498.     (error-of-type 'error
  1499.       #L{
  1500.       DEUTSCH "~S: Oberklasse ~S sollte zur Klasse STRUCTURE-CLASS gehören."
  1501.       ENGLISH "~S: superclass ~S should belong to class STRUCTURE-CLASS"
  1502.       FRANCAIS "~S : La classe supérieure ~S n'appartient pas à la classe STRUCTURE-CLASS."
  1503.       }
  1504.       name (first direct-superclasses)
  1505.   ) )
  1506.   (let ((class (make-structure-class :classname name :metaclass metaclass)))
  1507.     (setf (class-direct-superclasses class) (copy-list direct-superclasses))
  1508.     (setf (class-precedence-list class)
  1509.           (std-compute-cpl class
  1510.                            (add-default-superclass direct-superclasses <t>)
  1511.     )     )
  1512.     (setf (class-all-superclasses class)
  1513.           (std-compute-superclasses (class-precedence-list class))
  1514.     )
  1515.     (setf (class-slot-location-table class)
  1516.           (make-hash-table :test #'eq :initial-contents slots)
  1517.     )
  1518.     class
  1519. ) )
  1520.  
  1521. ; DEFSTRUCT-Hook
  1522. (defun define-structure-class (name)
  1523.   (let ((descr (get name 'sys::defstruct-description)))
  1524.     (when descr
  1525.       (let ((names (svref descr 0)))
  1526.         (setf (find-class name)
  1527.               (make-instance-structure-class <structure-class>
  1528.                 :name name
  1529.                 :direct-superclasses
  1530.                   (if (cdr names) (list (find-class (second names))) '())
  1531.                 :slots
  1532.                   (mapcan #'(lambda (slot)
  1533.                               (if (first slot)
  1534.                                 (list (cons (first slot) (second slot)))
  1535.                             ) )
  1536.                           (svref descr 3)
  1537.                   )
  1538. ) ) ) ) )     )
  1539.  
  1540. ;; Bootstrapping
  1541. (progn
  1542.   ; 1. Klasse <t>
  1543.   (setq <t>
  1544.         (make-instance-built-in-class nil :name 't :direct-superclasses '())
  1545.   )
  1546.   ; 2. Klasse <structure-class>
  1547.   (setq <structure-class> (make-structure-class)) ; Dummy, damit (setf find-class) geht
  1548.   (let ((<class> (define-structure-class 'class)))
  1549.     (setq <structure-class> (define-structure-class 'structure-class))
  1550.     (setf (class-metaclass <class>) <structure-class>)
  1551.     (setf (class-metaclass <structure-class>) <structure-class>)
  1552.   )
  1553.   ; 3. Alle structure-Klassen
  1554.   (labels ((define-structure-class-with-includes (name)
  1555.              (when (get name 'sys::defstruct-description)
  1556.                (unless (find-class name nil)
  1557.                  (let ((names (svref (get name 'sys::defstruct-description) 0)))
  1558.                    (when (cdr names)
  1559.                      (define-structure-class-with-includes (second names))
  1560.                  ) )
  1561.                  (define-structure-class name)
  1562.           )) ) )
  1563.     (do-all-symbols (s) (define-structure-class-with-includes s))
  1564.   )
  1565.   ; 4. Klassen <standard-class>, <built-in-class>
  1566.   (setq <standard-class> (find-class 'standard-class))
  1567.   (setq <built-in-class> (find-class 'built-in-class))
  1568.   ; 5. Klasse <t> zu Ende
  1569.   (setf (class-metaclass <t>) <built-in-class>)
  1570.   (setf (find-class 't) <t>)
  1571.   ; 6. Klasse <standard-object>
  1572.   (setq <standard-object>
  1573.         (make-standard-class
  1574.           :classname 'standard-object
  1575.           :metaclass <standard-class>
  1576.           :direct-superclasses `(,<t>)
  1577.           :direct-slots '()
  1578.           :slots '()
  1579.           :slot-location-table empty-ht
  1580.           :instance-slot-count 1
  1581.           :direct-default-initargs nil
  1582.           :default-initargs nil
  1583.   )     )
  1584.   (setf (class-all-superclasses <standard-object>)
  1585.         (std-compute-superclasses
  1586.           (setf (class-precedence-list <standard-object>)
  1587.                 `(,<standard-object> ,<t>)
  1588.   )     ) )
  1589.   (setf (find-class 'standard-object) <standard-object>)
  1590.   ; 7. Wert #<unbound>
  1591.   (def-unbound
  1592.     (sys::%record-ref (allocate-std-instance <standard-object> 2) 1)
  1593.   )
  1594. )
  1595.  
  1596.  
  1597. ;; 28.1.4. Integrating Types and Classes
  1598. (defun subclassp (class1 class2)
  1599.   (values
  1600.     (gethash class2 (class-all-superclasses class1)) ; T oder (Default) NIL
  1601. ) )
  1602.  
  1603. ;; Built-In-Klassen installieren
  1604. ; Table 28-1, CLtL2 p. 783
  1605. (macrolet ((def (&rest classes &aux (new (car (last classes))))
  1606.              (let ((name (intern (string-trim "<>" (symbol-name new)))))
  1607.                `(setf (find-class ',name)
  1608.                   (setq ,new
  1609.                     (make-instance-built-in-class <built-in-class>
  1610.                       :name ',name
  1611.                       :direct-superclasses (list ,@(cdr (reverse classes)))
  1612.                 ) ) )
  1613.           )) )
  1614.  ;(def <t>)
  1615.   (def <t> <character>)
  1616.   (def <t> <function>)
  1617.   (def     <function> <standard-generic-function>)
  1618.   (def <t> <hash-table>)
  1619.   (def <t> <package>)
  1620.   (def <t> <pathname>)
  1621.   #+LOGICAL-PATHNAMES
  1622.   (def     <pathname> <logical-pathname>)
  1623.   (def <t> <random-state>)
  1624.   (def <t> <readtable>)
  1625.   (def <t> <stream>)
  1626.   (def     <stream> <file-stream>)
  1627.   (def     <stream> <synonym-stream>)
  1628.   (def     <stream> <broadcast-stream>)
  1629.   (def     <stream> <concatenated-stream>)
  1630.   (def     <stream> <two-way-stream>)
  1631.   (def     <stream> <echo-stream>)
  1632.   (def     <stream> <string-stream>)
  1633.   (def <t> <symbol>)
  1634.   (def <t> <sequence>)
  1635.   (def     <sequence> <list>)
  1636.   (def                <list> <cons>)
  1637.   (def                <list> <symbol> <null>)
  1638.   (def <t>            <array>)
  1639.   (def     <sequence> <array> <vector>)
  1640.   (def                        <vector> <bit-vector>)
  1641.   (def                        <vector> <string>)
  1642.   (def <t> <number>)
  1643.   (def     <number> <complex>)
  1644.   (def     <number> <real>)
  1645.   (def              <real> <float>)
  1646.   (def              <real> <rational>)
  1647.   (def                     <rational> <ratio>)
  1648.   (def                     <rational> <integer>)
  1649. )
  1650.  
  1651. ; Weiter Bootstrapping
  1652. (%defclos
  1653.   ; Erkennungszeichen für CLASS-P
  1654.   (svref (get 'class 'sys::defstruct-description) 0)
  1655.   ; Built-In-Klassen für CLASS-OF
  1656.   (vector <array> <bit-vector> <character> <complex> <cons> <float> <function>
  1657.           <hash-table> <integer> <null> <package> <pathname>
  1658.           #+LOGICAL-PATHNAMES <logical-pathname>
  1659.           <random-state> <ratio> <readtable> <standard-generic-function>
  1660.           <stream> <file-stream> <synonym-stream> <broadcast-stream>
  1661.           <concatenated-stream> <two-way-stream> <echo-stream> <string-stream>
  1662.           <string> <symbol> <t> <vector>
  1663. ) )
  1664.  
  1665. ;; Schnitt zweier Built-In-Klassen:
  1666. ; Abweichungen von der Single-Inheritance sind nur
  1667. ; (AND <sequence> <array>) = <vector> und (AND <list> <symbol>) = <null>.
  1668. (defun bc-p (class)
  1669.   (or (built-in-class-p class) (eq class <standard-object>))
  1670. )
  1671. (defun bc-and (class1 class2) ; liefert (AND class1 class2)
  1672.   (cond ((subclassp class1 class2) class1)
  1673.         ((subclassp class2 class1) class2)
  1674.         ((or (and (subclassp <sequence> class1) (subclassp <array> class2))
  1675.              (and (subclassp <sequence> class2) (subclassp <array> class1))
  1676.          )
  1677.          <vector>
  1678.         )
  1679.         ((or (and (subclassp <list> class1) (subclassp <symbol> class2))
  1680.              (and (subclassp <list> class2) (subclassp <symbol> class1))
  1681.          )
  1682.          <null>
  1683.         )
  1684.         (t nil)
  1685. ) )
  1686. (defun bc-and-not (class1 class2) ; liefert eine Klasse c mit
  1687.                                   ; (AND class1 (NOT class2)) <= c <= class1
  1688.   (cond ((subclassp class1 class2) nil)
  1689.         ((and (eq class1 <sequence>) (subclassp <vector> class2)) <list>)
  1690.         ((and (eq class1 <sequence>) (subclassp <list> class2)) <vector>)
  1691.         ((and (eq class1 <list>) (subclassp <null> class2)) <cons>)
  1692.         (t class1)
  1693. ) )
  1694.  
  1695.  
  1696. ;;; Methoden
  1697.  
  1698. (defstruct (standard-method (:conc-name "STD-METHOD-") (:print-function print-std-method))
  1699.   function               ; die Funktion
  1700.   wants-next-method-p    ; Flag, ob als erstes Argument die NEXT-METHOD (als
  1701.                          ; Funktion mit allen Argumenten) bzw. NIL übergeben
  1702.                          ; werden soll (= NIL bei :BEFORE- und :AFTER-Methoden)
  1703.   parameter-specializers ; Liste ({class | (EQL object)}*)
  1704.   qualifiers             ; Liste von Symbolen, z.B. (:before)
  1705.   signature              ; Liste (reqanz optanz restp keyp keywords allowp)
  1706.   gf                     ; die generische Funktion, zu der diese Methode
  1707.                          ; gehört (nur für den Bedarf von NO-NEXT-METHOD)
  1708.   initfunction           ; liefert, wenn aufgerufen, die Funktion
  1709.                          ; (nur für den Bedarf von ADD-METHOD)
  1710. )
  1711.  
  1712. ; Bei NO-NEXT-METHOD muß die generische Funktion bekannt sein. Da allerdings
  1713. ; im Prinzip Methoden nicht bestimmten generischen Funktionen zugehörig sind
  1714. ; (wegen ADD-METHOD), müssen wir die Methode bei ADD-METHOD kopieren. Die
  1715. ; Identität zweier Kopien derselben Methode stellen wir durch Blick auf
  1716. ; std-method-initfunction fest. (Man könnte stattdessen auch die generische
  1717. ; Funktion bei jedem Aufruf mitgeben, als erstes Argument an die effektive
  1718. ; Methode, aber das ist sicher ineffizienter.)
  1719.  
  1720. (defun print-std-method (method stream depth)
  1721.   (declare (ignore depth))
  1722.   (print-unreadable-object (method stream :type t)
  1723.     (dolist (q (std-method-qualifiers method))
  1724.       (write q :stream stream)
  1725.       (write-char #\Space stream)
  1726.     )
  1727.     (write (std-method-parameter-specializers method) :stream stream)
  1728. ) )
  1729.  
  1730. ; Hilfsfunktion: Liefert eine Liste von n Gensyms.
  1731. (defun n-gensyms (n)
  1732.   (do ((l '() (cons (gensym) l))
  1733.        (i n (1- i)))
  1734.       ((eql i 0) l)
  1735. ) )
  1736.  
  1737. ; Hilfsfunktion: Testet auf Lambda-Listen-Marker.
  1738. (defun lambda-list-keyword-p (x)
  1739.   (memq x lambda-list-keywords)
  1740. )
  1741.  
  1742. ;; Für DEFMETHOD, DEFGENERIC, GENERIC-FUNCTION, GENERIC-FLET, GENERIC-LABELS,
  1743. ;; WITH-ADDED-METHODS
  1744.   ; caller: Symbol
  1745.   ; funname: Funktionsname, Symbol oder (SETF symbol)
  1746.   ; description: (qualifier* spec-lambda-list {declaration|docstring}* form*)
  1747.   ; ==> method-building-form
  1748. (defun analyze-method-description (caller funname description env)
  1749.   (let ((qualifiers nil))
  1750.     (loop
  1751.       (when (atom description)
  1752.         (error-of-type 'program-error
  1753.           #L{
  1754.           DEUTSCH "~S ~S: Lambdaliste fehlt."
  1755.           ENGLISH "~S ~S: missing lambda list"
  1756.           FRANCAIS "~S ~S : la liste lambda manque."
  1757.           }
  1758.           caller funname
  1759.       ) )
  1760.       (when (listp (car description)) (return))
  1761.       (push (pop description) qualifiers)
  1762.     )
  1763.     ; Nur STANDARD Methodenkombination ist implementiert.
  1764.     (cond ((equal qualifiers '()))
  1765.           ((equal qualifiers '(:before)))
  1766.           ((equal qualifiers '(:after)))
  1767.           ((equal qualifiers '(:around)))
  1768.           (t (error-of-type 'program-error
  1769.                #L{
  1770.                DEUTSCH "Bei STANDARD Methodenkombination dürfen die Methodenbestimmer nicht ~S lauten."
  1771.                ENGLISH "STANDARD method combination doesn't allow the method qualifiers to be ~S"
  1772.                FRANCAIS "La combinaison STANDARD de méthodes ne permet pas de qualifier des méthodes comme ~S."
  1773.                }
  1774.                (nreverse qualifiers)
  1775.     )     )  )
  1776.     ; Lambdaliste bilden, Parameter-Specializer und Signatur extrahieren:
  1777.     (let ((specialized-lambda-list (car description))
  1778.           (body (cdr description)))
  1779.       (let ((req-vars '())
  1780.             (ignorable-req-vars '())
  1781.             (req-specializer-forms '()))
  1782.         (do ()
  1783.             ((or (atom specialized-lambda-list)
  1784.                  (lambda-list-keyword-p (car specialized-lambda-list))
  1785.             ))
  1786.           (let* ((item (pop specialized-lambda-list))
  1787.                  (specializer-name
  1788.                    (if (atom item)
  1789.                      (progn (push item req-vars) 't)
  1790.                      (progn
  1791.                        (push (first item) req-vars)
  1792.                        (push (first item) ignorable-req-vars) ; CLtL2 S. 840 oben
  1793.                        (second item)
  1794.                 )) ) )
  1795.             (push (if (and (consp specializer-name)
  1796.                            (eq (car specializer-name) 'EQL)
  1797.                       )
  1798.                     `(LIST 'EQL ,(second specializer-name))
  1799.                     `(FIND-CLASS ',specializer-name)
  1800.                   )
  1801.                   req-specializer-forms
  1802.         ) ) )
  1803.         (let* ((reqanz (length req-vars))
  1804.                (lambda-list (nreconc req-vars specialized-lambda-list))
  1805.                (optanz
  1806.                  (let ((h (cdr (member '&OPTIONAL lambda-list :test #'eq))))
  1807.                    (or (position-if #'lambda-list-keyword-p h) (length h))
  1808.                ) )
  1809.                (keyp (not (null (member '&KEY lambda-list :test #'eq))))
  1810.                (restp (or keyp (not (null (member '&REST lambda-list :test #'eq)))))
  1811.                (keywords
  1812.                  (mapcar
  1813.                    #'(lambda (item)
  1814.                        (when (consp item) (setq item (first item)))
  1815.                        (if (consp item)
  1816.                          (first item)
  1817.                          (intern (symbol-name item) *keyword-package*)
  1818.                      ) )
  1819.                    (let ((h (cdr (member '&KEY lambda-list :test #'eq))))
  1820.                      (subseq h 0 (position-if #'lambda-list-keyword-p h))
  1821.                ) ) )
  1822.                (allowp (and keyp (not (null (member '&ALLOW-OTHER-KEYS lambda-list :test #'eq)))))
  1823.               )
  1824.           ; Methoden haben ein implizites &allow-other-keys (28.1.6.4.):
  1825.           (when (and keyp (not allowp))
  1826.             (let ((index (+ (position '&KEY lambda-list :test #'eq) 1 (length keywords))))
  1827.               (setq lambda-list
  1828.                 `(,@(subseq lambda-list 0 index) &ALLOW-OTHER-KEYS
  1829.                   ,@(subseq lambda-list index)
  1830.                  )
  1831.           ) ) )
  1832.           (let* ((self (gensym))
  1833.                  (wants-next-method-p
  1834.                    (or (equal qualifiers '()) (equal qualifiers '(:around)))
  1835.                  )
  1836.                  (compile nil)
  1837.                  (lambdabody
  1838.                    (multiple-value-bind (body-rest declarations docstring)
  1839.                        (sys::parse-body body t env)
  1840.                      (declare (ignore docstring))
  1841.                      (setq compile (member '(COMPILE) declarations :test #'equal))
  1842.                      (when ignorable-req-vars
  1843.                        (push `(IGNORABLE ,@(nreverse ignorable-req-vars))
  1844.                              declarations
  1845.                      ) )
  1846.                      (let ((lambdabody-part1
  1847.                              `(,lambda-list
  1848.                                ,@(if declarations `((DECLARE ,@declarations)))
  1849.                               )
  1850.                            )
  1851.                            (lambdabody-part2
  1852.                              (if (eq caller 'generic-function)
  1853.                                body-rest
  1854.                                ; impliziter Block
  1855.                                `((BLOCK ,(block-name funname) ,@body-rest))
  1856.                           )) )
  1857.                        (if wants-next-method-p
  1858.                          (let ((cont (gensym)) ; Variable für die Continuation
  1859.                                (req-dummies ; Liste von reqanz Dummies
  1860.                                  (n-gensyms reqanz)
  1861.                                )
  1862.                                (rest-dummy (if (or restp (> optanz 0)) (gensym)))
  1863.                                (lambda-expr `(LAMBDA ,@lambdabody-part1 ,@lambdabody-part2)))
  1864.                            `(; neue Lambda-Liste:
  1865.                              (,cont
  1866.                               ,@req-dummies
  1867.                               ,@(if rest-dummy `(&REST ,rest-dummy) '())
  1868.                              )
  1869.                              (MACROLET
  1870.                                ((CALL-NEXT-METHOD (&REST NEW-ARG-EXPRS)
  1871.                                   (IF NEW-ARG-EXPRS
  1872.                                     (LIST 'IF ',cont
  1873.                                       (LIST* 'FUNCALL ',cont NEW-ARG-EXPRS)
  1874.                                       (LIST* '%NO-NEXT-METHOD ',self NEW-ARG-EXPRS)
  1875.                                     )
  1876.                                     ,(if rest-dummy
  1877.                                        `(LIST 'IF ',cont
  1878.                                           (LIST 'APPLY ',cont
  1879.                                             ,@(mapcar #'(lambda (x) `',x) req-dummies)
  1880.                                             ',rest-dummy
  1881.                                           )
  1882.                                           (LIST 'APPLY '(FUNCTION %NO-NEXT-METHOD)
  1883.                                             ',self
  1884.                                             ,@(mapcar #'(lambda (x) `',x) req-dummies)
  1885.                                             ',rest-dummy
  1886.                                         ) )
  1887.                                        `(LIST 'IF ',cont
  1888.                                           (LIST 'FUNCALL ',cont
  1889.                                             ,@(mapcar #'(lambda (x) `',x) req-dummies)
  1890.                                           )
  1891.                                           (LIST '%NO-NEXT-METHOD
  1892.                                             ',self
  1893.                                             ,@(mapcar #'(lambda (x) `',x) req-dummies)
  1894.                                         ) )
  1895.                                      )
  1896.                                 ) )
  1897.                                 (NEXT-METHOD-P () ',cont)
  1898.                                )
  1899.                                ; neuer Body:
  1900.                                ,(if rest-dummy
  1901.                                   `(APPLY (FUNCTION ,lambda-expr)
  1902.                                           ,@req-dummies ,rest-dummy
  1903.                                    )
  1904.                                   `(,lambda-expr ,@req-dummies)
  1905.                                 )
  1906.                             ))
  1907.                          )
  1908.                          `(,@lambdabody-part1
  1909.                            (MACROLET
  1910.                              ((CALL-NEXT-METHOD ()
  1911.                                 (ERROR-OF-TYPE 'PROGRAM-ERROR
  1912.                                   #L{
  1913.                                   DEUTSCH "~S ~S: ~S ist in ~S-Methoden nicht erlaubt."
  1914.                                   ENGLISH "~S ~S: ~S is invalid within ~S methods"
  1915.                                   FRANCAIS "~S ~S : ~S n'est pas permit dans des méthodes ~S."
  1916.                                   }
  1917.                                   ',caller ',funname 'CALL-NEXT-METHOD ',(first qualifiers)
  1918.                               ) )
  1919.                               (NEXT-METHOD-P ()
  1920.                                 (ERROR-OF-TYPE 'PROGRAM-ERROR
  1921.                                   #L{
  1922.                                   DEUTSCH "~S ~S: ~S ist in ~S-Methoden nicht erlaubt."
  1923.                                   ENGLISH "~S ~S: ~S is invalid within ~S methods"
  1924.                                   FRANCAIS "~S ~S : ~S n'est pas permit dans des méthodes ~S."
  1925.                                   }
  1926.                                   ',caller ',funname 'NEXT-METHOD-P ',(first qualifiers)
  1927.                              )) )
  1928.                              ,@lambdabody-part2
  1929.                           ))
  1930.                 )) ) ) )
  1931.             `(MAKE-STANDARD-METHOD
  1932.                :INITFUNCTION
  1933.                  #'(LAMBDA (,self)
  1934.                      ,@(if compile '((DECLARE (COMPILE))))
  1935.                      (%OPTIMIZE-FUNCTION-LAMBDA
  1936.                        ,(if wants-next-method-p `(T) `())
  1937.                        ,@lambdabody
  1938.                    ) )
  1939.                :WANTS-NEXT-METHOD-P ',wants-next-method-p
  1940.                :PARAMETER-SPECIALIZERS (LIST ,@(nreverse req-specializer-forms))
  1941.                :QUALIFIERS ',qualifiers
  1942.                :SIGNATURE '(,reqanz ,optanz ,restp ,keyp ,keywords ,allowp)
  1943.              )
  1944. ) ) ) ) ) )
  1945.  
  1946. ;; 28.1.6.3. agreement on parameter specializers and qualifiers
  1947. (defun methods-agree-p (method1 method2)
  1948.   (and (equal (std-method-qualifiers method1) (std-method-qualifiers method2))
  1949.        (specializers-agree-p (std-method-parameter-specializers method1)
  1950.                              (std-method-parameter-specializers method2)
  1951. ) )    )
  1952. (defun specializers-agree-p (specializers1 specializers2)
  1953.   (and (eql (length specializers1) (length specializers2))
  1954.        (every #'(lambda (parspec1 parspec2)
  1955.                   (or ; zwei gleiche Klassen?
  1956.                       (eq parspec1 parspec2)
  1957.                       ; zwei gleiche EQL-Specializer?
  1958.                       (and (consp parspec1) (consp parspec2)
  1959.                            (eql (second parspec1) (second parspec2))
  1960.                 ) )   )
  1961.               specializers1 specializers2
  1962. ) )    )
  1963.  
  1964. ;; 28.1.6.2. applicable methods
  1965. (defun method-applicable-p (method required-arguments)
  1966.   (every #'typep required-arguments (std-method-parameter-specializers method))
  1967. )
  1968.  
  1969. ;; 28.1.7.1. sorting the applicable methods by precedence order
  1970. (defun sort-applicable-methods (methods required-arguments argument-order)
  1971.   (sort (copy-list methods)
  1972.         #'(lambda (method1 method2) ; method1 < method2 ?
  1973.             (let ((specializers1 (std-method-parameter-specializers method1))
  1974.                   (specializers2 (std-method-parameter-specializers method2)))
  1975.               (dolist (arg-index argument-order nil)
  1976.                 (let ((arg (nth arg-index required-arguments))
  1977.                       (psp1 (nth arg-index specializers1))
  1978.                       (psp2 (nth arg-index specializers2)))
  1979.                   (if (consp psp1)
  1980.                     (if (consp psp2)
  1981.                       nil        ; (EQL x) = (EQL x)
  1982.                       (return t) ; (EQL x) < <class>  ==>  method1 < method2
  1983.                     )
  1984.                     (if (consp psp2)
  1985.                       (return nil) ; <class> > (EQL x)   ==>  method1 > method2
  1986.                       ; Zwei Klassen: vergleiche die Position in der CPL von arg:
  1987.                       (let* ((cpl (class-precedence-list (class-of arg)))
  1988.                              (pos1 (position psp1 cpl))
  1989.                              (pos2 (position psp2 cpl)))
  1990.                         (cond ((< pos1 pos2) (return t)) ; method1 < method2
  1991.                               ((> pos1 pos2) (return nil)) ; method1 > method2
  1992.                       ) )
  1993.           ) ) ) ) ) )
  1994. ) )
  1995.  
  1996. ; Für STANDARD Methodenkombination: Aufspalten der Methoden nach Qualifiern
  1997. (defun partition-method-list (methods)
  1998.   (let ((primary-methods '())
  1999.         (before-methods '())
  2000.         (after-methods '())
  2001.         (around-methods '()))
  2002.     (dolist (method methods)
  2003.       (let ((quals (std-method-qualifiers method)))
  2004.         (cond ((equal quals '())        (push method primary-methods))
  2005.               ((equal quals '(:before)) (push method before-methods))
  2006.               ((equal quals '(:after))  (push method after-methods))
  2007.               ((equal quals '(:around)) (push method around-methods))
  2008.     ) ) )
  2009.     (values
  2010.       (nreverse primary-methods)
  2011.       (nreverse before-methods)
  2012.       (nreverse after-methods)
  2013.       (nreverse around-methods)
  2014. ) ) )
  2015.  
  2016.  
  2017. ;;; Generische Funktionen
  2018.  
  2019. ; Low-Level-Repräsentation:
  2020. ; Compilierte Funktionen (Cclosures), bei denen im Flag-Byte des Code-Vektors
  2021. ; ein bestimmtes Bit gesetzt ist. Hintendran zusätzlich:
  2022. ; - die Signatur, eine Liste (reqanz optanz restp keywords allowp),
  2023. ; - die Argument-Precedence-Order, als Liste der Zahlen von 0 bis reqanz-1,
  2024. ; - die Liste aller Methoden.
  2025.  
  2026. ; Der Compiler benutzt (bei GENERIC-FLET, GENERIC-LABELS) und der Evaluator
  2027. ; setzt ebenfalls voraus, daß eine generische Funktion ihre Aufrufkonvention
  2028. ; nicht ändert.
  2029. ; Eine generische Funktion mit Signatur (reqanz optanz restp keywords allowp)
  2030. ; ist von Anfang an (!) eine compilierte Funktion mit
  2031. ;         reqanz  required-Parametern
  2032. ;         0       optionalen Parametern
  2033. ;         &rest genau dann wenn (or (> optanz 0) restp),
  2034. ;         ohne &key.
  2035. (defun callinfo (reqanz optanz restp keywords allowp)
  2036.   (declare (ignore keywords allowp))
  2037.   (list reqanz 0 (or (> optanz 0) restp) nil nil nil)
  2038. )
  2039.  
  2040. (defun gf-signature (gf)
  2041.   (sys::%record-ref gf 3)
  2042. )
  2043. (defun (setf gf-signature) (new gf)
  2044.   (setf (sys::%record-ref gf 3) new)
  2045. )
  2046.  
  2047. (defun gf-argorder (gf)
  2048.   (sys::%record-ref gf 4)
  2049. )
  2050. (defun (setf gf-argorder) (new gf)
  2051.   (setf (sys::%record-ref gf 4) new)
  2052. )
  2053.  
  2054. (defun gf-methods (gf)
  2055.   (sys::%record-ref gf 5)
  2056. )
  2057. (defun (setf gf-methods) (new gf)
  2058.   (setf (sys::%record-ref gf 5) new)
  2059. )
  2060.  
  2061. ; Der Dispatch-Code für generische Funktionen wird mit
  2062. ; `(%GENERIC-FUNCTION-LAMBDA ,@lambdabody)
  2063. ; - ähnlich zu `(FUNCTION (LAMBDA ,@lambdabody)) - gebildet.
  2064. ; Es dürfen darin nicht vorkommen:
  2065. ; - Zugriff auf dynamische Variablen, Binden von dynamischen Variablen,
  2066. ; - nichttriviale BLOCK, RETURN-FROM, TAGBODY, GO Konstrukte,
  2067. ; - Aufruf globaler Funktionen, die nicht inline sind,
  2068. ; - Bildung von nicht-autonomen Funktionen (Closures).
  2069. ; Nötig ist also:
  2070. ;   (declare (inline case eql eq typep
  2071. ;                    arrayp bit-vector-p characterp complexp consp floatp
  2072. ;                    functionp clos::generic-function-p hash-table-p integerp
  2073. ;                    listp null numberp packagep pathnamep sys::logical-pathname-p
  2074. ;                    random-state-p rationalp readtablep realp sys::sequencep
  2075. ;                    clos::std-instance-p streamp sys::file-stream-p
  2076. ;                    sys::synonym-stream-p sys::broadcast-stream-p
  2077. ;                    sys::concatenated-stream-p sys::two-way-stream-p
  2078. ;                    sys::echo-stream-p sys::string-stream-p stringp symbolp
  2079. ;                    vectorp
  2080. ;                    class-of cons gethash funcall apply ...
  2081. ;   )        )
  2082. ; Das Ergebnis ist nicht(!) als eigenständige Funktion aufrufbar, sondern
  2083. ; bedarf der Nachbearbeitung: Die Konstanten C_0 ... C_(k-1) C_k müssen zu
  2084. ; #(C_0 ... C_(k-1) . [Rest von C_k]) zusammengefaßt werden, k = 0 oder 1.
  2085.  
  2086. ; Liefert eine generische Funktion ohne Dispatch-Code. Nicht aufrufbar!!
  2087. (let* ((prototype ; eine sinnlose Funktion
  2088.          #'(lambda (&rest args) (declare (compile) (ignore args))
  2089.              (tagbody 1 (go 1))
  2090.            )
  2091.        )
  2092.        (prototype-code (sys::%record-ref prototype 1)))
  2093.   (defun %make-gf (name signature argorder methods)
  2094.     (sys::%make-closure name prototype-code
  2095.                         (list nil signature argorder methods)
  2096.   ) )
  2097. )
  2098.  
  2099. #|
  2100. ; Besser in compiler.lsp??
  2101. (defun make-gf (name lambdabody signature argorder methods)
  2102.   (let ((preliminary
  2103.           (eval `(LET ()
  2104.                    (DECLARE (COMPILE))
  2105.                    (%GENERIC-FUNCTION-LAMBDA ,@lambdabody)
  2106.                  )
  2107.        )) )
  2108.     (sys::%make-closure
  2109.       name
  2110.       (sys::closure-codevec preliminary)
  2111.       (list
  2112.         (case (sys::%record-length preliminary)
  2113.           (3 (sys::%record-ref preliminary 2))
  2114.           (4 (let ((consts (sys::%record-ref preliminary 3)))
  2115.                (setf (svref consts 0) (sys::%record-ref preliminary 2))
  2116.                consts
  2117.         ) )  )
  2118.         signature
  2119.         argorder
  2120.         methods
  2121. ) ) ) )
  2122. |#
  2123.  
  2124.  
  2125. #|
  2126.  
  2127. ;; Generische Funktionen mit primitivem Dispatch:
  2128.  
  2129. (defun make-slow-gf (name signature argorder methods)
  2130.   (let* ((final (%make-gf name signature argorder methods))
  2131.          (preliminary
  2132.            (eval `(LET ((GF ',final))
  2133.                     (DECLARE (COMPILE))
  2134.                     (%GENERIC-FUNCTION-LAMBDA (&REST ARGS)
  2135.                       (DECLARE (INLINE APPLY))
  2136.                       (APPLY 'SLOW-FUNCALL-GF GF ARGS)
  2137.                   ) )
  2138.         )) )
  2139.     (setf (sys::%record-ref final 1) (sys::closure-codevec preliminary))
  2140.     (setf (sys::%record-ref final 2)
  2141.           (case (sys::%record-length preliminary)
  2142.             (3 (sys::%record-ref preliminary 2))
  2143.             (4 (let ((consts (sys::%record-ref preliminary 3)))
  2144.                  (setf (svref consts 0) (sys::%record-ref preliminary 2))
  2145.                  consts
  2146.           ) )  )
  2147.     )
  2148.     final
  2149. ) )
  2150.  
  2151. (let* ((prototype
  2152.          (let ((gf 'magic))
  2153.            (declare (compile))
  2154.            (%generic-function-lambda (&rest args)
  2155.              (declare (inline apply))
  2156.              (apply 'slow-funcall-gf gf args)
  2157.        ) ) )
  2158.        (prototype-code (sys::%record-ref prototype 1))
  2159.        (prototype-consts (sys::%record-ref prototype 3)))
  2160.   (defun finalize-slow-gf (gf)
  2161.     (setf (sys::%record-ref gf 1) prototype-code)
  2162.     (setf (sys::%record-ref gf 2) (substitute gf 'magic prototype-consts))
  2163.   )
  2164.   (defun gf-never-called-p (gf) (eq (sys::%record-ref gf 1) prototype-code))
  2165.   (defun warn-if-gf-already-called (gf) )
  2166. )
  2167.  
  2168. ; Aufruf einer generischen Funktion
  2169. (defun slow-funcall-gf (gf &rest args)
  2170.   (let ((reqanz (first (gf-signature gf)))
  2171.         (arg-order (gf-argorder gf))
  2172.         (methods (gf-methods gf)))
  2173.     (unless (>= (length args) reqanz)
  2174.       (error-of-type 'error
  2175.         #L{
  2176.         DEUTSCH "Zu wenig Argumente für ~S: ~S"
  2177.         ENGLISH "Too few arguments to ~S: ~S"
  2178.         FRANCAIS "Trop peu d'arguments pour ~S : ~S"
  2179.         }
  2180.         gf args
  2181.     ) )
  2182.     (let ((req-args (subseq args 0 reqanz)))
  2183.       ; Determine the effective method:
  2184.       ; 1. Select the applicable methods:
  2185.       (setq methods
  2186.         (remove-if-not #'(lambda (method) (method-applicable-p method req-args))
  2187.                        methods
  2188.       ) )
  2189.       (when (null methods)
  2190.         (return-from slow-funcall-gf (apply #'no-applicable-method gf args))
  2191.       )
  2192.       ; 2. Sort the applicable methods by precedence order:
  2193.       (setq methods (sort-applicable-methods methods req-args arg-order))
  2194.       ; 3. Apply method combination:
  2195.       ; Nur STANDARD Methoden-Kombination ist implementiert.
  2196.       ; Aufspalten in einzelne Methoden-Typen:
  2197.       (multiple-value-bind (primary-methods before-methods after-methods around-methods)
  2198.           (partition-method-list methods)
  2199.         (when (null primary-methods)
  2200.           (return-from slow-funcall-gf (apply #'no-primary-method gf args))
  2201.         )
  2202.         ; Methoden zu einer "effektiven Methode" kombinieren:
  2203.         (labels ((ef-1 (primary-methods before-methods after-methods around-methods)
  2204.                    (if (null around-methods)
  2205.                      (ef-2 primary-methods before-methods after-methods)
  2206.                      (let* ((1method (first around-methods))
  2207.                             (1function (std-method-function 1method)))
  2208.                        (if (std-method-wants-next-method-p 1method)
  2209.                          (let ((next-ef
  2210.                                  (ef-1 primary-methods before-methods after-methods (rest around-methods))
  2211.                               ))
  2212.                            #'(lambda (&rest args) (apply 1function next-ef args))
  2213.                          )
  2214.                          #'(lambda (&rest args) (apply 1function args))
  2215.                  ) ) ) )
  2216.                  (ef-2 (primary-methods before-methods after-methods)
  2217.                    (if (null after-methods)
  2218.                      (ef-3 primary-methods before-methods)
  2219.                      (let* ((1method (first after-methods))
  2220.                             (1function (std-method-function 1method)))
  2221.                        (let ((next-ef (ef-2 primary-methods before-methods (rest after-methods))))
  2222.                          #'(lambda (&rest args) (multiple-value-prog1 (apply next-ef args) (apply 1function args)))
  2223.                  ) ) ) )
  2224.                  (ef-3 (primary-methods before-methods)
  2225.                    (if (null before-methods)
  2226.                      (ef-4 primary-methods)
  2227.                      (let* ((1method (first before-methods))
  2228.                             (1function (std-method-function 1method)))
  2229.                        (let ((next-ef (ef-3 primary-methods (rest before-methods))))
  2230.                          #'(lambda (&rest args) (progn (apply 1function args) (apply next-ef args)))
  2231.                  ) ) ) )
  2232.                  (ef-4 (primary-methods)
  2233.                    (if (null primary-methods)
  2234.                      nil ; keine Funktion, NEXT-METHOD-P reagiert darauf
  2235.                      (let* ((1method (first primary-methods))
  2236.                             (1function (std-method-function 1method)))
  2237.                        (if (std-method-wants-next-method-p 1method)
  2238.                          (let ((next-ef (ef-4 (rest primary-methods))))
  2239.                            #'(lambda (&rest args) (apply 1function next-ef args))
  2240.                          )
  2241.                          #'(lambda (&rest args) (apply 1function args))
  2242.                 )) ) ) )
  2243.           (let ((ef (ef-1 primary-methods before-methods after-methods around-methods)))
  2244.             ; Keyword-Check (28.1.6.4., 28.1.6.5.) ??
  2245.             ; Effektive Methode aufrufen:
  2246.             (funcall ef args)
  2247. ) ) ) ) ) )
  2248.  
  2249. |#
  2250.  
  2251.  
  2252. ;; Generische Funktionen mit optimiertem Dispatch:
  2253.  
  2254. (defun make-fast-gf (name signature argorder)
  2255.   (let ((gf (%make-gf name signature argorder '())))
  2256.     (finalize-fast-gf gf)
  2257.     gf
  2258. ) )
  2259.  
  2260. (let ((prototype-table (make-hash-table :test #'equal)))
  2261.   (defun finalize-fast-gf (gf)
  2262.     (let* ((signature (gf-signature gf))
  2263.            (reqanz (first signature))
  2264.            (restp (or (third signature) (> (second signature) 0)))
  2265.            (hash-key (cons reqanz restp))
  2266.            (prototype
  2267.              (or (gethash hash-key prototype-table)
  2268.                  (setf (gethash hash-key prototype-table)
  2269.                        (let* ((reqvars (n-gensyms reqanz))
  2270.                               (proto-gf
  2271.                                 (eval `(LET ((GF 'MAGIC))
  2272.                                          (DECLARE (COMPILE))
  2273.                                          (%GENERIC-FUNCTION-LAMBDA (,@reqvars ,@(if restp '(&REST ARGS) '()))
  2274.                                            (DECLARE (INLINE APPLY))
  2275.                                            (APPLY 'INITIAL-FUNCALL-GF GF ,@reqvars ,(if restp `ARGS `'NIL))
  2276.                                        ) )
  2277.                              )) )
  2278.                          ; (sys::%record-ref proto-gf 1) müssen wir aufbewahren.
  2279.                          ; (sys::%record-ref proto-gf 3) = #(NIL INITIAL-FUNCALL-GF MAGIC)
  2280.                          (sys::%record-ref proto-gf 1)
  2281.           )) )   )     )
  2282.       (setf (sys::%record-ref gf 1) prototype)
  2283.       (setf (sys::%record-ref gf 2) (vector 'NIL 'INITIAL-FUNCALL-GF gf))
  2284.   ) )
  2285.   (defun gf-never-called-p (gf)
  2286.     (let* ((signature (gf-signature gf))
  2287.            (reqanz (first signature))
  2288.            (restp (or (third signature) (> (second signature) 0)))
  2289.            (hash-key (cons reqanz restp))
  2290.            (prototype (gethash hash-key prototype-table)))
  2291.       (eq (sys::%record-ref gf 1) prototype)
  2292.   ) )
  2293.   (defun warn-if-gf-already-called (gf)
  2294.     (unless (gf-never-called-p gf)
  2295.       (warn 
  2296.        #L{
  2297.        DEUTSCH "Die generische Funktion ~S wird modifiziert, wurde aber bereits aufgerufen."
  2298.        ENGLISH "The generic function ~S is being modified, but has already been called."
  2299.        FRANCAIS "On change la fonction générique ~S qui a déjà été appelée."
  2300.        }
  2301.             gf
  2302.   ) ) )
  2303. )
  2304.  
  2305. ; Der eigentliche Dispatch-Code wird erst beim ersten Aufruf der funktion
  2306. ; berechnet, um aufeinanderfolgende Methoden-Definitionen nicht zu teuer
  2307. ; zu machen.
  2308.  
  2309. ; Erster Aufruf einer generischen Funktion:
  2310. (defun initial-funcall-gf (gf &rest args)
  2311.   (install-dispatch gf)
  2312.   (apply gf args)
  2313. )
  2314.  
  2315. ; Installiert den endgültigen Dispatch-Code in eine generische Funktion.
  2316. (defun install-dispatch (gf)
  2317.   (multiple-value-bind (bindings lambdabody) (compute-dispatch gf)
  2318.     (let ((preliminary
  2319.             (eval `(LET ,bindings
  2320.                      (DECLARE (COMPILE))
  2321.                      (%GENERIC-FUNCTION-LAMBDA ,@lambdabody)
  2322.                    )
  2323.          )) )
  2324.       (setf (sys::%record-ref gf 1) (sys::%record-ref preliminary 1))
  2325.       (setf (sys::%record-ref gf 2)
  2326.             (let ((consts (sys::%record-ref preliminary 3)))
  2327.                (setf (svref consts 0) (sys::%record-ref preliminary 2))
  2328.                consts
  2329.       )     )
  2330. ) ) )
  2331.  
  2332. ; Berechnet den Dispatch-Code einer generischen Funktion.
  2333. ; Er hat folgendes Aussehen:
  2334. ; (LAMBDA (variablen)      ; die required einzeln, alles andere mit &rest
  2335. ;   (DECLARE (INLINE ...)) ; alles inline wegen %GENERIC-FUNCTION-LAMBDA
  2336. ;   If-Kaskaden, dabei werden EQL-Parameter-Specializer und die meisten
  2337. ;   Builtin-Klassen per TYPEP inline abgefragt.
  2338. ;   Für die anderen required-Parameter wird CLASS-OF aufgerufen, die Ergebnisse
  2339. ;   gesammelt und als Index in eine Hash-Tabelle genommen. Dort steht die
  2340. ;   effektive Methode:
  2341. ;   (LET ((EM (GETHASH (CONS (CLASS-OF ...) ...) ht1)))
  2342. ;     (WHEN EM (RETURN-FROM block (APPLY EM Argumente)))
  2343. ;   )
  2344. ;   Wenn das nicht gelungen ist:
  2345. ;   (APPLY 'COMPUTE-AND-ADD-EFFECTIVE-METHOD gf Argumente)
  2346. ; )
  2347. (defun compute-dispatch (gf)
  2348.   (let* ((signature (gf-signature gf))
  2349.          (req-anz (first signature))
  2350.          (req-vars (n-gensyms req-anz))
  2351.          (restp (or (third signature) (> (second signature) 0)))
  2352.          (rest-var (if restp (gensym)))
  2353.          (apply-fun (if restp 'APPLY 'FUNCALL))
  2354.          (apply-args `(,@req-vars ,@(if restp `(,rest-var) '())))
  2355.          (arg-order (gf-argorder gf))
  2356.          (methods (gf-methods gf))
  2357.          (block-name (gensym))
  2358.          (maybe-no-applicable nil)
  2359.          (ht-vars '())) ; Liste von Hashtabellen-Variablen und ihren Inits
  2360.     ; Wir machen eine Rekursion über die Argumente.
  2361.     (labels
  2362.        ((recursion (remaining-args ; ein nthcdr von arg-order
  2363.                     remaining-methods ; Teilliste von methods
  2364.                     class-of-exprs ; Liste von CLASS-OF Expressions
  2365.                    )
  2366.           (if (null remaining-methods)
  2367.             (progn
  2368.               (setq maybe-no-applicable t)
  2369.               'NIL ; nichts tun, später NO-APPLICABLE-METHOD aufrufen
  2370.             )
  2371.             (if (null remaining-args)
  2372.               ; alle Argumente abgearbeitet
  2373.               #| ; benutze GETHASH :
  2374.               (let ((ht-var (gensym))
  2375.                     (n (length class-of-exprs)) ; indiziere mit n-Tupeln
  2376.                     ht-init ; Expression zum Initialisieren von ht-var
  2377.                     ht-key-binding ; Bindung einer Variablen an ein n-Tupel
  2378.                     em-expr ; Expression zum Auffinden der EM
  2379.                     setf-em-expr ; Expression-Teil zum Setzen der EM
  2380.                    )
  2381.                 (if (eql n 0)
  2382.                   (setq ht-init 'NIL
  2383.                         ht-key-binding '()
  2384.                         em-expr ht-var
  2385.                         setf-em-expr `(SETQ ,ht-var)
  2386.                   )
  2387.                   (let ((tuple-var (gensym)))
  2388.                     (setq ht-init
  2389.                           `(MAKE-HASH-TABLE
  2390.                              :TEST (FUNCTION ,(if (eql n 1) 'EQ 'EQUAL))
  2391.                            )
  2392.                           ht-key-binding
  2393.                           `((,tuple-var
  2394.                              ,(let ((tuple-fun (hash-tuple-function n)))
  2395.                                 (if (member '&rest (second tuple-fun))
  2396.                                   `(,tuple-fun ,@(reverse class-of-exprs))
  2397.                                   ; kein &rest -> kann optimieren
  2398.                                   ; (der Compiler kann's noch nicht so gut)
  2399.                                   (sublis (mapcar #'cons (second tuple-fun) (reverse class-of-exprs))
  2400.                                           (third tuple-fun)
  2401.                               ) ) )
  2402.                            ))
  2403.                           em-expr
  2404.                           `(GETHASH ,tuple-var ,ht-var)
  2405.                           setf-em-expr
  2406.                           ; `(SETF (GETHASH ,tuple-var ,ht-var)) ginge auch;
  2407.                           ; das Folgende spart aber zwei temporäre Variablen:
  2408.                           `(SYSTEM::PUTHASH ,tuple-var ,ht-var)
  2409.                 ) ) )
  2410.                 (push (list ht-var ht-init) ht-vars)
  2411.                 `(LET ,ht-key-binding
  2412.                    (RETURN-FROM ,block-name
  2413.                      (,apply-fun
  2414.                       (OR ,em-expr
  2415.                           (,@setf-em-expr
  2416.                                 (,apply-fun 'COMPUTE-EFFECTIVE-METHOD ',gf nil
  2417.                                             ,@apply-args
  2418.                       )   )     )
  2419.                       ,@apply-args
  2420.                  ) ) )
  2421.               )
  2422.               |# ; benutze CLASS-GETHASH und CLASS-TUPLE-GETHASH :
  2423.               (let ((ht-var (gensym))
  2424.                     (n (length class-of-exprs)) ; indiziere mit n-Tupeln
  2425.                     ht-init ; Expression zum Initialisieren von ht-var
  2426.                     em-expr ; Expression zum Auffinden der EM
  2427.                     setf-em-expr ; Expression-Teil zum Setzen der EM
  2428.                    )
  2429.                 (if (eql n 0)
  2430.                   (setq ht-init 'NIL
  2431.                         em-expr ht-var
  2432.                         setf-em-expr `(SETQ ,ht-var)
  2433.                   )
  2434.                   (setq class-of-exprs
  2435.                         (reverse class-of-exprs)
  2436.                         ht-init
  2437.                         `(MAKE-HASH-TABLE
  2438.                            :TEST (FUNCTION ,(if (eql n 1) 'EQ 'EQUAL))
  2439.                          )
  2440.                         em-expr
  2441.                         (if (eql n 1) ; je nachdem welches schneller ist
  2442.                           ; `(GETHASH ,@class-of-exprs ,ht-var) ==
  2443.                           `(CLASS-GETHASH ,ht-var ,(second (first class-of-exprs)))
  2444.                           `(CLASS-TUPLE-GETHASH ,ht-var ,@(mapcar #'second class-of-exprs))
  2445.                         )
  2446.                         setf-em-expr
  2447.                         `(SYSTEM::PUTHASH
  2448.                           ,(let ((tuple-fun (hash-tuple-function n)))
  2449.                              (if (member '&rest (second tuple-fun))
  2450.                                `(,tuple-fun ,@class-of-exprs)
  2451.                                ; kein &rest -> kann optimieren
  2452.                                ; (der Compiler kann's noch nicht so gut)
  2453.                                (sublis (mapcar #'cons (second tuple-fun) class-of-exprs)
  2454.                                        (third tuple-fun)
  2455.                            ) ) )
  2456.                           ,ht-var
  2457.                          )
  2458.                 ) )
  2459.                 (push (list ht-var ht-init) ht-vars)
  2460.                 `(RETURN-FROM ,block-name
  2461.                    (,apply-fun
  2462.                     (OR ,em-expr
  2463.                         (,@setf-em-expr
  2464.                               (,apply-fun 'COMPUTE-EFFECTIVE-METHOD ',gf nil
  2465.                                           ,@apply-args
  2466.                     )   )     )
  2467.                     ,@apply-args
  2468.                  ) )
  2469.               )
  2470.               ; nächstes Argument abarbeiten:
  2471.               (let* ((arg-index (first remaining-args))
  2472.                      (arg-var (nth arg-index req-vars))
  2473.                      (eql-cases ; alle EQL-Specializer für dieses Argument
  2474.                        (remove-duplicates
  2475.                          (mapcar #'second
  2476.                            (remove-if-not #'consp
  2477.                              (mapcar #'(lambda (m)
  2478.                                          (nth arg-index
  2479.                                            (std-method-parameter-specializers m)
  2480.                                        ) )
  2481.                                remaining-methods
  2482.                          ) ) )
  2483.                          :test #'eql
  2484.                      ) )
  2485.                      (eql-caselist ; Fall-Liste für CASE
  2486.                        (mapcar
  2487.                          #'(lambda (object)
  2488.                              `((,object)
  2489.                                ,(recursion
  2490.                                   (cdr remaining-args)
  2491.                                   (remove-if-not
  2492.                                     #'(lambda (m)
  2493.                                         (typep object
  2494.                                           (nth arg-index
  2495.                                             (std-method-parameter-specializers m)
  2496.                                       ) ) )
  2497.                                     remaining-methods
  2498.                                   )
  2499.                                   class-of-exprs
  2500.                                 )
  2501.                               )
  2502.                            )
  2503.                          eql-cases
  2504.                     )) )
  2505.                 ; Fürs weitere brauchen wir die EQL-Methoden nicht mehr zu
  2506.                 ; betrachten.
  2507.                 (setq remaining-methods
  2508.                       (remove-if
  2509.                         #'(lambda (m)
  2510.                             (consp
  2511.                               (nth arg-index
  2512.                                 (std-method-parameter-specializers m)
  2513.                           ) ) )
  2514.                         remaining-methods
  2515.                 )     )
  2516.                 ((lambda (other-cases)
  2517.                    (if eql-caselist
  2518.                      `(CASE ,arg-var ,@eql-caselist (T ,other-cases))
  2519.                      other-cases
  2520.                  ) )
  2521.                  (let ((classes
  2522.                          (delete <t>
  2523.                            (delete-duplicates
  2524.                              (mapcar #'(lambda (m)
  2525.                                          (nth arg-index
  2526.                                            (std-method-parameter-specializers m)
  2527.                                        ) )
  2528.                                      remaining-methods
  2529.                       )) ) ) )
  2530.                    ; Falls alle Klassen, auf die zu testen ist,
  2531.                    ; Built-In-Klassen sind, machen wir den Typ-Dispatch
  2532.                    ; inline. Denn in der Hierarchie der Built-In-Klassen
  2533.                    ; (die außer NULL und VECTOR keine mehrfache Vererbung
  2534.                    ; kennt) sind alle CPLs konsistent. Man kann daher mit
  2535.                    ; (subclassp (class-of obj) class) == (typep obj class)
  2536.                    ; arbeiten.
  2537.                    ; Im anderen Fall ist sowieso ein Hash-Tabellen-Zugriff
  2538.                    ; nötig, dann sparen wir uns den Test auf die Built-In-
  2539.                    ; Klassen und beziehen ihn in die Hash-Tabelle ein.
  2540.                    (if (and (every #'bc-p classes)
  2541.                             (<= (length classes) 5) ; zu viele Fälle -> hashen
  2542.                        )
  2543.                      (labels
  2544.                         ((built-in-subtree (class remaining-classes remaining-methods)
  2545.                            ; behandelt die Fälle, daß das Argument der Klasse
  2546.                            ; class angehört und auf Zugehörigkeit zu einer der
  2547.                            ; remaining-classes abgeprüft werden muß.
  2548.                            ; (Man kann voraussetzen, daß (bc-and class x) /= nil
  2549.                            ; für alle x aus remaining-classes.)
  2550.                            (if (null remaining-classes)
  2551.                              ; Keine Fallunterscheidung mehr nötig
  2552.                              (recursion
  2553.                                (cdr remaining-args)
  2554.                                (remove-if-not
  2555.                                  #'(lambda (m)
  2556.                                      (bc-and class
  2557.                                        (nth arg-index
  2558.                                          (std-method-parameter-specializers m)
  2559.                                    ) ) )
  2560.                                  remaining-methods
  2561.                                )
  2562.                                class-of-exprs
  2563.                              )
  2564.                              ; Fallunterscheidung mittels TYPEP
  2565.                              (let ((test-class (first remaining-classes)))
  2566.                                ; besser test-class maximal wählen:
  2567.                                (loop
  2568.                                  (let ((other-class
  2569.                                          (find-if
  2570.                                            #'(lambda (x)
  2571.                                                (and (subclassp test-class x)
  2572.                                                     (not (eq test-class x))
  2573.                                              ) )
  2574.                                            remaining-classes
  2575.                                       )) )
  2576.                                    (unless other-class (return))
  2577.                                    (setq test-class other-class)
  2578.                                ) )
  2579.                                `(IF (TYPEP ,arg-var ',(class-classname test-class))
  2580.                                   ,(built-in-subtree
  2581.                                      (bc-and class test-class) ; /= nil !
  2582.                                      (remove 'nil
  2583.                                        (mapcar
  2584.                                          #'(lambda (x) (bc-and x test-class))
  2585.                                          (remove test-class remaining-classes)
  2586.                                      ) )
  2587.                                      (remove-if-not
  2588.                                        #'(lambda (m)
  2589.                                            (bc-and
  2590.                                              (nth arg-index
  2591.                                                (std-method-parameter-specializers m)
  2592.                                              )
  2593.                                              test-class
  2594.                                          ) )
  2595.                                        remaining-methods
  2596.                                    ) )
  2597.                                   ,(built-in-subtree
  2598.                                      (bc-and-not class test-class) ; /= nil !
  2599.                                      (remove 'nil
  2600.                                        (mapcar
  2601.                                          #'(lambda (x) (bc-and-not x test-class))
  2602.                                          remaining-classes
  2603.                                      ) )
  2604.                                      (remove-if-not
  2605.                                        #'(lambda (m)
  2606.                                            (bc-and-not
  2607.                                              (nth arg-index
  2608.                                                (std-method-parameter-specializers m)
  2609.                                              )
  2610.                                              test-class
  2611.                                          ) )
  2612.                                        remaining-methods
  2613.                                    ) )
  2614.                                 )
  2615.                         )) ) )
  2616.                        (built-in-subtree <t> classes remaining-methods)
  2617.                      )
  2618.                      (recursion
  2619.                        (cdr remaining-args)
  2620.                        remaining-methods
  2621.                        (cons `(CLASS-OF ,arg-var) class-of-exprs)
  2622.                 )) ) )
  2623.        )) ) ) )
  2624.       (let ((form (recursion arg-order methods '())))
  2625.         (values
  2626.           ; bindings
  2627.           (nreverse ht-vars)
  2628.           ; lambdabody
  2629.           `((,@req-vars ,@(if restp `(&REST ,rest-var) '()))
  2630.             (DECLARE
  2631.               (INLINE ; für die Fallunterscheidungen:
  2632.                       CASE EQL EQ TYPEP
  2633.                       ; bei der Inline-Expansion von TYPEP auf Built-In-Klassen:
  2634.                       ARRAYP BIT-VECTOR-P CHARACTERP COMPLEXP CONSP FLOATP
  2635.                       FUNCTIONP CLOS::GENERIC-FUNCTION-P HASH-TABLE-P INTEGERP
  2636.                       LISTP NULL NUMBERP PACKAGEP PATHNAMEP SYS::LOGICAL-PATHNAME-P
  2637.                       RANDOM-STATE-P RATIONALP READTABLEP REALP SYS::SEQUENCEP
  2638.                       CLOS::STD-INSTANCE-P STREAMP SYS::FILE-STREAM-P
  2639.                       SYS::SYNONYM-STREAM-P SYS::BROADCAST-STREAM-P
  2640.                       SYS::CONCATENATED-STREAM-P SYS::TWO-WAY-STREAM-P
  2641.                       SYS::ECHO-STREAM-P SYS::STRING-STREAM-P STRINGP SYMBOLP
  2642.                       VECTORP
  2643.                       ; Finden und Aufruf der effektiven Methode:
  2644.                       CLASS-OF CONS GETHASH CLASS-GETHASH CLASS-TUPLE-GETHASH
  2645.                       SYS::PUTHASH FUNCALL APPLY
  2646.             ) )
  2647.             (BLOCK ,block-name
  2648.               ,form
  2649.               ,@(if maybe-no-applicable
  2650.                   `((,apply-fun 'NO-APPLICABLE-METHOD ',gf ,@apply-args))
  2651.                 )
  2652.            ))
  2653. ) ) ) ) )
  2654.  
  2655. ; Unsere EQUAL-Hashfunktion schaut in Cons-Bäume nur bis Tiefe 4 hinein.
  2656. ; Ein Tupel aus maximal 16 Elementen kann zu einem solchen Baum gemacht werden.
  2657. (defun hash-tuple-function (n) ; n>0
  2658.   (case n
  2659.     (1 '(lambda (t1) t1))
  2660.     (2 '(lambda (t1 t2) (cons t1 t2)))
  2661.     (3 '(lambda (t1 t2 t3) (cons t1 (cons t2 t3))))
  2662.     (4 '(lambda (t1 t2 t3 t4) (cons (cons t1 t2) (cons t3 t4))))
  2663.     (5 '(lambda (t1 t2 t3 t4 t5) (cons (cons t1 t2) (cons t3 (cons t4 t5)))))
  2664.     (6 '(lambda (t1 t2 t3 t4 t5 t6)
  2665.           (cons (cons t1 t2) (cons (cons t3 t4) (cons t5 t6))) ))
  2666.     (7 '(lambda (t1 t2 t3 t4 t5 t6 t7)
  2667.           (cons (cons t1 (cons t2 t3)) (cons (cons t4 t5) (cons t6 t7))) ))
  2668.     (8 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8)
  2669.           (cons (cons (cons t1 t2) (cons t3 t4)) (cons (cons t5 t6) (cons t7 t8))) ))
  2670.     (9 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9)
  2671.           (cons (cons (cons t1 t2) (cons t3 t4)) (cons (cons t5 t6) (cons t7 (cons t8 t9)))) ))
  2672.     (10 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
  2673.            (cons (cons (cons t1 t2) (cons t3 t4)) (cons (cons t5 t6) (cons (cons t7 t8) (cons t9 t10)))) ))
  2674.     (11 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11)
  2675.            (cons (cons (cons t1 t2) (cons t3 t4)) (cons (cons t5 (cons t6 t7)) (cons (cons t8 t9) (cons t10 t11)))) ))
  2676.     (12 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12)
  2677.            (cons (cons (cons t1 t2) (cons t3 t4)) (cons (cons (cons t5 t6) (cons t7 t8)) (cons (cons t9 t10) (cons t11 t12)))) ))
  2678.     (13 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13)
  2679.            (cons (cons (cons t1 t2) (cons t3 (cons t4 t5))) (cons (cons (cons t6 t7) (cons t8 t9)) (cons (cons t10 t11) (cons t12 t13)))) ))
  2680.     (14 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14)
  2681.            (cons (cons (cons t1 t2) (cons (cons t3 t4) (cons t5 t6))) (cons (cons (cons t7 t8) (cons t9 t10)) (cons (cons t11 t12) (cons t13 t14)))) ))
  2682.     (15 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15)
  2683.            (cons (cons (cons t1 (cons t2 t3)) (cons (cons t4 t5) (cons t6 t7))) (cons (cons (cons t8 t9) (cons t10 t11)) (cons (cons t12 t13) (cons t14 t15)))) ))
  2684.     (16 '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15 t16)
  2685.            (cons (cons (cons (cons t1 t2) (cons t3 t4)) (cons (cons t5 t6) (cons t7 t8))) (cons (cons (cons t9 t10) (cons t11 t12)) (cons (cons t13 t14) (cons t15 t16)))) ))
  2686.     (t '(lambda (t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 &rest more-t)
  2687.           (cons (cons (cons (cons t1 t2) (cons t3 t4)) (cons (cons t5 t6) (cons t7 t8))) (cons (cons (cons t9 t10) (cons t11 t12)) (cons (cons t13 t14) more-t))) ))
  2688. ) )
  2689.  
  2690. ; Berechnet die effektive Methode zu gegebenen Argumenten.
  2691. ; Es ist eigentlich die effektive Methode zu allen Argumenten, die dieselben
  2692. ; EQL- und Klassen-Einschränkungen haben wie die gegebenen Argumente, aber
  2693. ; darum hat sich compute-dispatch schon gekümmert.
  2694. (defun compute-effective-method (gf probe &rest args)
  2695.   (let* ((signature (gf-signature gf))
  2696.          (req-anz (first signature))
  2697.          (req-vars (n-gensyms req-anz))
  2698.          (req-args (subseq args 0 req-anz))
  2699.          (restp (or (third signature) (> (second signature) 0)))
  2700.          (rest-var (if restp (gensym)))
  2701.          (apply-fun (if restp 'APPLY 'FUNCALL))
  2702.          (apply-args `(,@req-vars ,@(if restp `(,rest-var) '())))
  2703.          (lambdalist `(,@req-vars ,@(if restp `(&REST ,rest-var) '())))
  2704.          (opt-vars '())
  2705.          (key-vars '())
  2706.          (lambdalist-keypart '())
  2707.          (arg-order (gf-argorder gf))
  2708.          (methods (gf-methods gf)))
  2709.     ; Determine the effective method:
  2710.     ; 1. Select the applicable methods:
  2711.     (setq methods
  2712.       (remove-if-not #'(lambda (method) (method-applicable-p method req-args))
  2713.                      methods
  2714.     ) )
  2715.     (when (null methods)
  2716.       (apply #'no-applicable-method gf args)
  2717.       (if probe
  2718.           (error-of-type 'error
  2719.                          #L{
  2720.                          DEUTSCH ""
  2721.                          ENGLISH "No method for generic function: ~S"
  2722.                          FRANCAIS ""
  2723.                          }
  2724.                          gf)
  2725.           (return-from compute-effective-method
  2726.             (progn
  2727.               (install-dispatch gf)
  2728.               (apply #'compute-effective-method gf t args)
  2729.               ))))
  2730.     ; 28.1.6.4., 28.1.6.5.: Keyword arguments in generic functions
  2731.     (when restp
  2732.       ; Die generische Funktion hat &REST oder &KEY, also auch alle Methoden.
  2733.       ; "If the lambda-list of ... the generic function definition contains
  2734.       ;  &allow-other-keys, all keyword arguments are accepted."
  2735.       (unless (fifth signature)
  2736.         ; "The specific set of keyword arguments accepted ... varies according
  2737.         ;  to the applicable methods."
  2738.         (let ((signatures (mapcar #'std-method-signature methods)))
  2739.           ; "A method that has &rest but not &key does not affect the set of
  2740.           ;  acceptable keyword srguments."
  2741.           (setq signatures (delete-if-not #'fourth signatures))
  2742.           ; Keine Methode mit &key -> keine Einschränkung der Argumente.
  2743.           (unless (null signatures)
  2744.             ; "If the lambda-list of any applicable method ... contains
  2745.             ;  &allow-other-keys, all keyword arguments are accepted."
  2746.             (unless (some #'sixth signatures)
  2747.               ; "The set of keyword arguments accepted for a particular call
  2748.               ;  is the union of the keyword arguments accepted by all
  2749.               ;  applicable methods and the keyword arguments mentioned after
  2750.               ;  &key in the generic function definition."
  2751.               (let ((keywords
  2752.                       (remove-duplicates
  2753.                         (append (fourth signature) (mapcap #'fifth signatures))
  2754.                         :from-end t
  2755.                    )) )
  2756.                 (setq opt-vars (n-gensyms (second signature)))
  2757.                 (setq key-vars (n-gensyms (length keywords)))
  2758.                 (setq lambdalist-keypart
  2759.                       `(&KEY
  2760.                         ,@(mapcar #'(lambda (kw var) `((,kw ,var)))
  2761.                                   keywords key-vars
  2762.                           )
  2763.                        )
  2764.     ) ) ) ) ) ) )
  2765.     ; 2. Sort the applicable methods by precedence order:
  2766.     (setq methods (sort-applicable-methods methods req-args arg-order))
  2767.     ; 3. Apply method combination:
  2768.     ; Nur STANDARD Methoden-Kombination ist implementiert.
  2769.     ; Aufspalten in einzelne Methoden-Typen:
  2770.     (multiple-value-bind (primary-methods before-methods after-methods around-methods)
  2771.         (partition-method-list methods)
  2772.     (when (null primary-methods)
  2773.       (apply #'no-primary-method gf args)
  2774.       (if probe
  2775.           (error-of-type 'error
  2776.                          #L{
  2777.                          DEUTSCH ""
  2778.                          ENGLISH "No primary method for generic function: ~S"
  2779.                          FRANCAIS ""
  2780.                          }
  2781.                          gf)
  2782.           (return-from compute-effective-method
  2783.             (progn
  2784.               (install-dispatch gf)
  2785.               (apply #'compute-effective-method gf t args)
  2786.               ))))
  2787.       ; Methoden zu einer "effektiven Methode" kombinieren:
  2788.       (labels ((ef-1 (primary-methods before-methods after-methods around-methods)
  2789.                  (if (null around-methods)
  2790.                    (ef-2 primary-methods before-methods after-methods)
  2791.                    (let* ((1method (first around-methods))
  2792.                           (1function (std-method-function 1method)))
  2793.                      (if (std-method-wants-next-method-p 1method)
  2794.                        (let ((next-ef
  2795.                                  (ef-1 primary-methods before-methods after-methods (rest around-methods))
  2796.                             ))
  2797.                          `(,apply-fun ',1function
  2798.                                       #'(LAMBDA ,lambdalist ,next-ef)
  2799.                                       ,@apply-args
  2800.                           )
  2801.                        )
  2802.                        `(,apply-fun ',1function ,@apply-args)
  2803.                ) ) ) )
  2804.                (ef-2 (primary-methods before-methods after-methods)
  2805.                  (let ((next-ef (ef-3 primary-methods after-methods)))
  2806.                    (if (null before-methods)
  2807.                      next-ef
  2808.                      `(PROGN
  2809.                         ,@(mapcar
  2810.                             #'(lambda (method)
  2811.                                 `(,apply-fun ',(std-method-function method)
  2812.                                              ,@apply-args
  2813.                                  )
  2814.                               )
  2815.                             before-methods ; most-specific-first
  2816.                           )
  2817.                         ,next-ef
  2818.                       )
  2819.                ) ) )
  2820.                (ef-3 (primary-methods after-methods)
  2821.                  (let ((next-ef (ef-4 primary-methods)))
  2822.                    (if (null after-methods)
  2823.                      next-ef
  2824.                      `(MULTIPLE-VALUE-PROG1
  2825.                         ,next-ef
  2826.                         ,@(mapcar
  2827.                             #'(lambda (method)
  2828.                                 `(,apply-fun ',(std-method-function method)
  2829.                                              ,@apply-args
  2830.                                  )
  2831.                               )
  2832.                             (reverse after-methods) ; most-specific-last
  2833.                           )
  2834.                       )
  2835.                ) ) )
  2836.                (ef-4 (primary-methods)
  2837.                  (let* ((1method (first primary-methods))
  2838.                         (1function (std-method-function 1method)))
  2839.                    (if (std-method-wants-next-method-p 1method)
  2840.                      (let ((next-ef-fun (ef-5 (rest primary-methods))))
  2841.                        `(,apply-fun ',1function ,next-ef-fun ,@apply-args)
  2842.                      )
  2843.                      `(,apply-fun ',1function ,@apply-args)
  2844.                ) ) )
  2845.                (ef-5 (primary-methods)
  2846.                  (if (null primary-methods)
  2847.                    'NIL ; keine Funktion, NEXT-METHOD-P reagiert darauf
  2848.                    `#'(LAMBDA ,lambdalist ,(ef-4 primary-methods))
  2849.               )) )
  2850.         (let* ((ef-form (ef-1 primary-methods before-methods after-methods around-methods))
  2851.                (ef-fun (if (and (eq (car ef-form) apply-fun)
  2852.                                 (equal (cddr ef-form) apply-args)
  2853.                                 (null lambdalist-keypart)
  2854.                            )
  2855.                          (cadr ef-form)
  2856.                          `#'(LAMBDA
  2857.                               ,@(if (null opt-vars)
  2858.                                   `(,(append lambdalist lambdalist-keypart)
  2859.                                     ,@(if key-vars `((DECLARE (IGNORE ,@key-vars))))
  2860.                                    )
  2861.                                   `(,lambdalist
  2862.                                     (APPLY #'(LAMBDA (&OPTIONAL ,@opt-vars ,@lambdalist-keypart)
  2863.                                                (DECLARE (IGNORE ,@opt-vars ,@key-vars))
  2864.                                              )
  2865.                                            ,rest-var
  2866.                                    ))
  2867.                                 )
  2868.                               ,ef-form
  2869.                             )
  2870.               ))       )
  2871.           ; (eval ef-fun)                                 ; interpretiert
  2872.           ; (eval `(LOCALLY (DECLARE (COMPILE)) ,ef-fun)) ; compiliert
  2873.           (eval `(LET () (DECLARE (COMPILE) (INLINE FUNCALL APPLY)) ,ef-fun))
  2874. ) ) ) ) )
  2875.  
  2876.  
  2877. ; Grausamer Hack (28.1.9.2.):
  2878. ; MAKE-INSTANCE muß über die Methoden von INITIALIZE-INSTANCE und
  2879. ; SHARED-INITIALIZE Bescheid wissen.
  2880. ; REINITIALIZE-INSTANCE muß über die Methoden von REINITIALIZE-INSTANCE und
  2881. ; SHARED-INITIALIZE Bescheid wissen.
  2882. (defvar |#'initialize-instance| nil)
  2883. (defvar |#'reinitialize-instance| nil)
  2884. (defvar |#'shared-initialize| nil)
  2885.  
  2886. ; Hinzufügen einer Methode zu einer generischen Funktion:
  2887. (defun std-add-method (gf method)
  2888.   ; 28.1.6.4. congruent lambda lists
  2889.   (let ((gf-sign (gf-signature gf))             ; (reqanz optanz restp keywords allowp)
  2890.         (m-sign (std-method-signature method))) ; (reqanz optanz restp keyp keywords allowp)
  2891.     (unless (= (first m-sign) (first gf-sign))
  2892.       (error-of-type 'error
  2893.         #L{
  2894.         DEUTSCH "~S hat ~S, ~S hat aber ~S Required-Parameter."
  2895.         ENGLISH "~S has ~S, but ~S has ~S required parameters"
  2896.         FRANCAIS "~S reçoit ~S arguments obligatoires, mais ~S en reçoit ~S."
  2897.         }
  2898.         method (first m-sign) gf (first gf-sign)
  2899.     ) )
  2900.     (unless (= (second m-sign) (second gf-sign))
  2901.       (error-of-type 'error
  2902.         #L{
  2903.         DEUTSCH "~S hat ~S, ~S hat aber ~S optionale Parameter."
  2904.         ENGLISH "~S has ~S, but ~S has ~S optional parameters"
  2905.         FRANCAIS "~S reçoit ~S arguments facultatifs, mais ~S en reçoit ~S."
  2906.         }
  2907.         method (second m-sign) gf (second gf-sign)
  2908.     ) )
  2909.     (when (and (third m-sign) (not (third gf-sign)))
  2910.       (error-of-type 'error
  2911.         #L{
  2912.         DEUTSCH "~S hat &REST oder &KEY, ~S jedoch nicht."
  2913.         ENGLISH "~S has &REST or &KEY, but ~S hasn't."
  2914.         FRANCAIS "~S spécifie &REST ou &KEY, mais ~S pas."
  2915.         }
  2916.         method gf
  2917.     ) )
  2918.     (when (and (third gf-sign) (not (third m-sign)))
  2919.       (error-of-type 'error
  2920.         #L{
  2921.         DEUTSCH "~S hat &REST oder &KEY, ~S jedoch nicht."
  2922.         ENGLISH "~S has &REST or &KEY, but ~S hasn't."
  2923.         FRANCAIS "~S spécifie &REST ou &KEY, mais ~S pas."
  2924.         }
  2925.         gf method
  2926.     ) )
  2927.     (when (fourth gf-sign) ; gf hat Keywords?
  2928.       ; ja -> Methode muß sie akzeptieren:
  2929.       (unless (if (fourth m-sign) ; Methode hat &key ?
  2930.                 (or (sixth m-sign) ; Methode muß &allow-other-keys haben oder
  2931.                     (subsetp (fourth gf-sign) (fifth m-sign)) ; die Keywords aufzählen
  2932.                 )
  2933.                 (third m-sign) ; Methode muß &rest haben!
  2934.               )
  2935.         (error-of-type 'error
  2936.           #L{
  2937.           DEUTSCH "~S akzeptiert die Keywords ~S von ~S nicht."
  2938.           ENGLISH "~S doesn't accept the keywords ~S of ~S"
  2939.           FRANCAIS "~S n'accepte pas les mots clé ~S de ~S."
  2940.           }
  2941.           method (fourth gf-sign) gf
  2942.     ) ) )
  2943.   )
  2944.   ; method kopieren, damit man gf eintragen kann:
  2945.   (when (std-method-wants-next-method-p method)
  2946.     (setq method (copy-standard-method method))
  2947.     (setf (std-method-function method) nil)
  2948.     (setf (std-method-gf method) gf)
  2949.   )
  2950.   ; function aus initfunction bestimmen:
  2951.   (when (null (std-method-function method))
  2952.     (let ((h (funcall (std-method-initfunction method) method)))
  2953.       (setf (std-method-function method) (car h))
  2954.       (when (car (cdr h)) ; konnte die Variable ",cont" wegoptimiert werden?
  2955.         (setf (std-method-wants-next-method-p method) nil)
  2956.   ) ) )
  2957.   ; Methode ist fertig. Eintragen:
  2958.   (warn-if-gf-already-called gf)
  2959.   (let ((old-method (find method (gf-methods gf) :test #'methods-agree-p)))
  2960.     (cond ((eq gf |#'initialize-instance|) (note-ii-change method))
  2961.           ((eq gf |#'reinitialize-instance|) (note-ri-change method))
  2962.           ((eq gf |#'shared-initialize|) (note-si-change method))
  2963.     )
  2964.     (setf (gf-methods gf)
  2965.           (cons method
  2966.                 (if old-method
  2967.                   (progn
  2968.                     (warn
  2969.                      #L{
  2970.                      DEUTSCH "Methode ~S in ~S wird ersetzt."
  2971.                      ENGLISH "Replacing method ~S in ~S"
  2972.                      FRANCAIS "On remplace la méthode ~S dans ~S."
  2973.                      }
  2974.                      old-method gf
  2975.                     )
  2976.                     (remove old-method (gf-methods gf))
  2977.                   )
  2978.                   (gf-methods gf)
  2979.     )     )     )
  2980.     (finalize-fast-gf gf)
  2981.   )
  2982.   gf
  2983. )
  2984.  
  2985. ; Entfernen einer Methode von einer generischen Funktion:
  2986. (defun std-remove-method (gf method)
  2987.   (let ((old-method (find (std-method-initfunction method) (gf-methods gf)
  2988.                           :key #'std-method-initfunction)))
  2989.     (when old-method
  2990.       (warn-if-gf-already-called gf)
  2991.       (warn
  2992.        #L{
  2993.        DEUTSCH "Methode ~S in ~S wird entfernt."
  2994.        ENGLISH "Removing method ~S in ~S"
  2995.        FRANCAIS "On retire la méthode ~S de ~S."
  2996.        }
  2997.        old-method gf
  2998.       )
  2999.       (cond ((eq gf |#'initialize-instance|) (note-ii-change method))
  3000.             ((eq gf |#'reinitialize-instance|) (note-ri-change method))
  3001.             ((eq gf |#'shared-initialize|) (note-si-change method))
  3002.       )
  3003.       (setf (gf-methods gf) (remove old-method (gf-methods gf)))
  3004.       (finalize-fast-gf gf)
  3005.   ) )
  3006.   gf
  3007. )
  3008.  
  3009. ; Aufsuchen einer Methode in einer generischen Funktion:
  3010. (defun std-find-method (gf qualifiers specializers &optional (errorp t))
  3011.   ; sozusagen
  3012.   ;   (find hypothetical-method (gf-methods gf) :test #'methods-agree-p)
  3013.   ; vgl. methods-agree-p
  3014.   (dolist (method (gf-methods gf))
  3015.     (when (and (equal (std-method-qualifiers method) qualifiers)
  3016.                (specializers-agree-p (std-method-parameter-specializers method)
  3017.                                      specializers
  3018.           )    )
  3019.       (return-from std-find-method method)
  3020.   ) )
  3021.   (if errorp
  3022.     (error-of-type 'error
  3023.       #L{
  3024.       DEUTSCH "~S hat keine Methode mit Bestimmern ~:S und Spezialierung ~S."
  3025.       ENGLISH "~S has no method with qualifiers ~:S and specializers ~S"
  3026.       FRANCAIS "~S n'a pas de méthode qualifiée ~:S qui est spécialisée sur ~S."
  3027.       }
  3028.       gf qualifiers specializers
  3029.     )
  3030.     nil
  3031. ) )
  3032.  
  3033.  
  3034. ;;; DEFMETHOD
  3035.  
  3036. (defmacro defmethod (funname &rest method-description &environment env)
  3037.   (unless (function-name-p funname)
  3038.     (error-of-type 'program-error
  3039.       #L{
  3040.       DEUTSCH "~S: Der Name einer Funktion muß ein Symbol sein, nicht: ~S"
  3041.       ENGLISH "~S: the name of a function must be a symbol, not ~S"
  3042.       FRANCAIS "~S : Le nom d'une fonction doit être un symbole et non ~S"
  3043.       }
  3044.       'defmethod funname
  3045.   ) )
  3046.   `(LET ()
  3047.      (EVAL-WHEN (COMPILE) (COMPILER::C-DEFUN ',funname))
  3048.      (DO-DEFMETHOD ',funname
  3049.        ,(analyze-method-description 'defmethod funname method-description env)
  3050.    ) )
  3051. )
  3052.  
  3053. (defun do-defmethod (funname method)
  3054.   (std-add-method
  3055.     (if (fboundp funname)
  3056.       (let ((gf (fdefinition funname)))
  3057.         (if (clos::generic-function-p gf)
  3058.           gf
  3059.           (error-of-type 'error
  3060.             #L{
  3061.             DEUTSCH "~S bezeichnet keine generische Funktion."
  3062.             ENGLISH "~S doesn't name a generic function"
  3063.             FRANCAIS "~S n'est pas ne nom d'une fonction générique."
  3064.             }
  3065.             funname
  3066.       ) ) )
  3067.       (setf (fdefinition funname)
  3068.             (let ((signature (std-method-signature method)))
  3069.               (make-fast-gf funname
  3070.                             ; GF-Signatur aus der Methoden-Signatur bestimmen:
  3071.                             (list (first signature) ; reqanz
  3072.                                   (second signature) ; optanz
  3073.                                   (third signature) ; restp
  3074.                                   '() ; keywords
  3075.                                   nil ; allowp
  3076.                             )
  3077.                             ; argorder := (0 ... reqanz-1)
  3078.                             (countup (first signature))
  3079.       )     ) )
  3080.     )
  3081.     method
  3082.   )
  3083.   method
  3084. )
  3085.  
  3086. ; n --> Liste (0 ... n-1)
  3087. (defun countup (n)
  3088.   (do* ((count n (1- count))
  3089.         (l '() (cons count l)))
  3090.        ((eql count 0) l)
  3091. ) )
  3092.  
  3093.  
  3094. ;; Für DEFGENERIC, GENERIC-FUNCTION, GENERIC-FLET, GENERIC-LABELS,
  3095. ;; WITH-ADDED-METHODS
  3096.   ; caller: Symbol
  3097.   ; funname: Funktionsname, Symbol oder (SETF symbol)
  3098.   ; lambdalist: Lambdaliste der generischen Funktion
  3099.   ; options: (option*)
  3100.   ; --> signature, argorder, method-forms, docstring
  3101. (defun analyze-defgeneric (caller funname lambdalist options env)
  3102.   (unless (function-name-p funname)
  3103.     (error-of-type 'program-error
  3104.       #L{
  3105.       DEUTSCH "~S: Der Name einer Funktion muß ein Symbol sein, nicht: ~S"
  3106.       ENGLISH "~S: the name of a function must be a symbol, not ~S"
  3107.       FRANCAIS "~S : Le nom d'une fonction doit être un symbole et non ~S"
  3108.       }
  3109.       caller funname lambdalist
  3110.   ) )
  3111.   ; Lambdaliste parsen:
  3112.   (multiple-value-bind (reqanz req-vars optanz restp keywords allowp)
  3113.       (analyze-defgeneric-lambdalist caller funname lambdalist)
  3114.     ; Optionen abarbeiten:
  3115.     (let ((method-forms '())
  3116.           (argorders nil)
  3117.           (docstrings nil))
  3118.       (dolist (option options)
  3119.         (unless (listp option)
  3120.           (error-of-type 'program-error
  3121.             #L{
  3122.             DEUTSCH "~S ~S: Das ist keine ~S-Option: ~S"
  3123.             ENGLISH "~S ~S: not a ~S option: ~S"
  3124.             FRANCAIS "~S ~S : Ceci n'est pas une option ~S: ~S"
  3125.             }
  3126.             caller funname 'defgeneric option
  3127.         ) )
  3128.         (case (first option)
  3129.           (DECLARE
  3130.             (unless (every
  3131.                        #'(lambda (x) (and (consp x) (eq (first x) 'OPTIMIZE)))
  3132.                        (rest option)
  3133.                     )
  3134.               (warn 
  3135.                #L{
  3136.                DEUTSCH "~S ~S: Erlaubt sind nur ~S-Deklarationen: ~S"
  3137.                ENGLISH "~S ~S: Only ~S declarations are permitted: ~S"
  3138.                FRANCAIS "~S ~S : Seules les déclarations ~S sont permises: ~S"
  3139.                }
  3140.                caller funname 'optimize option
  3141.             ) )
  3142.             ; Die Deklaration wird ignoriert.
  3143.             ; Der Compiler ignoriert sie sowieso.
  3144.           )
  3145.           (:ARGUMENT-PRECEDENCE-ORDER
  3146.             (when argorders
  3147.               (error-of-type 'program-error
  3148.                 #L{
  3149.                 DEUTSCH "~S ~S: ~S darf nur einmal angegeben werden."
  3150.                 ENGLISH "~S ~S: ~S may only be specified once."
  3151.                 FRANCAIS "~S ~S : ~S ne peut être spécifié qu'une seule fois."
  3152.                 }
  3153.                 caller funname ':argument-precedence-order
  3154.             ) )
  3155.             (setq argorders option)
  3156.           )
  3157.           (:DOCUMENTATION
  3158.             (unless (and (eql (length option) 2) (stringp (second option)))
  3159.               (error-of-type 'program-error
  3160.                 #L{
  3161.                 DEUTSCH "~S ~S: Nach ~S muß ein String angegeben werden: ~S"
  3162.                 ENGLISH "~S ~S: A string must be specified after ~S : ~S"
  3163.                 FRANCAIS "~S ~S : Il faut une chaîne après ~S : ~S"
  3164.                 }
  3165.                 caller funname ':documentation option
  3166.             ) )
  3167.             (when docstrings
  3168.               (error-of-type 'program-error
  3169.                 #L{
  3170.                 DEUTSCH "~S ~S: Es ist höchstens ein ~S-String erlaubt."
  3171.                 ENGLISH "~S ~S: Only one ~S string is allowed"
  3172.                 FRANCAIS "~S ~S : Il faut qu'une seule chaîne ~S."
  3173.                 }
  3174.                 caller funname ':documentation
  3175.             ) )
  3176.             (setq docstrings (rest option))
  3177.           )
  3178.           (:METHOD-COMBINATION
  3179.             (unless (equal (rest option) '(STANDARD))
  3180.               (error-of-type 'program-error
  3181.                 #L{
  3182.                 DEUTSCH "~S ~S: Als Methodenkombination ist nur ~S zugelassen: ~S"
  3183.                 ENGLISH "~S ~S: The only valid method combination is ~S : ~S"
  3184.                 FRANCAIS "~S ~S : La seule combinaison de méthodes valable est ~S : ~S"
  3185.                 }
  3186.                 caller funname 'standard option
  3187.             ) )
  3188.             ; Die Methodenkombination wird ignoriert.
  3189.           )
  3190.           (:GENERIC-FUNCTION-CLASS
  3191.             (unless (equal (rest option) '(STANDARD-GENERIC-FUNCTION))
  3192.               (error-of-type 'program-error
  3193.                 #L{
  3194.                 DEUTSCH "~S ~S: Als Name der Klasse der generischen Funktion ist nur ~S zugelassen: ~S"
  3195.                 ENGLISH "~S ~S: The only valid generic function class name is ~S : ~S"
  3196.                 FRANCAIS "~S ~S : Le seul nom valable d'une classe de fonction générique est ~S : ~S"
  3197.                 }
  3198.                 caller funname 'standard-generic-function option
  3199.             ) )
  3200.             ; Die Klasse der generischen Funktion wird ignoriert.
  3201.           )
  3202.           (:METHOD-CLASS
  3203.             (unless (equal (rest option) '(STANDARD-METHOD))
  3204.               (error-of-type 'program-error
  3205.                 #L{
  3206.                 DEUTSCH "~S ~S: Als Name der Klasse der Methoden ist nur ~S zugelassen: ~S"
  3207.                 ENGLISH "~S ~S: The only valid method class name is ~S : ~S"
  3208.                 FRANCAIS "~S ~S : Le seul nom valable d'une classe de méthodes est ~S : ~S"
  3209.                 }
  3210.                 caller funname 'standard-method option
  3211.             ) )
  3212.             ; Die Klasse der Methoden wird ignoriert.
  3213.           )
  3214.           (:METHOD
  3215.             (push (analyze-method-description caller funname (rest option) env)
  3216.                   method-forms
  3217.           ) )
  3218.           (t (error-of-type 'program-error
  3219.                #L{
  3220.                DEUTSCH "~S ~S: Falsche Syntax in ~S-Option: ~S"
  3221.                ENGLISH "~S ~S: invalid syntax in ~S option: ~S"
  3222.                FRANCAIS "~S ~S : Mauvaise syntaxe dans l'option ~S: ~S"
  3223.                }
  3224.                caller funname 'defstruct option
  3225.       ) ) )  )
  3226.       ; :argument-precedence-order überprüfen:
  3227.       (let ((argorder
  3228.               (if argorders
  3229.                 (let ((l (mapcar #'(lambda (x)
  3230.                                      (or (position x req-vars)
  3231.                                          (error-of-type 'program-error
  3232.                                            #L{
  3233.                                            DEUTSCH "~S ~S: ~S ist keiner der notwendigen Parameter: ~S"
  3234.                                            ENGLISH "~S ~S: ~S is not one of the required parameters: ~S"
  3235.                                            FRANCAIS "~S ~S : ~S n'est pas parmi les noms d'arguments obligatoires: ~S"
  3236.                                            }
  3237.                                            caller funname x argorders
  3238.                                    ) )   )
  3239.                                  (rest argorders)
  3240.                      ))  )
  3241.                   ; Ist (rest argorders) eine Permutation von req-vars ?
  3242.                   ; Anders ausgedrückt: Ist die Abbildung
  3243.                   ;        (rest argorders)  -->  req-vars
  3244.                   ; bzw.   l --> {0, ..., reqanz-1}
  3245.                   ; bijektiv?
  3246.                   (unless (apply #'/= l) ; injektiv?
  3247.                     (error-of-type 'program-error
  3248.                       #L{
  3249.                       DEUTSCH "~S ~S: eine Variable taucht in ~S doppelt auf."
  3250.                       ENGLISH "~S ~S: some variable occurs twice in ~S"
  3251.                       FRANCAIS "~S ~S : une variable apparaît plusieurs fois dans ~S."
  3252.                       }
  3253.                       caller funname argorders
  3254.                   ) )
  3255.                   (unless (eql (length l) reqanz) ; surjektiv?
  3256.                     (error-of-type 'program-error
  3257.                       #L{
  3258.                       DEUTSCH "~S ~S: ~S enthält nicht alle notwendigen Parameter."
  3259.                       ENGLISH "~S ~S: ~S is missing some required parameter"
  3260.                       FRANCAIS "~S ~S : ~S ne contient pas tous les noms d'arguments obligatoires."
  3261.                       }
  3262.                       caller funname argorders
  3263.                   ) )
  3264.                   l
  3265.                 )
  3266.                 (countup reqanz)
  3267.            )) )
  3268.         (values ; Signatur
  3269.                 `(,reqanz ,optanz ,restp ,keywords ,allowp)
  3270.                 ; argorder
  3271.                 argorder
  3272.                 ; Liste der Methoden-Formen
  3273.                 (nreverse method-forms)
  3274.                 ; docstring oder nil
  3275.                 (car docstrings)
  3276.         )
  3277. ) ) ) )
  3278.  
  3279. ; Lambdaliste parsen:
  3280. ; lambdalist --> reqanz, req-vars, optanz, restp, keywords, allowp
  3281. (defun analyze-defgeneric-lambdalist (caller funname lambdalist)
  3282.   (let ((req-vars '())
  3283.         (optanz 0)
  3284.         (restp nil)
  3285.         (keyp nil)
  3286.         (keywords '())
  3287.         (allowp nil))
  3288.     (when (some #'(lambda (item) (and (consp item) (cdr item))) lambdalist)
  3289.       (error-of-type 'program-error
  3290.         #L{
  3291.         DEUTSCH "~S ~S: In der Lambda-Liste einer generischen Funktion sind keine Initialisierungen erlaubt: ~S"
  3292.         ENGLISH "~S ~S: No initializations are allowed in a generic function lambda-list: ~S"
  3293.         FRANCAIS "~S ~S : Des initialisations ne sont pas permises dans la liste lambda d'une fonction générique: ~S"
  3294.         }
  3295.         caller funname lambdalist
  3296.     ) )
  3297.     (flet ((check-varname (var)
  3298.              (unless (symbolp var)
  3299.                (error-of-type 'program-error
  3300.                  #L{
  3301.                  DEUTSCH "~S ~S: Variablenname muß ein Symbol sein, nicht ~S"
  3302.                  ENGLISH "~S ~S: variable name ~S should be a symbol"
  3303.                  FRANCAIS "~S ~S : le nom de variable ~S devrait être un symbole."
  3304.                  }
  3305.                  caller funname var
  3306.              ) )
  3307.              (when (member var req-vars :test #'eq)
  3308.                (error-of-type 'program-error
  3309.                  #L{
  3310.                  DEUTSCH "~S ~S: Variablenname ~S darf nicht mehrfach auftreten."
  3311.                  ENGLISH "~S ~S: duplicate variable name ~S"
  3312.                  FRANCAIS "~S ~S : le nom de variable ~S apparaît plusieurs fois."
  3313.                  }
  3314.                  caller funname var
  3315.              ) )
  3316.              var
  3317.           ))
  3318.       (loop
  3319.         (when (or (atom lambdalist) (lambda-list-keyword-p (first lambdalist)))
  3320.           (return)
  3321.         )
  3322.         (push (check-varname (pop lambdalist)) req-vars)
  3323.       )
  3324.       (when (and (consp lambdalist) (eq (first lambdalist) '&optional))
  3325.         (pop lambdalist)
  3326.         (loop
  3327.           (when (or (atom lambdalist) (lambda-list-keyword-p (first lambdalist)))
  3328.             (return)
  3329.           )
  3330.           (let ((item (pop lambdalist)))
  3331.             (check-varname (if (consp item) (first item) item))
  3332.             (incf optanz)
  3333.       ) ) )
  3334.       (when (and (consp lambdalist) (eq (first lambdalist) '&rest)
  3335.                  (consp (rest lambdalist))
  3336.             )
  3337.         (pop lambdalist)
  3338.         (check-varname (pop lambdalist))
  3339.         (setq restp t)
  3340.       )
  3341.       (when (and (consp lambdalist) (eq (first lambdalist) '&key))
  3342.         (pop lambdalist)
  3343.         (setq restp t) ; &key impliziert &rest
  3344.         (loop
  3345.           (when (or (atom lambdalist) (lambda-list-keyword-p (first lambdalist)))
  3346.             (return)
  3347.           )
  3348.           (let ((item (pop lambdalist)))
  3349.             (when (consp item) (setq item (first item)))
  3350.             (check-varname (if (consp item) (second item) item))
  3351.             (push (if (consp item)
  3352.                     (first item)
  3353.                     (intern (symbol-name item) *keyword-package*)
  3354.                   )
  3355.                   keywords
  3356.         ) ) )
  3357.         (when (and (consp lambdalist) (eq (first lambdalist) '&allow-other-keys))
  3358.           (pop lambdalist)
  3359.           (setq allowp t)
  3360.       ) )
  3361.     )
  3362.     (when lambdalist
  3363.       (error-of-type 'program-error
  3364.         #L{
  3365.         DEUTSCH "~S ~S: Lambda-Liste enthält Unzulässiges: ~S"
  3366.         ENGLISH "~S ~S: invalid lambda list portion: ~S"
  3367.         FRANCAIS "~S ~S : liste lambda partiellement invalide: ~S"
  3368.         }
  3369.         caller funname lambdalist
  3370.     ) )
  3371.     (values (length req-vars) (nreverse req-vars) optanz
  3372.             (or restp keyp) keywords allowp
  3373. ) ) )
  3374.  
  3375. ; Lambdaliste in Aufrufkonvention umrechnen:
  3376. (defun defgeneric-lambdalist-callinfo (caller funname lambdalist)
  3377.   (multiple-value-bind (reqanz req-vars optanz restp keywords allowp)
  3378.       (analyze-defgeneric-lambdalist caller funname lambdalist)
  3379.     (declare (ignore req-vars))
  3380.     (callinfo reqanz optanz restp keywords allowp)
  3381. ) )
  3382.  
  3383.  
  3384. ;;; DEFGENERIC
  3385.  
  3386. (defmacro defgeneric (funname lambda-list &rest options &environment env)
  3387.   (multiple-value-bind (signature argorder method-forms docstring)
  3388.       (analyze-defgeneric 'defgeneric funname lambda-list options env)
  3389.     `(LET ()
  3390.        (EVAL-WHEN (COMPILE) (COMPILER::C-DEFUN ',funname))
  3391.        ; NB: Kein (SYSTEM::REMOVE-OLD-DEFINITIONS ',funname)
  3392.        ,@(if docstring
  3393.            (let ((symbolform
  3394.                    (if (atom funname)
  3395.                      `',funname
  3396.                      `(LOAD-TIME-VALUE (SYSTEM::GET-SETF-SYMBOL ',(second funname)))
  3397.                 )) )
  3398.              `((SYSTEM::%SET-DOCUMENTATION ,symbolform 'FUNCTION ',docstring))
  3399.          ) )
  3400.        (DO-DEFGENERIC ',funname ',signature ',argorder ,@method-forms)
  3401.      )
  3402. ) )
  3403.  
  3404. (defun make-generic-function (funname signature argorder &rest methods)
  3405.   (let ((gf (make-fast-gf funname signature argorder)))
  3406.     (dolist (method methods) (std-add-method gf method))
  3407.     (finalize-fast-gf gf)
  3408.     gf
  3409. ) )
  3410.  
  3411. (defun do-defgeneric (funname signature argorder &rest methods)
  3412.   (if (fboundp funname)
  3413.     (let ((gf (fdefinition funname)))
  3414.       (if (clos::generic-function-p gf)
  3415.         ; Umdefinition einer generischen Funktion
  3416.         (progn
  3417.           (warn-if-gf-already-called gf)
  3418.           (unless (null (gf-methods gf))
  3419.             (warn
  3420.              #L{
  3421.              DEUTSCH "Alle Methoden von ~S werden entfernt."
  3422.              ENGLISH "Removing all methods of ~S"
  3423.              FRANCAIS "On enlève toutes les méthodes de ~S."
  3424.              }
  3425.              gf
  3426.             )
  3427.             (setf (gf-methods gf) nil)
  3428.           )
  3429.           (unless (and (equal signature (gf-signature gf))
  3430.                        (equal argorder (gf-argorder gf))
  3431.                   )
  3432.             (warn 
  3433.              #L{
  3434.              DEUTSCH "Das Parameter-Profil von ~S wird modifiziert."
  3435.              ENGLISH "Modifying the parameter profile of ~S"
  3436.              FRANCAIS "On change le nombre / l'ordre des arguments de ~S."
  3437.              }
  3438.              gf
  3439.             )
  3440.             (setf (gf-signature gf) signature)
  3441.             (setf (gf-argorder gf) argorder)
  3442.           )
  3443.           (dolist (method methods) (std-add-method gf method))
  3444.           (finalize-fast-gf gf)
  3445.           gf
  3446.         )
  3447.         (error-of-type 'error ; 'program-error ??
  3448.           #L{
  3449.           DEUTSCH "~S bezeichnet keine generische Funktion."
  3450.           ENGLISH "~S doesn't name a generic function"
  3451.           FRANCAIS "~S n'est pas le nom d'une fonction générique."
  3452.           }
  3453.           funname
  3454.     ) ) )
  3455.     (setf (fdefinition funname)
  3456.           (apply #'make-generic-function funname signature argorder methods)
  3457. ) ) )
  3458.  
  3459.  
  3460. #|
  3461. ;; Für GENERIC-FLET, GENERIC-LABELS
  3462.  
  3463. ; Wie make-generic-function, nur daß der Dispatch-Code gleich installiert wird.
  3464. (defun make-generic-function-now (funname signature argorder &rest methods)
  3465.   (let ((gf (make-fast-gf funname signature argorder)))
  3466.     (dolist (method methods) (std-add-method gf method))
  3467.     (install-dispatch gf)
  3468.     gf
  3469. ) )
  3470. |#
  3471.  
  3472.  
  3473. ;; Für GENERIC-FUNCTION, GENERIC-FLET, GENERIC-LABELS
  3474.  
  3475. (defun make-generic-function-form (caller funname lambda-list options env)
  3476.   (multiple-value-bind (signature argorder method-forms docstring)
  3477.       (analyze-defgeneric caller funname lambda-list options env)
  3478.     (declare (ignore docstring))
  3479.     `(MAKE-GENERIC-FUNCTION ',funname ',signature ',argorder ,@method-forms)
  3480. ) )
  3481.  
  3482.  
  3483. ;;; GENERIC-FUNCTION
  3484.  
  3485. (defmacro generic-function (lambda-list &rest options &environment env)
  3486.   (make-generic-function-form 'generic-function 'LAMBDA lambda-list options env)
  3487. )
  3488.  
  3489.  
  3490. ;; Für GENERIC-FLET, GENERIC-LABELS
  3491. (defun analyze-generic-fundefs (caller fundefs env)
  3492.   (let ((names '())
  3493.         (funforms '()))
  3494.     (dolist (fundef fundefs)
  3495.       (unless (and (consp fundef) (consp (cdr fundef)))
  3496.         (error-of-type 'program-error
  3497.           #L{
  3498.           DEUTSCH "~S: ~S ist keine Spezifikation einer generischen Funktion."
  3499.           ENGLISH "~S: ~S is not a generic function specification"
  3500.           FRANCAIS "~S: ~S n'est pas une spécification de fonction générique."
  3501.           }
  3502.           caller fundef
  3503.       ) )
  3504.       (push (first fundef) names)
  3505.       (push (make-generic-function-form caller (first fundef) (second fundef) (cddr fundef) env) funforms)
  3506.     )
  3507.     (values (nreverse names) (nreverse funforms))
  3508. ) )
  3509.  
  3510.  
  3511. ;;; GENERIC-FLET
  3512.  
  3513. (defmacro generic-flet (fundefs &body body &environment env)
  3514.   (multiple-value-bind (funnames funforms)
  3515.       (analyze-generic-fundefs 'generic-flet fundefs env)
  3516.     (let ((varnames (n-gensyms (length funnames))))
  3517.       `(LET ,(mapcar #'list varnames funforms)
  3518.          (FLET ,(mapcar #'(lambda (varname funname)
  3519.                             `(,funname (&rest args) (apply ,varname args))
  3520.                           )
  3521.                         varnames funnames
  3522.                 )
  3523.            ,@body
  3524.        ) )
  3525. ) ) )
  3526.  
  3527.  
  3528. ;;; GENERIC-LABELS
  3529.  
  3530. (defmacro generic-labels (fundefs &body body &environment env)
  3531.   (multiple-value-bind (funnames funforms)
  3532.       (analyze-generic-fundefs 'generic-labels fundefs env)
  3533.     (let ((varnames (n-gensyms (length funnames))))
  3534.       `(LET ,varnames
  3535.          (FLET ,(mapcar #'(lambda (varname funname)
  3536.                             `(,funname (&rest args) (apply ,varname args))
  3537.                           )
  3538.                         varnames funnames
  3539.                 )
  3540.            ,@(mapcar #'(lambda (varname funform) `(SETQ ,varname ,funform))
  3541.                      varnames funforms
  3542.              )
  3543.            ,@body
  3544.        ) )
  3545. ) ) )
  3546.  
  3547.  
  3548. ;;; WITH-ADDED-METHODS
  3549. ; ist vermurkst und wird deshalb nicht implementiert.
  3550.  
  3551.  
  3552. ;;; Verschiedene generische Funktionen, die wir bis jetzt hinausgezögert haben:
  3553.  
  3554. (defgeneric class-name (class)
  3555.   (:method ((class class))
  3556.     (class-classname class)
  3557. ) )
  3558.  
  3559. (defgeneric (setf class-name) (new-value class)
  3560.   (:method (new-value (class class))
  3561.     (unless (symbolp new-value)
  3562.       (error-of-type 'type-error
  3563.         :datum new-value :expected-type 'symbol
  3564.         #L{
  3565.         DEUTSCH "~S: Der Name einer Klasse muß ein Symbol sein, nicht ~S"
  3566.         ENGLISH "~S: The name of a class must be a symbol, not ~S"
  3567.         FRANCAIS "~S : Le nom d'une classe doit être un symbole et non ~S."
  3568.         }
  3569.         '(setf class-name) new-value
  3570.     ) )
  3571.     (when (built-in-class-p class)
  3572.       (error-of-type 'error
  3573.         #L{
  3574.         DEUTSCH "~S: Der Name der Built-In-Klasse ~S kann nicht verändert werden."
  3575.         ENGLISH "~S: The name of the built-in class ~S cannot be modified"
  3576.         FRANCAIS "~S : Le nom de la classe prédéfinie ~S ne peut pas être changée."
  3577.         }
  3578.         '(setf class-name) class
  3579.     ) )
  3580.     (setf (class-classname class) new-value)
  3581. ) )
  3582.  
  3583. (defgeneric no-applicable-method (gf &rest args)
  3584.   (:method ((gf t) &rest args)
  3585.     (error-of-type 'error
  3586.       #L{
  3587.       DEUTSCH "~S: Beim Aufruf von ~S mit Argumenten ~S ist keine Methode anwendbar."
  3588.       ENGLISH "~S: When calling ~S with arguments ~S, no method is applicable."
  3589.       FRANCAIS "~S : À l'appel de ~S avec les arguments ~S, aucune méthode ne s'applique."
  3590.       }
  3591.       'no-applicable-method gf args
  3592. ) ) )
  3593.  
  3594. (defgeneric no-primary-method (gf &rest args)
  3595.   (:method ((gf t) &rest args)
  3596.     (error-of-type 'error
  3597.       #L{
  3598.       DEUTSCH "~S: Beim Aufruf von ~S mit Argumenten ~S ist keine primäre Methode anwendbar."
  3599.       ENGLISH "~S: When calling ~S with arguments ~S, no primary method is applicable."
  3600.       FRANCAIS "~S : À l'appel de ~S avec les arguments ~S, aucune méthode primaire ne s'applique."
  3601.       }
  3602.       'no-primary-method gf args
  3603. ) ) )
  3604.  
  3605. (defun %no-next-method (method &rest args)
  3606.   (apply #'no-next-method (std-method-gf method) method args)
  3607. )
  3608. (defgeneric no-next-method (gf method &rest args)
  3609.   (:method ((gf standard-generic-function) (method standard-method) &rest args)
  3610.     (error-of-type 'error
  3611.       #L{
  3612.       DEUTSCH "~S: Beim Aufruf von ~S mit Argumenten ~S gibt es nach ~S keine weitere Methode, und ~S wurde aufgerufen."
  3613.       ENGLISH "~S: When calling ~S with arguments ~S, there is no next method after ~S, and ~S was called."
  3614.       FRANCAIS "~S : À l'appel de ~S avec les arguments ~S, il n'y a plus de méthode après ~S, et ~S a été appelé."
  3615.       }
  3616.       'no-next-method gf args method '(call-next-method)
  3617. ) ) )
  3618.  
  3619. (defgeneric find-method (gf qualifiers specializers &optional errorp)
  3620.   (:method ((gf standard-generic-function) qualifiers specializers &optional (errorp t))
  3621.      (std-find-method gf qualifiers specializers errorp)
  3622. ) )
  3623.  
  3624. (defgeneric add-method (gf method)
  3625.   (:method ((gf standard-generic-function) (method standard-method))
  3626.     (std-add-method gf method)
  3627. ) )
  3628.  
  3629. (defgeneric remove-method (gf method)
  3630.   (:method ((gf standard-generic-function) (method standard-method))
  3631.     (std-remove-method gf method)
  3632. ) )
  3633.  
  3634. (defun compute-applicable-methods (gf args)
  3635.   (let ((reqanz (first (gf-signature gf)))
  3636.         (methods (gf-methods gf)))
  3637.     (if (>= (length args) reqanz)
  3638.       (let ((req-args (subseq args 0 reqanz)))
  3639.         ; 1. Select the applicable methods:
  3640.         (setq methods
  3641.           (remove-if-not
  3642.             #'(lambda (method) (method-applicable-p method req-args))
  3643.             methods
  3644.         ) )
  3645.         ; 2. Sort the applicable methods by precedence order:
  3646.         (sort-applicable-methods methods req-args (gf-argorder gf))
  3647.       )
  3648.       nil ; lieber kein Error
  3649. ) ) )
  3650.  
  3651. (defgeneric method-qualifiers (method)
  3652.   (:method ((method standard-method))
  3653.     (std-method-qualifiers method)
  3654. ) )
  3655.  
  3656. (defgeneric function-keywords (method)
  3657.   (:method ((method standard-method))
  3658.     (values-list (cddddr (std-method-signature method)))
  3659. ) )
  3660.  
  3661. (defgeneric slot-missing (class instance slot-name operation &optional new-value)
  3662.   (:method ((class t) instance slot-name operation &optional new-value)
  3663.     (declare (ignore instance new-value))
  3664.     (error-of-type 'error
  3665.       #L{
  3666.       DEUTSCH "~S: Die Klasse ~S hat keinen Slot mit Namen ~S."
  3667.       ENGLISH "~S: The class ~S has no slot named ~S"
  3668.       FRANCAIS "~S : La classe ~S n'a pas de composant de nom ~S."
  3669.       }
  3670.       operation class slot-name
  3671. ) ) )
  3672.  
  3673. (defgeneric slot-unbound (class instance slot-name)
  3674.   (:method ((class t) instance slot-name)
  3675.     (declare (ignore class))
  3676.     (error-of-type 'error
  3677.       #L{
  3678.       DEUTSCH "~S: Der Slot ~S von ~S hat keinen Wert."
  3679.       ENGLISH "~S: The slot ~S of ~S has no value"
  3680.       FRANCAIS "~S : Le composant ~S de ~S n'a pas de valeur."
  3681.       }
  3682.       'slot-value slot-name instance
  3683. ) ) )
  3684.  
  3685. (defgeneric print-object (object stream)
  3686.   (:method ((object standard-object) stream)
  3687.     (print-unreadable-object (object stream :type t :identity t))
  3688. ) )
  3689.  
  3690. (defgeneric describe-object (object stream)
  3691.   (:method ((object standard-object) s)
  3692.     (let ((slotnames (mapcar #'slotdef-name (class-slots (class-of object)))))
  3693.       (if slotnames
  3694.         (let* ((slotstrings (mapcar #'write-to-string slotnames))
  3695.                (tabpos (+ 4 (reduce #'max (mapcar #'length slotstrings)))))
  3696.           (format s 
  3697.                   #L{
  3698.                   DEUTSCH "~%Slots:"
  3699.                   ENGLISH "~%Slots:"
  3700.                   FRANCAIS "~%Composants:"
  3701.                   }
  3702.           )
  3703.           (mapc #'(lambda (slotname slotstring)
  3704.                     (format s "~%  ~A~VT" slotstring tabpos)
  3705.                     (if (slot-boundp object slotname)
  3706.                       (format s "=  ~S" (slot-value object slotname))
  3707.                       (format s
  3708.                               #L{
  3709.                               DEUTSCH "ohne Wert"
  3710.                               ENGLISH "unbound"
  3711.                               FRANCAIS "aucune valeur"
  3712.                               }
  3713.                   ) ) )
  3714.                 slotnames slotstrings
  3715.         ) )
  3716.         (format s
  3717.                 #L{
  3718.                 DEUTSCH "~%Keine Slots."
  3719.                 ENGLISH "~%No slots."
  3720.                 FRANCAIS "~%Aucun composant."
  3721.                 }
  3722.   ) ) ) )
  3723. )
  3724.  
  3725.  
  3726. ;; 28.1.9. Object creation and initialization
  3727.  
  3728. ; Grausamer Hack (28.1.9.2.):
  3729. ; MAKE-INSTANCE muß über die Methoden von INITIALIZE-INSTANCE und
  3730. ; SHARED-INITIALIZE Bescheid wissen.
  3731. ; REINITIALIZE-INSTANCE muß über die Methoden von REINITIALIZE-INSTANCE und
  3732. ; SHARED-INITIALIZE Bescheid wissen.
  3733.  
  3734. (defparameter *make-instance-table* (make-hash-table :test #'eq))
  3735.   ; Hashtabelle, die einer Klasse zuordnet ein List* aus
  3736.   ; - einer Liste der zulässigen Keyword-Argumente,
  3737.   ; - der effektiven Methode von initialize-instance,
  3738.   ; - der effektiven Methode von shared-initialize.
  3739.  
  3740. (defparameter *reinitialize-instance-table* (make-hash-table :test #'eq))
  3741.   ; Hashtabelle, die einer Klasse zuordnet ein Cons aus
  3742.   ; - einer Liste der zulässigen Keyword-Argumente,
  3743.   ; - der effektiven Methode von shared-initialize.
  3744.  
  3745. (defun note-i-change (specializer table)
  3746.   (maphash #'(lambda (class value) (declare (ignore value))
  3747.                (when (subclassp class specializer)
  3748.                  (remhash class table)
  3749.              ) )
  3750.            table
  3751. ) )
  3752.  
  3753. (defun note-ii-change (method)
  3754.   (let ((specializer (first (std-method-parameter-specializers method))))
  3755.     ; EQL-Methoden auf INITIALIZE-INSTANCE sind eh wertlos
  3756.     (unless (consp specializer)
  3757.       ; Entferne die Einträge von *make-instance-table*, für welche die
  3758.       ; besagte Methode anwendbar wäre:
  3759.       (note-i-change specializer *make-instance-table*)
  3760. ) ) )
  3761.  
  3762. (defun note-ri-change (method)
  3763.   (let ((specializer (first (std-method-parameter-specializers method))))
  3764.     ; EQL-Methoden auf REINITIALIZE-INSTANCE sind im wesentlichen wertlos
  3765.     (unless (consp specializer)
  3766.       ; Entferne die Einträge von *reinitialize-instance-table*, für welche die
  3767.       ; besagte Methode anwendbar wäre:
  3768.       (note-i-change specializer *reinitialize-instance-table*)
  3769. ) ) )
  3770.  
  3771. (defun note-si-change (method)
  3772.   (let* ((specializers (std-method-parameter-specializers method))
  3773.          (specializer1 (first specializers))
  3774.          (specializer2 (second specializers)))
  3775.     ; EQL-Methoden auf SHARED-INITIALIZE sind im wesentlichen wertlos
  3776.     (unless (consp specializer1)
  3777.       ; Als zweites Argument wird von INITIALIZE-INSTANCE immer nur T übergeben.
  3778.       (when (typep 'T specializer2)
  3779.         ; Entferne die Einträge von *make-instance-table*, für welche die
  3780.         ; besagte Methode anwendbar wäre:
  3781.         (note-i-change specializer1 *make-instance-table*)
  3782.       )
  3783.       ; Als zweites Argument wird von REINITIALIZE-INSTANCE nur NIL übergeben.
  3784.       (when (typep 'NIL specializer2)
  3785.         ; Entferne die Einträge von *reinitialize-instance-table*, für welche die
  3786.         ; besagte Methode anwendbar wäre:
  3787.         (note-i-change specializer1 *reinitialize-instance-table*)
  3788.       )
  3789. ) ) )
  3790.  
  3791. ; Aus einer Liste von anwendbaren Methoden alle Keywords sammeln:
  3792. (defun valid-initarg-keywords (class methods)
  3793.   (let ((signatures (mapcar #'std-method-signature methods)))
  3794.     ; "A method that has &rest but not &key does not affect the set of
  3795.     ;  acceptable keyword srguments."
  3796.     (setq signatures (delete-if-not #'fourth signatures))
  3797.     ; "The keyword name of each keyword parameter specified in the method's
  3798.     ;  lambda-list becomes an initialization argument for all classes for
  3799.     ;  which the method is applicable."
  3800.     (remove-duplicates
  3801.       (append (class-valid-initargs class) (mapcap #'fifth signatures))
  3802.       :from-end t
  3803. ) ) )
  3804.  
  3805. ; NB: Beim Berechnen einer effektiven Methode kommt es auf die restlichen
  3806. ; Argumente nicht an.
  3807. ; Beim ersten INITIALIZE-INSTANCE- oder MAKE-INSTANCE-Aufruf einer jeden Klasse
  3808. ; merkt man sich die benötigte Information in *make-instance-table*.
  3809.  
  3810. ; Bei MAKE-INSTANCE sind als Keys gültig:
  3811. ; - die Initargs, die zur Initialisierung von Slots benutzt werden,
  3812. ; - die Keywords von Methoden von SHARED-INITIALIZE,
  3813. ; - die Keywords von Methoden von INITIALIZE-INSTANCE.
  3814. (defun valid-make-instance-keywords (class)
  3815.   (valid-initarg-keywords
  3816.     class
  3817.     (append
  3818.       ; Liste aller anwendbaren Methoden von SHARED-INITIALIZE
  3819.       (remove-if-not
  3820.         #'(lambda (method)
  3821.             (let* ((specializers (std-method-parameter-specializers method))
  3822.                    (specializer1 (first specializers))
  3823.                    (specializer2 (second specializers)))
  3824.               (and (atom specializer1) (subclassp class specializer1)
  3825.                    (typep 'T specializer2)
  3826.           ) ) )
  3827.         (gf-methods |#'shared-initialize|)
  3828.       )
  3829.       ; Liste aller anwendbaren Methoden von INITIALIZE-INSTANCE
  3830.       (remove-if-not
  3831.         #'(lambda (method)
  3832.             (let ((specializer (first (std-method-parameter-specializers method))))
  3833.               (and (atom specializer) (subclassp class specializer))
  3834.           ) )
  3835.         (gf-methods |#'initialize-instance|)
  3836.       )
  3837. ) ) )
  3838. (defun make-instance-table-entry2 (instance)
  3839.   (cons (compute-effective-method |#'initialize-instance| nil instance)
  3840.         (compute-effective-method |#'shared-initialize| nil instance 'T)
  3841. ) )
  3842.  
  3843. ; 28.1.9.5., 28.1.9.4.
  3844. (defgeneric shared-initialize (instance slot-names &rest initargs))
  3845. (setq |#'shared-initialize| #'shared-initialize)
  3846. #|
  3847. (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs &key &allow-other-keys)
  3848.   (dolist (slot (class-slots (class-of instance)))
  3849.     (let ((slotname (slotdef-name slot)))
  3850.       (multiple-value-bind (init-key init-value foundp)
  3851.           (get-properties initargs (slotdef-initargs slot))
  3852.         (declare (ignore init-key))
  3853.         (if foundp
  3854.           (setf (slot-value instance slotname) init-value)
  3855.           (unless (slot-boundp instance slotname)
  3856.             (let ((init (slotdef-initer slot)))
  3857.               (when init
  3858.                 (when (or (eq slot-names 'T) (member slotname slot-names :test #'eq))
  3859.                   (setf (slot-value instance slotname)
  3860.                         (if (car init) (funcall (car init)) (cdr init))
  3861.   ) ) ) ) ) ) ) ) )
  3862.   instance
  3863. )
  3864. |#
  3865. ; die Haupt-Arbeit erledigt ein SUBR:
  3866. (do-defmethod 'shared-initialize
  3867.   (make-standard-method
  3868.     :initfunction #'(lambda (gf) (declare (ignore gf))
  3869.                       (cons #'clos::%shared-initialize '(T))
  3870.                     )
  3871.     :wants-next-method-p nil
  3872.     :parameter-specializers (list (find-class 'standard-object) (find-class 't))
  3873.     :qualifiers '()
  3874.     :signature '(2 0 t t () t)
  3875. ) )
  3876.  
  3877. ; 28.1.12.
  3878. (defgeneric reinitialize-instance (instance &rest initargs))
  3879. (setq |#'reinitialize-instance| #'reinitialize-instance)
  3880. #|
  3881. (defmethod reinitialize-instance ((instance standard-object) &rest initargs &key &allow-other-keys)
  3882.   (apply #'shared-initialize instance 'NIL initargs)
  3883. )
  3884. |#
  3885. #|
  3886. ; optimiert:
  3887. (defmethod reinitialize-instance ((instance standard-object) &rest initargs &key &allow-other-keys)
  3888.   (let ((h (gethash (class-of instance) *reinitialize-instance-table*)))
  3889.     (if h
  3890.       (progn
  3891.         ; 28.1.9.2. validity of initialization arguments
  3892.         (let ((valid-keywords (car h)))
  3893.           (sys::keyword-test initargs valid-keywords)
  3894.         )
  3895.         (if (not (eq (cdr h) #'clos::%shared-initialize))
  3896.           ; effektive Methode von shared-initialize anwenden:
  3897.           (apply (cdr h) instance 'NIL initargs)
  3898.           ; clos::%shared-initialize mit slot-names=NIL läßt sich vereinfachen:
  3899.           (progn
  3900.             (dolist (slot (class-slots (class-of instance)))
  3901.               (let ((slotname (slotdef-name slot)))
  3902.                 (multiple-value-bind (init-key init-value foundp)
  3903.                     (get-properties initargs (slotdef-initargs slot))
  3904.                   (declare (ignore init-key))
  3905.                   (if foundp
  3906.                     (setf (slot-value instance slotname) init-value)
  3907.             ) ) ) )
  3908.             instance
  3909.       ) ) )
  3910.       (apply #'initial-reinitialize-instance instance initargs)
  3911. ) ) )
  3912. |#
  3913. ; die Haupt-Arbeit erledigt ein SUBR:
  3914. (do-defmethod 'reinitialize-instance
  3915.   (make-standard-method
  3916.     :initfunction #'(lambda (gf) (declare (ignore gf))
  3917.                       (cons #'clos::%reinitialize-instance '(T))
  3918.                     )
  3919.     :wants-next-method-p nil
  3920.     :parameter-specializers (list (find-class 'standard-object))
  3921.     :qualifiers '()
  3922.     :signature '(1 0 t t () t)
  3923. ) )
  3924. ; Beim ersten REINITIALIZE-INSTANCE-Aufruf einer jeden Klasse merkt man sich die
  3925. ; benötigte Information in *reinitialize-instance-table*.
  3926. (defun initial-reinitialize-instance (instance &rest initargs)
  3927.   (let* ((class (class-of instance))
  3928.          (valid-keywords
  3929.            (valid-initarg-keywords
  3930.              class
  3931.              ; Liste aller anwendbaren Methoden von SHARED-INITIALIZE
  3932.              (remove-if-not
  3933.                #'(lambda (method)
  3934.                    (let* ((specializers (std-method-parameter-specializers method))
  3935.                           (specializer1 (first specializers))
  3936.                           (specializer2 (second specializers)))
  3937.                      (and (atom specializer1) (subclassp class specializer1)
  3938.                           (typep 'NIL specializer2)
  3939.                  ) ) )
  3940.                (gf-methods |#'shared-initialize|)
  3941.         )) ) )
  3942.     ; 28.1.9.2. validity of initialization arguments
  3943.     (sys::keyword-test initargs valid-keywords)
  3944.     (let ((si-ef (compute-effective-method |#'shared-initialize| nil instance 'NIL)))
  3945.       (setf (gethash class *reinitialize-instance-table*) (cons valid-keywords si-ef))
  3946.       (apply si-ef instance 'NIL initargs)
  3947. ) ) )
  3948.  
  3949. ; 28.1.9.6.
  3950. (defgeneric initialize-instance (instance &rest initargs))
  3951. (setq |#'initialize-instance| #'initialize-instance)
  3952. #|
  3953. (defmethod initialize-instance ((instance standard-object) &rest initargs &key &allow-other-keys)
  3954.   (apply #'shared-initialize instance 'T initargs)
  3955. )
  3956. |#
  3957. #|
  3958. ; optimiert:
  3959. (defmethod initialize-instance ((instance standard-object) &rest initargs &key &allow-other-keys)
  3960.   (let ((h (gethash class *make-instance-table*)))
  3961.     (if h
  3962.       (if (not (eq (cddr h) #'clos::%shared-initialize))
  3963.         ; effektive Methode von shared-initialize anwenden:
  3964.         (apply (cddr h) instance 'T initargs)
  3965.         ; clos::%shared-initialize mit slot-names=T läßt sich vereinfachen:
  3966.         (progn
  3967.           (dolist (slot (class-slots (class-of instance)))
  3968.             (let ((slotname (slotdef-name slot)))
  3969.               (multiple-value-bind (init-key init-value foundp)
  3970.                   (get-properties initargs (slotdef-initargs slot))
  3971.                 (declare (ignore init-key))
  3972.                 (if foundp
  3973.                   (setf (slot-value instance slotname) init-value)
  3974.                   (unless (slot-boundp instance slotname)
  3975.                     (let ((init (slotdef-initer slot)))
  3976.                       (when init
  3977.                         (setf (slot-value instance slotname)
  3978.                               (if (car init) (funcall (car init)) (cdr init))
  3979.           ) ) ) ) ) ) ) )
  3980.           instance
  3981.       ) )
  3982.       (apply #'initial-initialize-instance instance initargs)
  3983. ) ) )
  3984. |#
  3985. ; die Haupt-Arbeit erledigt ein SUBR:
  3986. (do-defmethod 'initialize-instance
  3987.   (make-standard-method
  3988.     :initfunction #'(lambda (gf) (declare (ignore gf))
  3989.                       (cons #'clos::%initialize-instance '(T))
  3990.                     )
  3991.     :wants-next-method-p nil
  3992.     :parameter-specializers (list (find-class 'standard-object))
  3993.     :qualifiers '()
  3994.     :signature '(1 0 t t () t)
  3995. ) )
  3996. (defun initial-initialize-instance (instance &rest initargs)
  3997.   (let* ((class (class-of instance))
  3998.          (valid-keywords (valid-make-instance-keywords class))
  3999.          (efs (make-instance-table-entry2 instance)))
  4000.     (setf (gethash class *make-instance-table*) (cons valid-keywords efs))
  4001.     ; effektive Methode von SHARED-INITIALIZE anwenden:
  4002.     (apply (cdr efs) instance 'T initargs)
  4003. ) )
  4004.  
  4005. ; 28.1.9.7.
  4006. (defgeneric make-instance (class &rest initargs)
  4007.   (:method ((class symbol) &rest initargs)
  4008.     (apply #'make-instance (find-class class) initargs)
  4009.   )
  4010. )
  4011. #|
  4012. (defmethod make-instance ((class standard-class) &rest initargs &key &allow-other-keys)
  4013.   ; 28.1.9.3., 28.1.9.4. default-initargs zur Kenntnis nehmen:
  4014.   (dolist (default-initarg (class-default-initargs class))
  4015.     (let ((nothing default-initarg))
  4016.       (when (eq (getf initargs (car default-initarg) nothing) nothing)
  4017.         (setq initargs
  4018.               (append initargs
  4019.                 (list (car default-initarg)
  4020.                       (let ((init (cdr default-initarg)))
  4021.                         (if (car init) (funcall (car init)) (cdr init))
  4022.   ) ) ) )     ) )     )
  4023.   #|
  4024.   ; 28.1.9.2. validity of initialization arguments
  4025.   (sys::keyword-test initargs
  4026.                      (union (class-valid-initargs class)
  4027.                             (applicable-keywords #'initialize-instance class) ; ??
  4028.   )                  )
  4029.   (let ((instance (std-allocate-instance class)))
  4030.     (apply #'initialize-instance instance initargs)
  4031.   )
  4032.   |#
  4033.   (let ((h (gethash class *make-instance-table*)))
  4034.     (if h
  4035.       (progn
  4036.         ; 28.1.9.2. validity of initialization arguments
  4037.         (let ((valid-keywords (car h)))
  4038.           (sys::keyword-test initargs valid-keywords)
  4039.         )
  4040.         (let ((instance (std-allocate-instance class)))
  4041.           (if (not (eq (cadr h) #'clos::%initialize-instance))
  4042.             ; effektive Methode von initialize-instance anwenden:
  4043.             (apply (cadr h) instance initargs)
  4044.             ; clos::%initialize-instance läßt sich vereinfachen (man braucht
  4045.             ; nicht nochmal in *make-instance-table* nachzusehen):
  4046.             (if (not (eq (cddr h) #'clos::%shared-initialize))
  4047.               ; effektive Methode von shared-initialize anwenden:
  4048.               (apply (cddr h) instance 'T initargs)
  4049.               ...
  4050.             )
  4051.       ) ) )
  4052.       (apply #'initial-make-instance class initargs)
  4053. ) ) )
  4054. |#
  4055. ; die Haupt-Arbeit erledigt ein SUBR:
  4056. (do-defmethod 'make-instance
  4057.   (make-standard-method
  4058.     :initfunction #'(lambda (gf) (declare (ignore gf))
  4059.                       (cons #'clos::%make-instance '(T))
  4060.                     )
  4061.     :wants-next-method-p nil
  4062.     :parameter-specializers (list (find-class 'standard-class))
  4063.     :qualifiers '()
  4064.     :signature '(1 0 t t () t)
  4065. ) )
  4066. (defun initial-make-instance (class &rest initargs)
  4067.   (let ((valid-keywords (valid-make-instance-keywords class)))
  4068.     ; 28.1.9.2. validity of initialization arguments
  4069.     (sys::keyword-test initargs valid-keywords)
  4070.     (let ((instance (std-allocate-instance class)))
  4071.       (let ((efs (make-instance-table-entry2 instance)))
  4072.         (setf (gethash class *make-instance-table*) (cons valid-keywords efs))
  4073.         ; effektive Methode von INITIALIZE-INSTANCE anwenden:
  4074.         (apply (car efs) instance initargs)
  4075. ) ) ) )
  4076.  
  4077.