File: cx-partial-class.lisp

package info (click to toggle)
cl-contextl 0.40-2
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 248 kB
  • ctags: 298
  • sloc: lisp: 2,271; makefile: 29
file content (82 lines) | stat: -rw-r--r-- 3,454 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
(in-package :contextl)

(defclass partial-object (standard-object)
  ()
  (:default-initargs :allow-other-keys t))

(defclass partial-class (standard-class)
  ((defining-classes :initarg defining-classes
                     :reader partial-class-defining-classes)
   (defining-metaclass :initarg :defining-metaclass
                       :reader partial-class-defining-metaclass)))

(defmethod validate-superclass
           ((class partial-class)
            (superclass standard-class))
  t)

(defmethod validate-superclass
           ((class standard-class)
            (superclass partial-class))
  t)

#+allegro
(defmethod finalize-inheritance :after ((class partial-class))
  (mapc #'finalize-inheritance (rest (class-precedence-list class))))

(defmethod initialize-instance :around
  ((class partial-class) &rest initargs
   &key name
   (in-layer 't)
   (defining-metaclass 'standard-class))
  (declare (dynamic-extent initargs))
  (let ((in-layer-name (layer-name in-layer))
        (direct-superclasses (list (find-class 'partial-object)))
        (defining-classes ()))
    (let ((defined-class
           (apply #'make-instance defining-metaclass
                  (loop for (key value) on initargs by #'cddr
                        unless (member key '(:name :defining-metaclass))
                        nconc (list key value)))))
      (push defined-class direct-superclasses)
      (setf (getf defining-classes in-layer-name) defined-class))
    (unless (eq in-layer-name 't)
      (let ((defined-class (make-instance defining-metaclass)))
        (push defined-class direct-superclasses)
        (setf (getf defining-classes 't) defined-class)))
    (call-next-method class
                      :name name
                      :direct-superclasses direct-superclasses
                      'defining-classes defining-classes
                      :defining-metaclass defining-metaclass)))

(defmethod reinitialize-instance :around
  ((class partial-class) &rest initargs
   &key (in-layer 't)
   (defining-metaclass (partial-class-defining-metaclass class) defining-metaclass-p))
  (declare (dynamic-extent initargs))
  (let ((in-layer-name (layer-name in-layer)))
    (let ((defined-class (getf (partial-class-defining-classes class) in-layer-name)))
      (if defined-class
        (progn
          (apply #'reinitialize-instance defined-class
                 (loop for (key value) on initargs by #'cddr
                       unless (member key '(:name :defining-metaclass))
                       nconc (list key value)))
          (call-next-method class))
        (let ((defined-class
               (apply #'make-instance defining-metaclass
                      (loop for (key value) on initargs by #'cddr
                            unless (member key '(:name :defining-metaclass))
                            nconc (list key value)))))
          (apply #'call-next-method class
                 :direct-superclasses
                 (append (remove (find-class 'partial-object)
                                 (class-direct-superclasses class))
                         (list defined-class)
                         (list (find-class 'partial-object)))
                 'defining-classes
                 (list* in-layer-name defined-class
                        (partial-class-defining-classes class))
                 (when defining-metaclass-p
                   (list :defining-metaclass defining-metaclass))))))))