projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
0.8.0.2:
[sbcl.git]
/
src
/
pcl
/
defclass.lisp
diff --git
a/src/pcl/defclass.lisp
b/src/pcl/defclass.lisp
index
dfba214
..
2c1dfed
100644
(file)
--- a/
src/pcl/defclass.lisp
+++ b/
src/pcl/defclass.lisp
@@
-48,6
+48,7
@@
(defvar *initfunctions-for-this-defclass*)
(defvar *readers-for-this-defclass*)
(defvar *writers-for-this-defclass*)
(defvar *initfunctions-for-this-defclass*)
(defvar *readers-for-this-defclass*)
(defvar *writers-for-this-defclass*)
+(defvar *slot-names-for-this-defclass*)
;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
@@
-71,17
+72,14
@@
(error "The value of the :metaclass option (~S) is not a~%~
legal class name."
(cadr option)))
(error "The value of the :metaclass option (~S) is not a~%~
legal class name."
(cadr option)))
- (setq metaclass
- (case (cadr option)
- (cl:standard-class 'standard-class)
- (cl:structure-class 'structure-class)
- (t (cadr option))))
+ (setq metaclass (cadr option))
(setf options (remove option options))
(return t))))
(let ((*initfunctions-for-this-defclass* ())
(*readers-for-this-defclass* ()) ;Truly a crock, but we got
(setf options (remove option options))
(return t))))
(let ((*initfunctions-for-this-defclass* ())
(*readers-for-this-defclass* ()) ;Truly a crock, but we got
- (*writers-for-this-defclass* ())) ;to have it to live nicely.
+ (*writers-for-this-defclass* ()) ;to have it to live nicely.
+ (*slot-names-for-this-defclass* ()))
(let ((canonical-slots
(mapcar (lambda (spec)
(canonicalize-slot-specification name spec))
(let ((canonical-slots
(mapcar (lambda (spec)
(canonicalize-slot-specification name spec))
@@
-107,6
+105,13
@@
,@(mapcar (lambda (x)
`(declaim (ftype (function (t t) t) ,x)))
*writers-for-this-defclass*)
,@(mapcar (lambda (x)
`(declaim (ftype (function (t t) t) ,x)))
*writers-for-this-defclass*)
+ ,@(mapcar (lambda (x)
+ `(declaim (ftype (function (t) t)
+ ,(slot-reader-name x)
+ ,(slot-boundp-name x))
+ (ftype (function (t t) t)
+ ,(slot-writer-name x))))
+ *slot-names-for-this-defclass*)
(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
(load-defclass ',name
',metaclass
(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
(load-defclass ',name
',metaclass
@@
-180,10
+185,12
@@
(cond ((and (symbolp spec)
(not (keywordp spec))
(not (memq spec '(t nil))))
(cond ((and (symbolp spec)
(not (keywordp spec))
(not (memq spec '(t nil))))
+ (push spec *slot-names-for-this-defclass*)
`'(:name ,spec))
((not (consp spec))
(error "~S is not a legal slot specification." spec))
((null (cdr spec))
`'(:name ,spec))
((not (consp spec))
(error "~S is not a legal slot specification." spec))
((null (cdr spec))
+ (push (car spec) *slot-names-for-this-defclass*)
`'(:name ,(car spec)))
((null (cddr spec))
(error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
`'(:name ,(car spec)))
((null (cddr spec))
(error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
@@
-196,6
+203,7
@@
(initargs ())
(unsupplied (list nil))
(initform (getf spec :initform unsupplied)))
(initargs ())
(unsupplied (list nil))
(initform (getf spec :initform unsupplied)))
+ (push name *slot-names-for-this-defclass*)
(doplist (key val) spec
(case key
(:accessor (push val readers)
(doplist (key val) spec
(case key
(:accessor (push val readers)
@@
-219,7
+227,7
@@
(if (eq initform unsupplied)
`(list* ,@spec)
`(list* :initfunction ,(make-initfunction initform) ,@spec))))))
(if (eq initform unsupplied)
`(list* ,@spec)
`(list* :initfunction ,(make-initfunction initform) ,@spec))))))
-
+
(defun canonicalize-defclass-option (class-name option)
(declare (ignore class-name))
(case (car option)
(defun canonicalize-defclass-option (class-name option)
(declare (ignore class-name))
(case (car option)
@@
-388,7
+396,7
@@
canonical-options (copy-tree canonical-options))
(let ((ecd
(make-early-class-definition name
canonical-options (copy-tree canonical-options))
(let ((ecd
(make-early-class-definition name
- *load-truename*
+ *load-pathname*
metaclass
supers
canonical-slots
metaclass
supers
canonical-slots