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.9 2003/04/29 05:57:24 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    '(class-of class-name class-slots find-class mop::standard-class
  52      mop::slot-definition-name mop:finalize-inheritance
  53      mop::standard-direct-slot-definition mop::standard-effective-slot-definition
  54      mop::validate-superclass mop:direct-slot-definition-class
  55      mop:compute-effective-slot-definition
  56      excl::compute-effective-slot-definition-initargs
  57      mop::slot-value-using-class
  58      mop:class-prototype mop:generic-function-method-class mop:intern-eql-specializer
  59      mop:make-method-lambda mop:generic-function-lambda-list
  60      mop::compute-slots
  61      ;; note: make-method-lambda is not fbound
  62      )
  63    #+lispworks
  64    '(class-of class-name class-slots find-class
  65      clos::standard-class
  66      clos:slot-definition-name clos::finalize-inheritance
  67      clos::standard-direct-slot-definition
  68      clos::standard-effective-slot-definition clos::validate-superclass
  69      clos::direct-slot-definition-class clos::compute-effective-slot-definition
  70      clos::compute-effective-slot-definition-initargs
  71      clos::slot-value-using-class
  72      clos:class-prototype clos:generic-function-method-class clos:intern-eql-specializer
  73      clos:make-method-lambda clos:generic-function-lambda-list
  74      clos::compute-slots)
  75    #+sbcl
  76    '(#+kmr-sbcl-mop class-of #-kmr-sbcl-mop sb-pcl:class-of
  77      #+kmr-sbcl-mop class-name #-kmr-sbcl-mop sb-pcl:class-name
  78      #+kmr-sbcl-mop class-slots #-kmr-sbcl-mop sb-pcl:class-slots
  79      #+kmr-sbcl-mop find-class #-kmr-sbcl-mop sb-pcl:find-class
  80      sb-pcl::standard-class
  81      sb-pcl:slot-definition-name sb-pcl::finalize-inheritance
  82      sb-pcl::standard-direct-slot-definition
  83      sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
  84      sb-pcl::direct-slot-definition-class sb-pcl::compute-effective-slot-definition
  85      sb-pcl::compute-effective-slot-definition-initargs
  86      sb-pcl::slot-value-using-class
  87      sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer
  88      sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list
  89      sb-pcl::compute-slots)
  90    #+cmu
  91    '(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
  92      pcl::slot-definition-name pcl:finalize-inheritance
  93      pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
  94      pcl::validate-superclass pcl:direct-slot-definition-class
  95      pcl:compute-effective-slot-definition
  96      pcl::compute-effective-slot-definition-initargs
  97      pcl::slot-value-using-class
  98      pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
  99      pcl:make-method-lambda pcl:generic-function-lambda-list
 100      pcl::compute-slots)
 101    #+scl
 102    '(class-of class-name class-slots find-class clos::standard-class
 103      clos::slot-definition-name clos:finalize-inheritance
 104      clos::standard-direct-slot-definition clos::standard-effective-slot-definition
 105      clos::validate-superclass clos:direct-slot-definition-class
 106      clos:compute-effective-slot-definition
 107      clos::compute-effective-slot-definition-initargs
 108      clos::slot-value-using-class
 109      clos:class-prototype clos:generic-function-method-class clos:intern-eql-specializer
 110      clos:make-method-lambda clos:generic-function-lambda-list
 111      clos::compute-slots
 112      ;; note: make-method-lambda is not fbound
 113      ))
 114
 115   (export '(class-of class-name class-slots find-class
 116             standard-class
 117             slot-definition-name finalize-inheritance
 118             standard-direct-slot-definition
 119             standard-effective-slot-definition validate-superclass
 120             direct-slot-definition-class compute-effective-slot-definition
 121             compute-effective-slot-definition-initargs
 122             slot-value-using-class
 123             class-prototype generic-function-method-class intern-eql-specializer
 124             make-method-lambda generic-function-lambda-list
 125             compute-slots))
 126
 127   #+sbcl
 128   (if (find-package 'sb-mop)
 129       (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*))
 130       (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*)))
 131
 132   #+cmu
 133   (if (find-package 'mop)
 134       (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
 135       (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*)))
 136
 137   (when (>= (length (generic-function-lambda-list
 138                      (ensure-generic-function
 139                       'compute-effective-slot-definition)))
 140             3)
 141     (pushnew :kmr-normal-cesd cl:*features*))
 142
 143   (when (>= (length (generic-function-lambda-list
 144                      (ensure-generic-function
 145                       'direct-slot-definition-class)))
 146             3)
 147     (pushnew :kmr-normal-dsdc cl:*features*))
 148
 149   )  ;; eval-when