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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: package.lisp
;;;; Purpose: Package definition for hyperobject package
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
(in-package #:cl-user)
#+cmu
(eval-when (:compile-toplevel :load-toplevel :execute)
(if (eq (symbol-package 'pcl:find-class)
(find-package 'common-lisp))
(pushnew :kmr-cmucl-mop cl:*features*)
(pushnew :kmr-cmucl-pcl cl:*features*)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (find-package '#:hyperobject-tests)
(delete-package '#:hyperobject-tests))
(when (find-package '#:hyperobject-user)
(delete-package '#:hyperobject-user))
(when (find-package '#:hyperobject)
(delete-package '#:hyperobject)))
(defpackage #:hyperobject
(:nicknames #:ho)
(:use #:common-lisp #:kmrcl
#+kmr-cmucl-mop #:mop
#+allegro #:mop
#+lispworks #:clos
#+scl #:clos
#+openmcl #:openmcl-mop)
(:export
#:package
#:hyperobject
#:hyperobject-class
#:hyperobject-class-user-name
#:load-all-subobjects
#:view
#:view-subobjects
#:fmt-comma-integer
#:processed-queued-definitions
#:all-subobjects
#:subobjects
#:cdata
))
(defpackage #:hyperobject-user
(:nicknames #:ho-user)
(:use #:hyperobject #:cl #:cl-user))
(eval-when (:compile-toplevel :load-toplevel :execute)
#+sbcl
(dolist (name '("CLASS-OF"
"CLASS-NAME"
"CLASS-SLOTS"
"FIND-CLASS"
"STANDARD-CLASS"
"SLOT-DEFINITION-NAME"
"FINALIZE-INHERITANCE"
"STANDARD-DIRECT-SLOT-DEFINITION"
"CLASS-PRECEDENCE-LIST"
"STANDARD-EFFECTIVE-SLOT-DEFINITION"
"VALIDATE-SUPERCLASS" "DIRECT-SLOT-DEFINITION-CLASS"
"EFFECTIVE-SLOT-DEFINITION-CLASS"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION"
"CLASS-DIRECT-SLOTS"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"
"SLOT-VALUE-USING-CLASS"
"CLASS-PROTOTYPE"
"GENERIC-FUNCTION-METHOD-CLASS"
"INTERN-EQL-SPECIALIZER"
"MAKE-METHOD-LAMBDA"
"GENERIC-FUNCTION-LAMBDA-LIST"
"COMPUTE-SLOTS"))
(let ((sym (find-symbol name "SB-MOP")))
(if sym
(progn (shadowing-import sym :hyperobject))
(progn
(setq sym (find-symbol name "SB-PCL"))
(if sym
(shadowing-import sym :hyperobject)
(warn "Can't find function ~A in packages SB-MOP or SB-PCL" name))))))
#-sbcl
(shadowing-import
#+allegro
'(excl::compute-effective-slot-definition-initargs)
#+lispworks
'(clos::compute-effective-slot-definition-initargs)
#+kmr-cmucl-mop
'(pcl::compute-effective-slot-definition-initargs)
#+kmr-cmucl-pcl
'(pcl:class-of pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
pcl::slot-definition-name pcl:finalize-inheritance
pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
pcl::validate-superclass pcl:direct-slot-definition-class
pcl:compute-effective-slot-definition
pcl::compute-effective-slot-definition-initargs
pcl::slot-value-using-class
pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
pcl:make-method-lambda pcl:generic-function-lambda-list
pcl:slot-definition-type
pcl::class-precedence-list)
#+clisp
'(clos:class-name clos:class-slots clos:find-class clos::standard-class
clos::slot-definition-name clos:finalize-inheritance
clos::standard-direct-slot-definition clos::standard-effective-slot-definition
clos::validate-superclass clos:direct-slot-definition-class
clos:effective-slot-definition-class
clos:slot-definition-type
clos:compute-effective-slot-definition
clos::compute-effective-slot-definition-initargs
clos::slot-value-using-class
clos:class-prototype clos:generic-function-method-class clos:intern-eql-specializer
clos:generic-function-lambda-list
clos::class-precedence-list)
#+scl
'(clos::compute-effective-slot-definition-initargs
clos::class-prototype
clos:slot-definition-type
;; note: make-method-lambda is not fbound
)
:hyperobject))
#+cmu
(eval-when (:compile-toplevel :load-toplevel :execute)
(if (find-package 'mop)
(setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
(setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*))))
|
