/usr/share/common-lisp/source/clsql/sql/kmr-mop.lisp is in cl-sql 6.5.0-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 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: kmr-mop.lisp
;;;; Purpose: MOP support for multiple-implementions
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
;;;; This file imports MOP symbols into the CLSQL-MOP package and then
;;;; re-exports into CLSQL-SYS them to hide differences in
;;;; MOP implementations.
;;;;
;;;; This file was extracted from the KMRCL utilities
;;;; *************************************************************************
(in-package #:clsql-sys)
#+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)
(defclass %slot-order-test-class ()
((a)
(b)))
(finalize-inheritance (find-class '%slot-order-test-class))
(let ((slots (class-slots (find-class '%slot-order-test-class))))
(ecase (slot-definition-name (first slots))
(a)
(b (pushnew :mop-slot-order-reversed cl:*features*)))))
(defun ordered-class-slots (class)
#+mop-slot-order-reversed (reverse (class-slots class))
#-mop-slot-order-reversed (class-slots class))
(defun ordered-class-direct-slots (class)
"Gets an ordered list of direct class slots"
;; NB: this used to return effective-slot-definitions in direct
;; opposition to the function name. Not sure why
(setf class (to-class class))
#+mop-slot-order-reversed (reverse (class-direct-slots class))
#-mop-slot-order-reversed (class-direct-slots class))
(defun find-slot-if (class predicate &optional direct? recurse?)
"Looks up a direct-slot-definition by name"
(setf class (to-class class))
(labels ((find-it (class)
(let* ((slots (if direct?
(ordered-class-direct-slots class)
(ordered-class-slots class)))
(it (find-if predicate slots)))
(or it
(when recurse?
(loop for sup in (class-direct-superclasses class)
for rtn = (find-it sup)
until rtn
finally (return rtn)))))))
(find-it class)))
(defun find-slot-by-name (class slot-name &optional direct? recurse?)
"Looks up a direct-slot-definition by name"
(setf class (to-class class)
slot-name (to-slot-name slot-name))
(find-slot-if class (lambda (slot-def) (eql (to-slot-name slot-def) slot-name))
direct? recurse?))
;; Lispworks has symbol for slot rather than the slot instance
(defun %svuc-slot-name (slot)
#+lispworks slot
#-lispworks (slot-definition-name slot))
(defun %svuc-slot-object (slot class)
(declare (ignorable class))
#+lispworks (clos:find-slot-definition slot class)
#-lispworks slot)
|