File: cx-layered-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 (75 lines) | stat: -rw-r--r-- 3,040 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
(in-package :contextl)

(defclass special-layered-access-class
          (layered-access-class special-class standard-class-in-layer)
  ())

(defclass special-layered-direct-slot-definition
          (layered-direct-slot-definition
           special-direct-slot-definition
           standard-direct-slot-definition-in-layer)
  ())

(defclass special-effective-slot-definition-in-layers
          (special-effective-slot-definition
           standard-effective-slot-definition-in-layers)
  ())

(defclass layered-effective-slot-definition-in-layers
          (layered-effective-slot-definition
           standard-effective-slot-definition-in-layers)
  ())

(defclass special-layered-effective-slot-definition
          (layered-effective-slot-definition-in-layers
           special-effective-slot-definition-in-layers)
  ())

(defmethod direct-slot-definition-class
           ((class special-layered-access-class) &key &allow-other-keys)
  (find-class 'special-layered-direct-slot-definition))

(defvar *special-layered-effective-slot-definition-class*)

(defmethod effective-slot-definition-class
           ((class special-layered-access-class) &key &allow-other-keys)
  *special-layered-effective-slot-definition-class*)

(defmethod compute-effective-slot-definition
           ((class special-layered-access-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((*special-layered-effective-slot-definition-class*
         (if (some #'slot-definition-layeredp direct-slot-definitions)
             (if (some #'slot-definition-specialp direct-slot-definitions)
                 (find-class 'special-layered-effective-slot-definition)
               (find-class 'layered-effective-slot-definition-in-layers))
           (if (some #'slot-definition-specialp direct-slot-definitions)
               (find-class 'special-effective-slot-definition-in-layers)
             (find-class 'standard-effective-slot-definition-in-layers)))))
    (call-next-method)))

(defclass layered-class (partial-class special-layered-access-class)
  ()
  (:default-initargs :defining-metaclass 'special-layered-access-class))

#+sbcl
(defmethod shared-initialize :after
  ((class layered-class) slot-names &key defining-metaclass)
  (declare (ignore slot-names defining-metaclass)))

(defmacro define-layered-class (&whole form name &body options)
  (let ((layer (if (member (car options) '(:in-layer :in) :test #'eq)
                 (cadr options)
                 t))
        (options (cond ((member (car options) '(:in-layer :in) :test #'eq)
                        (cddr options))
                       ((not (listp (car options)))
                        (error "Illegal option ~S in ~S."
                               (car options) form))
                       (t options))))
    `(defclass ,name ,(car options)
       ,(mapcar #'process-layered-access-slot-specification (cadr options))
       ,@(cddr options)
       ,@(unless (assoc :metaclass options)
           '((:metaclass layered-class)))
       (:in-layer . ,layer))))