← Back to branch summary

~ubuntu-branches/ubuntu/quantal/cl-closer-mop/quantal

« back to all changes in this revision

Viewing changes to allegro/closer-mop.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-02-03 19:00:06 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20060203190006-l9sfjyitk3gfzz40
Tags: 0.31-1
New upstream.

Show diffs side-by-side

added added

removed removed

Lines of Context:
allegro/closer-mop.lisp
1
1
(in-package :closer-mop)
2
2
 
 
3
;; This is a useful utility function.
 
4
 
 
5
(defun required-args (lambda-list &optional (collector #'identity))
 
6
  (loop for arg in lambda-list
 
7
        until (member arg lambda-list-keywords)
 
8
        collect (funcall collector arg)))
 
9
 
 
10
;; We need a new standard-class for various things.
 
11
 
 
12
(cl:defclass standard-class (cl:standard-class)
 
13
  ((valid-slot-allocations :initform '(:instance :class)
 
14
                           :accessor valid-slot-allocations
 
15
                           :reader excl::valid-slot-allocation-list)))
 
16
 
 
17
;; validate-superclass for metaclass classes is a little bit
 
18
;; more tricky than for class metaobject classes because
 
19
;; we don't want to make all standard-classes compatible to
 
20
;; each other.
 
21
 
 
22
;; Our validate-superclass may get passed a class-prototype
 
23
;; as its second argument, so don't expect its readers to
 
24
;; yield useful information. (In ANSI parlance, "the
 
25
;; consequences are undefined...")
 
26
 
 
27
(cl:defmethod validate-superclass
 
28
           ((class standard-class)
 
29
            (superclass cl:standard-class))
 
30
  (or (when (eq (class-of class) (find-class 'standard-class))
 
31
        (member (class-of superclass)
 
32
                (list (find-class 'cl:standard-class)
 
33
                      (find-class 'standard-class))))
 
34
      (call-next-method)
 
35
      (when (eq (class-of superclass) (find-class 'cl:standard-class))
 
36
        (validate-superclass class (class-prototype (find-class 'standard-class))))))
 
37
 
 
38
;; The following macro ensures that the new standard-class is used by default.
 
39
 
 
40
(defmacro defclass (name (&rest supers) &body options)
 
41
  (if (member :metaclass options :key #'car)
 
42
    `(cl:defclass ,name ,supers ,@options)
 
43
    `(cl:defclass ,name ,supers ,@options
 
44
       (:metaclass standard-class))))
 
45
 
 
46
;; Allegro defines an extra check for :allocation kinds. AMOP expects any kind to be
 
47
;; permissible, though. This is corrected here.
 
48
 
 
49
(defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys)
 
50
  (unless (eq (class-of class) (find-class 'standard-class))
 
51
    (pushnew allocation (valid-slot-allocations class))))
 
52
 
 
53
;;; In Allegro, slot-boundp-using-class and slot-makunbound-using-class are specialized
 
54
;;; on slot names instead of effective slot definitions. In order to fix this,
 
55
;;; we need to rewire the slot access protocol.
 
56
 
 
57
(cl:defmethod slot-boundp-using-class
 
58
           ((class standard-class) object (slot symbol))
 
59
  (declare (optimize (speed 3) (debug 0) (safety 0)
 
60
                     (compilation-speed 0)))
 
61
  (let ((slotd (find slot (class-slots class)
 
62
                     :test #'eq
 
63
                     :key #'slot-definition-name)))
 
64
    (if slotd
 
65
      (slot-boundp-using-class class object slotd)
 
66
      (slot-missing class object slot 'slot-boundp))))
 
67
 
 
68
(cl:defmethod slot-boundp-using-class
 
69
           ((class standard-class) object (slotd standard-effective-slot-definition))
 
70
  (declare (optimize (speed 3) (debug 0) (safety 0)
 
71
                     (compilation-speed 0)))
 
72
  (slot-boundp-using-class
 
73
   (load-time-value (class-prototype (find-class 'cl:standard-class)))
 
74
   object
 
75
   (slot-definition-name slotd)))
 
76
 
 
77
(cl:defmethod slot-makunbound-using-class
 
78
           ((class standard-class) object (slot symbol))
 
79
  (declare (optimize (speed 3) (debug 0) (safety 0)
 
80
                     (compilation-speed 0)))
 
81
  (let ((slotd (find slot (class-slots class)
 
82
                     :test #'eq
 
83
                     :key #'slot-definition-name)))
 
84
    (if slotd
 
85
      (slot-makunbound-using-class class object slotd)
 
86
      (slot-missing class object slot 'slot-makunbound))))
 
87
 
 
88
(cl:defmethod slot-makunbound-using-class
 
89
           ((class standard-class) object (slotd standard-effective-slot-definition))
 
90
  (declare (optimize (speed 3) (debug 0) (safety 0)
 
91
                     (compilation-speed 0)))
 
92
  (slot-makunbound-using-class
 
93
   (load-time-value (class-prototype (find-class 'cl:standard-class)))
 
94
   object
 
95
   (slot-definition-name slotd)))
 
96
 
3
97
;; We need a new standard-generic-function for various things.
4
98
 
5
99
(cl:defclass standard-generic-function (cl:standard-generic-function)
63
157
(defun ensure-method (gf lambda-expression 
64
158
                         &key (qualifiers ())
65
159
                         (lambda-list (cadr lambda-expression))
66
 
                         (specializers (loop for arg in lambda-list
67
 
                                             until (member arg lambda-list-keywords)
68
 
                                             collect (find-class 't))))
 
160
                         (specializers (required-args lambda-list (constantly (find-class 't)))))
69
161
  (funcall (compile nil `(lambda ()
70
162
                           (defmethod ,(generic-function-name gf) ,@qualifiers
71
 
                             ,(loop for (arg . rest) on lambda-list
72
 
                                    for specializer in specializers
 
163
                             ,(loop for specializer in specializers
 
164
                                    for (arg . rest) on lambda-list
73
165
                                    collect `(,arg ,specializer) into args
74
166
                                    finally (return (nconc args rest)))
75
167
                             ,@(cddr lambda-expression))))))