[Openmcl-cvs-notifications] r11120 - /trunk/source/level-1/l1-clos.lisp
gz at clozure.com
gz at clozure.com
Fri Oct 17 08:31:46 EDT 2008
Author: gz
Date: Fri Oct 17 08:31:46 2008
New Revision: 11120
Log:
>From working-0711 branch:
in make-instantiate-lambda-for-class-cell, don't bind class slot definition=
s if don't need 'em (avoids unref var warnings).
make the lambda-lists recorded for accessor methods use class name as the a=
rg name
record-source-file for accessor methods (so at least can get to the right f=
ile)
Modified:
trunk/source/level-1/l1-clos.lisp
Modified: trunk/source/level-1/l1-clos.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos.lisp (original)
+++ trunk/source/level-1/l1-clos.lisp Fri Oct 17 08:31:46 2008
@@ -642,9 +642,9 @@
(defun add-accessor-methods (class dslotds)
(dolist (dslotd dslotds)
(dolist (reader (%slot-definition-readers dslotd))
- (add-reader-method class =
- (ensure-generic-function reader)
- dslotd))
+ (add-reader-method class
+ (ensure-generic-function reader)
+ dslotd))
(dolist (writer (%slot-definition-writers dslotd))
(add-writer-method class
(ensure-generic-function writer)
@@ -908,7 +908,7 @@
(let* ((initargs
`(:qualifiers nil
:specializers ,(list class)
- :lambda-list (instance)
+ :lambda-list (,(or (%class-name class) 'instance))
:name ,(function-name gf)
:slot-definition ,dslotd))
(reader-method-class
@@ -919,6 +919,7 @@
:function method-function
initargs)))
(declare (dynamic-extent initargs))
+ (record-source-file method 'reader-method)
(add-method gf method)))
=
(defmethod remove-reader-method ((class std-class) gf)
@@ -942,7 +943,7 @@
(let* ((initargs
`(:qualifiers nil
:specializers ,(list *t-class* class)
- :lambda-list (new-value instance)
+ :lambda-list (new-value ,(or (%class-name class) 'instance))
:name ,(function-name gf)
:slot-definition ,dslotd))
(method-class (apply #'writer-method-class class dslotd initargs))
@@ -955,6 +956,7 @@
dslotd)
initargs)))
(declare (dynamic-extent initargs))
+ (record-source-file method 'writer-method)
(add-method gf method)))
=
(defmethod remove-writer-method ((class std-class) gf)
@@ -2202,14 +2204,12 @@
(initform (slot-definition-initform slot))
(location (slot-definition-location slot))
(location-var nil)
+ (class-init-p nil)
(one-initarg-p (null (cdr initargs)))
(name (slot-definition-name slot))
(type (slot-definition-type slot)))
(when (consp location)
- (setq location-var (gensym "LOCATION"))
- (class-binds `(,location-var
- (load-time-value
- (slot-definition-location ',slot)))))
+ (setq location-var (gensym "LOCATION")))
(when initfunction
(setq initform
(if (self-evaluating-p initform)
@@ -2220,11 +2220,12 @@
(if initfunction
(generate-type-check initform type)
`(%slot-unbound-marker))))
- (if (consp location)
+ (if location-var
(when initfunction
- (class-slot-inits
- `(when (eq (%slot-unbound-marker) (cdr ,=
location-var))
- (setf (cdr ,location-var) ,initial-va=
lue-form))))
+ (setq class-init-p t)
+ (class-slot-inits
+ `(when (eq (%slot-unbound-marker) (cdr ,lo=
cation-var))
+ (setf (cdr ,location-var) ,initial-valu=
e-form))))
(forms initial-value-form))))
(t (collect ((cond-clauses))
(let ((last-cond-clause nil))
@@ -2236,7 +2237,7 @@
(initial-value-form
(if (and initfunction
one-initarg-p
- (atom location))
+ (null location-var))
initform
(progn
(when initarg
@@ -2246,7 +2247,7 @@
(string inita=
rg)
"-P"))))
(and one-initarg-p
- (atom location)
+ (null location-var)
(if initfunction
initform
`(%slot-unbound-mark=
er))))))
@@ -2261,28 +2262,30 @@
`(funcall ,function)))))
(keys (list*
(list initarg name)
- (if (and default one-initarg-p (at=
om location))
+ (if (and default one-initarg-p (nu=
ll location-var))
default
initial-value-form)
(if spvar (list spvar))))
(if one-initarg-p
- (if (consp location)
- (class-slot-inits
- `(if ,spvar
- (setf (cdr ,location-var)
+ (if location-var
+ (progn
+ (setq class-init-p t)
+ (class-slot-inits
+ `(if ,spvar
+ (setf (cdr ,location-var)
+ ,(generate-type-check
+ name type))
+ ,(if default
+ `(setf (cdr ,location-var)
,(generate-type-check
- name type))
- ,(if default
- `(setf (cdr ,location-=
var)
- ,(generate-type=
-check
- default type))
- (when initfunction
- `(when (eq (%slot-un=
bound-marker)
- (cdr ,loc=
ation-var))
- (setf (cdr ,locat=
ion-var)
- ,(generate-=
type-check
- initform =
type)))))))
- (forms `,(generate-type-check nam=
e type spvar)))
+ default type))
+ (when initfunction
+ `(when (eq (%slot-unbound-=
marker)
+ (cdr ,location-=
var))
+ (setf (cdr ,location-va=
r)
+ ,(generate-type-c=
heck
+ initform type))=
))))))
+ (forms `,(generate-type-check name ty=
pe spvar)))
(progn (cond-clauses `(,spvar ,name))
(when (and default (null last-=
cond-clause))
(setq last-cond-clause
@@ -2290,7 +2293,7 @@
(when (cond-clauses)
(when last-cond-clause
(cond-clauses last-cond-clause))
- (cond ((atom location)
+ (cond ((null location-var)
(unless last-cond-clause
(cond-clauses `(t ,initform)))
(forms (generate-type-check
@@ -2307,6 +2310,7 @@
,(if initfunction
initform
`(%slot-unbound-marker=
)))))
+ (setq class-init-p t)
(class-slot-inits
`(let* (,@(and initform-p-var
(list `(,initform-=
p-var nil)))
@@ -2321,7 +2325,11 @@
(not (eq ,v=
alue-var
(%=
slot-unbound-marker)))))
t)
- (setf (cdr ,location-var) =
,value-var)))))))))))))))
+ (setf (cdr ,location-var) =
,value-var))))))))))))
+ (when class-init-p
+ (class-binds `(,location-var
+ (load-time-value
+ (slot-definition-location ',slot))))))))
(let* ((cell (make-symbol "CLASS-CELL"))
(args (make-symbol "ARGS"))
(slots (make-symbol "SLOTS"))
More information about the Openmcl-cvs-notifications
mailing list