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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: mop.lisp
;;;; Purpose: Imports standard MOP symbols into KMRCL
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
;;; This file imports MOP symbols into KMR-MOP packages and then
;;; re-exports them to hide differences in MOP implementations.
(in-package #:cl-user)
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(if (find-package 'sb-mop)
(pushnew 'kmrcl::sbcl-mop cl:*features*)
(pushnew 'kmrcl::sbcl-pcl cl:*features*)))
#+cmu
(eval-when (:compile-toplevel :load-toplevel :execute)
(if (eq (symbol-package 'pcl:find-class)
(find-package 'common-lisp))
(pushnew 'kmrcl::cmucl-mop cl:*features*)
(pushnew 'kmrcl::cmucl-pcl cl:*features*)))
(defpackage #:kmr-mop
(:use
#:cl
#:kmrcl
#+kmrcl::sbcl-mop #:sb-mop
#+kmrcl::cmucl-mop #:mop
#+allegro #:mop
#+lispworks #:clos
#+clisp #:clos
#+scl #:clos
#+ccl #:openmcl-mop
)
)
(in-package #:kmr-mop)
#+lispworks
(defun intern-eql-specializer (slot)
`(eql ,slot))
(defmacro process-class-option (metaclass slot-name &optional required)
#+lispworks
`(defmethod clos:process-a-class-option ((class ,metaclass)
(name (eql ,slot-name))
value)
(when (and ,required (null value))
(error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
(list name `',value))
#-lispworks
(declare (ignore metaclass slot-name required))
)
(defmacro process-slot-option (metaclass slot-name)
#+lispworks
`(defmethod clos:process-a-slot-option ((class ,metaclass)
(option (eql ,slot-name))
value
already-processed-options
slot)
(list* option `',value already-processed-options))
#-lispworks
(declare (ignore metaclass slot-name))
)
(eval-when (:compile-toplevel :load-toplevel :execute)
(shadowing-import
#+allegro
'(excl::compute-effective-slot-definition-initargs)
#+lispworks
'(clos::compute-effective-slot-definition-initargs)
#+clisp
'(clos::compute-effective-slot-definition-initargs)
#+sbcl
'(#+kmrcl::sbcl-mop class-of #-kmrcl::sbcl-mop sb-pcl:class-of
#+kmrcl::sbcl-mop class-name #-kmrcl::sbcl-mop sb-pcl:class-name
#+kmrcl::sbcl-mop class-slots #-kmrcl::sbcl-mop sb-pcl:class-slots
#+kmrcl::sbcl-mop find-class #-kmrcl::sbcl-mop sb-pcl:find-class
sb-pcl::standard-class
sb-pcl:slot-definition-name sb-pcl::finalize-inheritance
sb-pcl::standard-direct-slot-definition
sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
sb-pcl::direct-slot-definition-class
sb-pcl::effective-slot-definition-class
sb-pcl::compute-effective-slot-definition
sb-pcl:class-direct-slots
sb-pcl::compute-effective-slot-definition-initargs
sb-pcl::slot-value-using-class
sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer
sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list
sb-pcl::compute-slots)
#+cmu
'(pcl:class-of pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
pcl::slot-definition-name pcl:finalize-inheritance
pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
pcl::validate-superclass pcl:direct-slot-definition-class pcl::effective-slot-definition-class
pcl:compute-effective-slot-definition
pcl:class-direct-slots
pcl::compute-effective-slot-definition-initargs
pcl::slot-value-using-class
pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
pcl:make-method-lambda pcl:generic-function-lambda-list
pcl::compute-slots)
#+scl
'(class-of class-name class-slots find-class clos::standard-class
clos::slot-definition-name clos:finalize-inheritance
clos::standard-direct-slot-definition clos::standard-effective-slot-definition
clos::effective-slot-definition-class
clos:class-direct-slots
clos::validate-superclass clos:direct-slot-definition-class
clos:compute-effective-slot-definition
clos::compute-effective-slot-definition-initargs
clos::slot-value-using-class
clos::class-prototype clos:generic-function-method-class clos:intern-eql-specializer
clos:make-method-lambda clos:generic-function-lambda-list
clos::compute-slots
;; note: make-method-lambda is not fbound
)
#+ccl
'(openmcl-mop::slot-definition-name openmcl-mop:finalize-inheritance
openmcl-mop::standard-direct-slot-definition openmcl-mop::standard-effective-slot-definition
openmcl-mop::validate-superclass openmcl-mop:direct-slot-definition-class openmcl-mop::effective-slot-definition-class
openmcl-mop:compute-effective-slot-definition
openmcl-mop:class-direct-slots
openmcl-mop::compute-effective-slot-definition-initargs
openmcl-mop::slot-value-using-class
openmcl-mop:class-prototype openmcl-mop:generic-function-method-class openmcl-mop:intern-eql-specializer
openmcl-mop:make-method-lambda openmcl-mop:generic-function-lambda-list
openmcl-mop::compute-slots) ))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(class-of class-name class-slots find-class
standard-class
slot-definition-name finalize-inheritance
standard-direct-slot-definition
standard-effective-slot-definition validate-superclass
compute-effective-slot-definition-initargs
direct-slot-definition-class effective-slot-definition-class
compute-effective-slot-definition
slot-value-using-class
class-prototype generic-function-method-class intern-eql-specializer
make-method-lambda generic-function-lambda-list
compute-slots
class-direct-slots
;; KMR-MOP encapsulating macros
process-slot-option
process-class-option))
#+sbcl
(if (find-package 'sb-mop)
(setq cl:*features* (delete 'kmrcl::sbcl-mop cl:*features*))
(setq cl:*features* (delete 'kmrcl::sbcl-pcl cl:*features*)))
#+cmu
(if (find-package 'mop)
(setq cl:*features* (delete 'kmrcl::cmucl-mop cl:*features*))
(setq cl:*features* (delete 'kmrcl::cmucl-pcl cl:*features*)))
(when (< (length (generic-function-lambda-list
(ensure-generic-function
'compute-effective-slot-definition)))
3)
(pushnew 'short-arg-cesd cl:*features*))
(when (< (length (generic-function-lambda-list
(ensure-generic-function
'direct-slot-definition-class)))
3)
(pushnew 'short-arg-dsdc cl:*features*))
) ;; eval-when
|