r4681: Auto commit for Debian build
[kmrcl.git] / mop.lisp
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
4 ;;;;
5 ;;;; Name:          mop.lisp
6 ;;;; Purpose:       Imports standard MOP symbols into KMRCL
7 ;;;; Programmer:    Kevin M. Rosenberg
8 ;;;; Date Started:  Apr 2003
9 ;;;;
10 ;;;; $Id: mop.lisp,v 1.5 2003/04/29 05:02:21 kevin Exp $
11 ;;;;
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
13 ;;;;
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
18
19 ;;; This file imports MOP symbols into KMR-MOP packages and then
20 ;;; re-exports them to hide differences in MOP implementations.
21
22 (in-package #:cl-user)
23
24 #+sbcl
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26   (if (find-package 'sb-mop)
27       (pushnew :kmr-sbcl-mop cl:*features*)
28       (pushnew :kmr-sbcl-pcl cl:*features*)))
29
30 #+cmu
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32   (if (find-package 'mop)
33       (pushnew :kmr-cmucl-mop cl:*features*)
34       (pushnew :kmr-cmucl-pcl cl:*features*)))
35
36 (defpackage #:kmr-mop
37   (:use
38    #:cl
39    #:kmrcl
40    #+kmr-sbcl-mop #:sb-mop
41    #+kmr-cmucl-mop #:mop
42    #+allegro #:mop
43    #+lispworks #:clos
44    #+scl #:clos))
45
46 (in-package #:kmr-mop)
47
48 (eval-when (:compile-toplevel :load-toplevel :execute)
49   (shadowing-import
50    #+allegro
51    '(excl::compute-effective-slot-definition-initargs)
52    #+lispworks
53    '(clos::compute-effective-slot-definition-initargs)
54    #+kmr-sbcl-mop 
55    '(sb-pcl::compute-effective-slot-definition-initargs)
56    #+kmr-sbcl-pcl
57    '(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl:find-class
58      sb-pcl::standard-class
59      sb-pcl:slot-definition-name sb-pcl::finalize-inheritance
60      sb-pcl::standard-direct-slot-definition
61      sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
62      sb-pcl::direct-slot-definition-class sb-pcl::compute-effective-slot-definition
63      sb-pcl::compute-effective-slot-definition-initargs
64      sb-pcl::slot-value-using-class
65      sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer
66      sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list
67      sb-pcl::compute-slots)
68    #+kmr-cmucl-mop 
69    '(pcl::compute-effective-slot-definition-initargs)
70    #+kmr-cmucl-pcl
71    '(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
72      pcl::slot-definition-name pcl:finalize-inheritance
73      pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
74      pcl::validate-superclass pcl:direct-slot-definition-class
75      pcl:compute-effective-slot-definition
76      pcl::compute-effective-slot-definition-initargs
77      pcl::slot-value-using-class
78      pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
79      pcl:make-method-lambda pcl:generic-function-lambda-list
80      pcl::compute-slots)
81    #+scl
82    '(clos::compute-effective-slot-definition-initargs
83      clos::class-prototype
84      ;; note: make-method-lambda is not fbound
85      )
86    '#:kmr-mop)
87   
88   (export '(#:class-of #:class-name #:class-slots #:find-class
89             #:standard-class
90             #:slot-definition-name #:finalize-inheritance
91             #:standard-direct-slot-definition
92             #:standard-effective-slot-definition #:validate-superclass
93             #:direct-slot-definition-class #:compute-effective-slot-definition
94             #:compute-effective-slot-definition-initargs
95             #:slot-value-using-class
96             #:class-prototype #:generic-function-method-class #:intern-eql-specializer
97             #:make-method-lambda #:generic-function-lambda-list
98             #:compute-slots))
99   
100   #+sbcl
101   (if (find-package 'sb-mop)
102       (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*))
103       (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*)))
104   
105   #+cmu
106   (if (find-package 'mop)
107       (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
108       (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*)))
109   
110   (when (>= (length (generic-function-lambda-list
111                      (ensure-generic-function
112                       'compute-effective-slot-definition)))
113             3)
114     (pushnew :kmr-normal-cesd cl:*features*))
115   
116   (when (>= (length (generic-function-lambda-list
117                      (ensure-generic-function
118                       'direct-slot-definition-class)))
119             3)
120     (pushnew :kmr-normal-dsdc cl:*features*))
121
122   )  ;; eval-when