package.lisp

   1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          package.lisp
   6 ;;;; Purpose:       Package definition for hyperobject package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
  11 ;;;; *************************************************************************
  12
  13 (in-package #:cl-user)
  14
  15 #+cmu
  16 (eval-when (:compile-toplevel :load-toplevel :execute)
  17   (if (eq (symbol-package 'pcl:find-class)
  18           (find-package 'common-lisp))
  19       (pushnew :kmr-cmucl-mop cl:*features*)
  20       (pushnew :kmr-cmucl-pcl cl:*features*)))
  21
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23   (when (find-package '#:hyperobject-tests)
  24     (delete-package '#:hyperobject-tests))
  25   (when (find-package '#:hyperobject-user)
  26     (delete-package '#:hyperobject-user))
  27   (when (find-package '#:hyperobject)
  28     (delete-package '#:hyperobject)))
  29
  30 (defpackage #:hyperobject
  31   (:nicknames #:ho)
  32   (:use #:common-lisp #:kmrcl
  33         #+kmr-cmucl-mop #:mop
  34         #+allegro #:mop
  35         #+lispworks #:clos
  36         #+scl #:clos
  37         #+openmcl #:openmcl-mop)
  38   (:export
  39    #:package
  40    #:hyperobject
  41    #:hyperobject-class
  42    #:hyperobject-class-user-name
  43    #:load-all-subobjects
  44    #:view
  45    #:view-subobjects
  46    #:fmt-comma-integer
  47    #:processed-queued-definitions
  48    #:all-subobjects
  49    #:subobjects
  50    #:cdata
  51    ))
  52
  53 (defpackage #:hyperobject-user
  54   (:nicknames #:ho-user)
  55   (:use #:hyperobject #:cl #:cl-user))
  56
  57 (eval-when (:compile-toplevel :load-toplevel :execute)
  58   #+sbcl
  59   (dolist (name '("CLASS-OF"
  60                   "CLASS-NAME"
  61                   "CLASS-SLOTS"
  62                   "FIND-CLASS"
  63                   "STANDARD-CLASS"
  64                   "SLOT-DEFINITION-NAME"
  65                   "FINALIZE-INHERITANCE"
  66                   "STANDARD-DIRECT-SLOT-DEFINITION"
  67                   "CLASS-PRECEDENCE-LIST"
  68                   "STANDARD-EFFECTIVE-SLOT-DEFINITION"
  69                   "VALIDATE-SUPERCLASS" "DIRECT-SLOT-DEFINITION-CLASS"
  70                   "EFFECTIVE-SLOT-DEFINITION-CLASS"
  71                   "COMPUTE-EFFECTIVE-SLOT-DEFINITION"
  72                   "CLASS-DIRECT-SLOTS"
  73                   "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"
  74                   "SLOT-VALUE-USING-CLASS"
  75                   "CLASS-PROTOTYPE"
  76                   "GENERIC-FUNCTION-METHOD-CLASS"
  77                   "INTERN-EQL-SPECIALIZER"
  78                   "MAKE-METHOD-LAMBDA"
  79                   "GENERIC-FUNCTION-LAMBDA-LIST"
  80                   "COMPUTE-SLOTS"))
  81     (let ((sym (find-symbol name "SB-MOP")))
  82       (if sym
  83           (progn (shadowing-import sym :hyperobject))
  84           (progn
  85             (setq sym (find-symbol name "SB-PCL"))
  86             (if sym
  87                 (shadowing-import sym :hyperobject)
  88                 (warn "Can't find function ~A in packages SB-MOP or SB-PCL" name))))))
  89   #-sbcl
  90   (shadowing-import
  91    #+allegro
  92    '(excl::compute-effective-slot-definition-initargs)
  93    #+lispworks
  94    '(clos::compute-effective-slot-definition-initargs)
  95    #+kmr-cmucl-mop
  96    '(pcl::compute-effective-slot-definition-initargs)
  97    #+kmr-cmucl-pcl
  98    '(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
  99      pcl::slot-definition-name pcl:finalize-inheritance
 100      pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
 101      pcl::validate-superclass pcl:direct-slot-definition-class
 102      pcl:compute-effective-slot-definition
 103      pcl::compute-effective-slot-definition-initargs
 104      pcl::slot-value-using-class
 105      pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
 106      pcl:make-method-lambda pcl:generic-function-lambda-list
 107      pcl:slot-definition-type
 108      pcl::class-precedence-list)
 109    #+clisp
 110    '(clos:class-name clos:class-slots clos:find-class clos::standard-class
 111      clos::slot-definition-name clos:finalize-inheritance
 112      clos::standard-direct-slot-definition clos::standard-effective-slot-definition
 113      clos::validate-superclass clos:direct-slot-definition-class
 114      clos:effective-slot-definition-class
 115      clos:slot-definition-type
 116      clos:compute-effective-slot-definition
 117      clos::compute-effective-slot-definition-initargs
 118      clos::slot-value-using-class
 119      clos:class-prototype clos:generic-function-method-class clos:intern-eql-specializer
 120      clos:generic-function-lambda-list
 121      clos::class-precedence-list)
 122    #+scl
 123    '(clos::compute-effective-slot-definition-initargs
 124      clos::class-prototype
 125      clos:slot-definition-type
 126      ;; note: make-method-lambda is not fbound
 127      )
 128    :hyperobject))
 129
 130 #+cmu
 131 (eval-when (:compile-toplevel :load-toplevel :execute)
 132   (if (find-package 'mop)
 133       (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
 134       (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*))))