cl-kmrcl 1.106-1 / usr / share / common-lisp / source / kmrcl / mop.lisp

This file is indexed.

/usr/share/common-lisp/source/kmrcl/mop.lisp is in cl-kmrcl 1.106-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below. 

  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

APT Browse - Built by Thomas Orozco.