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.3 2003/04/29 04:56:58 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   (:export
  46    #:class-of #:class-name #:class-slots #:find-class
  47    #:standard-class
  48    #:slot-definition-name #:finalize-inheritance
  49    #:standard-direct-slot-definition
  50    #:standard-effective-slot-definition #:validate-superclass
  51    #:direct-slot-definition-class #:compute-effective-slot-definition
  52    #:compute-effective-slot-definition-initargs
  53    #:slot-value-using-class
  54    #:class-prototype #:generic-function-method-class #:intern-eql-specializer
  55    #:make-method-lambda #:generic-function-lambda-list
  56    #:compute-slots)
  57    )
  58
  59 (in-package #:kmr-mop)
  60
  61 (shadowing-import
  62  #+allegro
  63  '(excl::compute-effective-slot-definition-initargs)
  64  #+lispworks
  65  '(clos::compute-effective-slot-definition-initargs)
  66  #+kmr-sbcl-mop
  67  '(sb-pcl::compute-effective-slot-definition-initargs)
  68  #+kmr-sbcl-pcl
  69  '(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl:find-class
  70    sb-pcl::standard-class
  71    sb-pcl:slot-definition-name sb-pcl::finalize-inheritance
  72    sb-pcl::standard-direct-slot-definition
  73    sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
  74    sb-pcl::direct-slot-definition-class sb-pcl::compute-effective-slot-definition
  75    sb-pcl::compute-effective-slot-definition-initargs
  76    sb-pcl::slot-value-using-class
  77    sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer
  78    sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list
  79    sb-pcl::compute-slots)
  80  #+kmr-cmucl-mop
  81  '(pcl::compute-effective-slot-definition-initargs)
  82  #+kmr-cmucl-pcl
  83  '(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
  84    pcl::slot-definition-name pcl:finalize-inheritance
  85    pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
  86    pcl::validate-superclass pcl:direct-slot-definition-class
  87    pcl:compute-effective-slot-definition
  88    pcl::compute-effective-slot-definition-initargs
  89    pcl::slot-value-using-class
  90    pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
  91    pcl:make-method-lambda pcl:generic-function-lambda-list
  92    pcl::compute-slots)
  93  #+scl
  94  '(clos::compute-effective-slot-definition-initargs
  95    clos::class-prototype
  96    ;; note: make-method-lambda is not fbound
  97    )
  98  '#:kmr-mop)
  99
 100 #+sbcl
 101 (eval-when (:compile-toplevel :load-toplevel :execute)
 102   (if (find-package 'sb-mop)
 103       (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*))
 104       (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*))))
 105
 106 #+cmu
 107 (eval-when (:compile-toplevel :load-toplevel :execute)
 108   (if (find-package 'mop)
 109       (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
 110       (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*))))
 111
 112 (eval-when (:compile-toplevel :load-toplevel :execute)
 113   (when (>= (length (generic-function-lambda-list
 114                      (ensure-generic-function
 115                       'compute-effective-slot-definition)))
 116             3)
 117     (pushnew :kmr-normal-cesd cl:*features*)))
 118
 119 (eval-when (:compile-toplevel :load-toplevel :execute)
 120   (when (>= (length (generic-function-lambda-list
 121                     (ensure-generic-function
 122                      'direct-slot-definition-class)))
 123             3)
 124     (pushnew :kmr-normal-dsdc cl:*features*)))
 125