Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl-copy
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Richard M Kreuter
cmucl-copy
Commits
83231787
Commit
83231787
authored
11 years ago
by
Raymond Toy
Browse files
Options
Downloads
Patches
Plain Diff
Remove the tests and just use mk-defsystem to load the separate PCL
test files.
parent
3feda4af
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
tests/pcl.lisp
+66
-2006
66 additions, 2006 deletions
tests/pcl.lisp
with
66 additions
and
2006 deletions
tests/pcl.lisp
+
66
−
2006
View file @
83231787
;;; Tests for PCL, taken from src/pcl/rt.
;;;
;;; It's clear that the tests used mk defsystem to load the tests, but
;;; it's not clear if the tests were compiled or not before running.
(
defpackage
"PCL-TESTS"
(
:use
"COMMON-LISP"
"PCL"
"LISP-UNIT"
))
(
in-package
"PCL-TESTS"
)
;; Simple macro converting RT's DEFTEST to lisp-unit's DEFINE-TEST.
(
defmacro
deftest
(
name
form
&rest
values
)
(
let
((
results
(
gensym
"RESULTS-"
)))
`
(
define-test
,
name
...
...
@@ -21,2006 +19,68 @@
(
defun
,
name
()
,
form
)
(
deftest
,
name
(
,
name
)
,@
values
)))
;; ctor.lisp
(
deftest
plist-keys.0
(
pcl::plist-keys
'
())
nil
)
(
deftest
plist-keys.1
(
pcl::plist-keys
'
(
:a
1
:b
2
))
(
:a
:b
))
(
deftest
plist-keys.2
(
multiple-value-bind
(
result
condition
)
(
ignore-errors
(
pcl::plist-keys
'
(
:a
)))
(
values
result
(
typep
condition
'condition
)))
nil
t
)
(
deftest
make-instance->constructor-call.0
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
a
x
))
nil
)
(
deftest
make-instance->constructor-call.1
(
pcl::make-instance->constructor-call
'
(
make-instance
foo
:a
x
))
nil
)
(
deftest
make-instance->constructor-call.2
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
x
))
nil
)
(
deftest
make-instance->constructor-call.4
(
pcl::make-instance->constructor-call
'
(
make-instance
1
))
nil
)
(
deftest
make-instance->constructor-call.5
(
let*
((
form
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
)))
(
call
(
car
(
last
form
))))
(
values
(
eq
(
first
call
)
'funcall
)
(
cddr
call
)))
t
())
(
deftest
make-instance->constructor-call.6
(
let*
((
form
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
:x
1
:y
2
)))
(
call
(
car
(
last
form
))))
(
values
(
eq
(
first
call
)
'funcall
)
(
cddr
call
)))
t
())
(
deftest
make-instance->constructor-call.7
(
let*
((
form
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
:x
x
:y
2
)))
(
call
(
car
(
last
form
))))
(
values
(
eq
(
first
call
)
'funcall
)
(
cddr
call
)))
t
(
x
))
(
deftest
make-instance->constructor-call.8
(
let*
((
form
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
:x
x
:y
y
)))
(
call
(
car
(
last
form
))))
(
values
(
eq
(
first
call
)
'funcall
)
(
cddr
call
)))
t
(
x
y
))
(
deftest
make-instance->constructor-call.9
(
let*
((
form
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
:x
x
:y
1
)))
(
call
(
car
(
last
form
))))
(
values
(
eq
(
first
call
)
'funcall
)
(
cddr
call
)))
t
(
x
))
(
deftest
make-instance->constructor-call.10
(
let*
((
form
(
pcl::make-instance->constructor-call
'
(
make-instance
'foo
:x
x
:y
1
:z
z
)))
(
call
(
car
(
last
form
))))
(
values
(
eq
(
first
call
)
'funcall
)
(
cddr
call
)))
t
(
x
z
))
(
deftest
make-ctor.0
(
let
((
ctor
(
pcl::make-ctor
'
(
pcl::ctor
bar
)
'bar
'
(
:x
1
:y
2
))))
(
values
(
pcl::ctor-function-name
ctor
)
(
pcl::ctor-class-name
ctor
)
(
pcl::ctor-initargs
ctor
)))
(
pcl::ctor
bar
)
bar
(
:x
1
:y
2
))
(
defclass
foo
()
((
a
:initarg
:a
:initform
1
)
(
b
:initarg
:b
:initform
2
)))
(
defun
call-generator
(
generator
function-name
class-name
args
)
(
declare
(
ignore
function-name
))
(
let*
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
class-name
)
class-name
args
))
(
class
(
find-class
class-name
))
(
proto
(
pcl::class-prototype
class
))
(
ii
(
pcl::compute-applicable-methods
#'
initialize-instance
(
list
proto
)))
(
si
(
pcl::compute-applicable-methods
#'
shared-initialize
(
list
proto
t
))))
(
setf
(
pcl::ctor-class
ctor
)
class
)
(
if
(
eq
generator
#'
pcl::fallback-generator
)
(
funcall
generator
ctor
)
(
funcall
generator
ctor
ii
si
))))
(
deftest
fallback-generator.0
(
let
((
fn
(
call-generator
#'
pcl::fallback-generator
'make-foo
'foo
'
(
:a
0
:b
1
))))
(
values
(
second
fn
)
(
type-of
(
second
(
third
fn
)))
(
nthcdr
2
(
third
fn
))))
()
pcl::standard-class
(
:a
0
:b
1
))
(
deftest
fallback-generator.1
(
let
((
fn
(
call-generator
#'
pcl::fallback-generator
'make-foo
'foo
'
(
:a
0
))))
(
values
(
second
fn
)
(
first
(
third
fn
))
(
type-of
(
second
(
third
fn
)))
(
nthcdr
2
(
third
fn
))))
()
make-instance
pcl::standard-class
(
:a
0
))
(
deftest
fallback-generator.2
(
let
((
fn
(
call-generator
#'
pcl::fallback-generator
'make-foo
'foo
'
())))
(
values
(
second
fn
)
(
type-of
(
second
(
third
fn
)))
(
nthcdr
2
(
third
fn
))))
()
pcl::standard-class
())
(
deftest
fallback-generator.3
(
let
((
fn
(
call-generator
#'
pcl::fallback-generator
'make-foo
'foo
'
(
:a
.
p0.
))))
(
values
(
second
fn
)
(
type-of
(
second
(
third
fn
)))
(
nthcdr
2
(
third
fn
))))
(
.
p0.
)
pcl::standard-class
(
:a
.
p0.
))
(
deftest
fallback-generator.4
(
let
((
fn
(
call-generator
#'
pcl::fallback-generator
'make-foo
'foo
'
(
:a
a
:b
b
))))
(
values
(
second
fn
)
(
type-of
(
second
(
third
fn
)))
(
nthcdr
2
(
third
fn
))))
(
a
b
)
pcl::standard-class
(
:a
a
:b
b
))
;;; These depend on the actual slot definition location computation,
;;; which may be different in my PCL than in the CVS PCL.
(
deftest
compute-initarg-locations.0
(
let
((
class
(
find-class
'foo
)))
(
pcl::compute-initarg-locations
class
'
(
:a
:b
)))
((
:a
(
0
.
t
))
(
:b
(
1
.
t
))))
(
defclass
foo2
(
foo
)
((
c
:initarg
:a
)))
(
deftest
compute-initarg-locations.1
(
let
((
class
(
find-class
'foo2
)))
(
pcl::compute-initarg-locations
class
'
(
:a
:b
)))
((
:a
(
0
.
t
)
(
2
.
t
))
(
:b
(
1
.
t
))))
(
defclass
foo3
(
foo
)
((
c
:initarg
:a
:allocation
:class
)))
;;;
;;; This test must be compiled for the case that PCL::+SLOT-UNBOUND+
;;; is a symbol macro calling PCL::MAKE-UNBOUND-MARKER, otherwise
;;; we'll get a complaint that C::%%PRIMITIVE is not defined.
;;;
(
define-compiled-test
compute-initarg-locations.2
(
let
((
class
(
find-class
'foo3
)))
(
subst
'unbound
pcl::+slot-unbound+
(
pcl::compute-initarg-locations
class
'
(
:a
:b
))))
((
:a
(
0
.
t
)
((
c
.
unbound
)
.
t
))
(
:b
(
1
.
t
))))
(
defclass
foo4
()
((
a
:initarg
:a
:initarg
:both
)
(
b
:initarg
:b
:initarg
:both
)))
(
deftest
compute-initarg-locations.3
(
let
((
class
(
find-class
'foo4
)))
(
pcl::compute-initarg-locations
class
'
(
:both
:a
:b
)))
((
:both
(
0
.
t
)
(
1
.
t
))
(
:a
)
(
:b
)))
(
deftest
compute-initarg-locations.4
(
let
((
class
(
find-class
'foo4
)))
(
pcl::compute-initarg-locations
class
'
(
:a
:both
)))
((
:a
(
0
.
t
))
(
:both
(
1
.
t
))))
(
deftest
slot-init-forms.0
(
let
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo
'
(
:a
a
:b
b
))))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo
))
(
pcl::slot-init-forms
ctor
nil
))
(
let
()
(
declare
(
ignorable
)
(
optimize
(
safety
3
)))
(
setf
(
svref
pcl::.slots.
0
)
(
the
t
a
))
(
setf
(
svref
pcl::.slots.
1
)
(
the
t
b
)))
nil
)
(
deftest
slot-init-forms.1
(
let
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo
'
(
:a
a
))))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo
))
(
pcl::slot-init-forms
ctor
nil
))
(
let
()
(
declare
(
ignorable
)
(
optimize
(
safety
3
)))
(
setf
(
svref
pcl::.slots.
0
)
(
the
t
a
))
(
setf
(
svref
pcl::.slots.
1
)
(
the
t
'2
)))
nil
)
(
defclass
foo5
()
((
a
:initarg
:a
:initform
0
)
(
b
:initarg
:b
)))
(
deftest
slot-init-forms.2
(
let
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo5
'
(
:a
a
))))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo5
))
(
pcl::slot-init-forms
ctor
nil
))
(
let
()
(
declare
(
ignorable
)
(
optimize
(
safety
3
)))
(
setf
(
svref
pcl::.slots.
0
)
(
the
t
a
))
(
setf
(
svref
pcl::.slots.
1
)
pcl::+slot-unbound+
))
nil
)
(
defclass
foo5a
()
((
a
:initarg
:a
:initform
0
)
(
b
:initarg
:b
:initform
0
)))
(
deftest
slot-init-forms.2a
(
let
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo5a
'
())))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo5a
))
(
pcl::slot-init-forms
ctor
nil
))
(
let
()
(
declare
(
ignorable
)
(
optimize
(
safety
3
)))
(
setf
(
svref
pcl::.slots.
0
)
(
the
t
'0
))
(
setf
(
svref
pcl::.slots.
1
)
(
the
t
'0
)))
nil
)
(
defclass
foo6
()
((
a
:initarg
:a
:initform
0
:allocation
:class
)
(
b
:initarg
:b
)))
(
deftest
slot-init-forms.3
(
let
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo6
'
(
:a
a
))))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo6
))
(
pcl::slot-init-forms
ctor
nil
))
(
let
()
(
declare
(
ignorable
)
(
optimize
(
safety
3
)))
(
setf
(
svref
pcl::.slots.
0
)
pcl::+slot-unbound+
)
(
setf
(
cdr
'
(
a
.
0
))
(
the
t
a
)))
nil
)
(
defun
foo
()
(
error
"should never be called"
))
(
defclass
foo7
()
((
a
:initarg
:a
:initform
(
foo
))
(
b
:initarg
:b
)))
(
deftest
slot-init-forms.4
(
let*
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo7
'
())))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo7
))
(
let
((
form
(
pcl::slot-init-forms
ctor
nil
)))
(
destructuring-bind
(
let
vars
declare
setf1
setf2
)
form
(
declare
(
ignore
let
vars
declare
))
(
values
setf2
(
second
setf1
)
(
first
(
third
(
third
setf1
)))
(
functionp
(
second
(
third
(
third
setf1
))))))))
(
setf
(
svref
pcl::.slots.
1
)
pcl::+slot-unbound+
)
(
svref
pcl::.slots.
0
)
funcall
t
)
(
deftest
slot-init-forms.5
(
let
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo
'
(
:a
'
(
foo
)))))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo
))
(
pcl::slot-init-forms
ctor
nil
))
(
let
()
(
declare
(
ignorable
)
(
optimize
(
safety
3
)))
(
setf
(
svref
pcl::.slots.
0
)
(
the
t
'
(
foo
)))
(
setf
(
svref
pcl::.slots.
1
)
(
the
t
'2
)))
nil
)
(
deftest
slot-init-forms.6
(
let
((
ctor
(
pcl::make-ctor
(
list
'pcl::ctor
'make-foo
)
'foo
'
(
:a
'x
))))
(
setf
(
pcl::ctor-class
ctor
)
(
find-class
'foo
))
(
pcl::slot-init-forms
ctor
nil
))
(
let
()
(
declare
(
ignorable
)
(
optimize
(
safety
3
)))
(
setf
(
svref
pcl::.slots.
0
)
(
the
t
'x
))
(
setf
(
svref
pcl::.slots.
1
)
(
the
t
'2
)))
nil
)
(
defmethod
bar1
((
x
integer
))
(
*
x
2
))
(
defmethod
bar2
((
x
integer
))
x
)
(
defmethod
bar2
:around
((
x
integer
))
x
)
(
deftest
around-or-nonstandard-primary-method-p.0
(
pcl::around-or-nonstandard-primary-method-p
(
pcl::compute-applicable-methods
#'
bar2
(
list
1
)))
t
)
(
defmethod
bar3
((
x
integer
))
x
)
(
defmethod
bar3
:after
((
x
integer
))
x
)
(
deftest
around-or-nonstandard-primary-method-p.1
(
pcl::around-or-nonstandard-primary-method-p
(
pcl::compute-applicable-methods
#'
bar3
(
list
1
)))
nil
)
(
deftest
optimizing-generator.0
(
let
((
fn
(
call-generator
#'
pcl::optimizing-generator
'make-foo
'foo
'
(
:a
0
:b
1
))))
(
second
fn
))
())
(
defun
construct
(
class-name
initargs
&rest
args
)
(
let*
((
form
(
call-generator
#'
pcl::optimizing-generator
'some-function-name
class-name
initargs
))
(
fn
(
pcl::compile-lambda
form
)))
(
apply
fn
args
)))
(
deftest
optimizing-generator.1
(
with-slots
(
a
b
)
(
construct
'foo
'
(
:a
0
:b
1
))
(
values
a
b
))
0
1
)
(
deftest
optimizing-generator.2
(
with-slots
(
a
b
)
(
construct
'foo
'
())
(
values
a
b
))
1
2
)
(
defclass
g1
()
((
a
:initform
0
)
(
b
)))
(
deftest
optimizing-generator.3
(
let
((
instance
(
construct
'g1
'
())))
(
values
(
slot-value
instance
'a
)
(
slot-boundp
instance
'b
)))
0
nil
)
;; Test for default-initargs bug.
(
defclass
g2
()
((
a
:initarg
:aa
)))
(
defmethod
initialize-instance
:after
((
f
g2
)
&key
aa
)
(
princ
aa
))
(
defclass
g3
(
g2
)
((
b
:initarg
:b
))
(
:default-initargs
:aa
5
))
(
deftest
defaulting-initargs.1
(
with-output-to-string
(
*standard-output*
)
(
make-instance
'g3
))
"5"
)
;; defclass.lisp
(
deftest
defclass-subtypep.0
(
progn
(
defclass
st0
()
())
(
defclass
st1
()
())
(
subtypep
'st1
'st0
))
nil
t
)
(
deftest
defclass-subtypep.1
(
progn
(
defclass
st1
(
st0
)
())
(
subtypep
'st1
'st0
))
t
t
)
(
deftest
defclass-subtypep.2
(
progn
(
defclass
st1
()
())
(
subtypep
'st1
'st0
))
nil
t
)
(
defvar
*instance*
nil
)
(
defvar
*update-instance-result*
nil
)
(
defclass
st2
()
((
a
:initform
0
:accessor
a
)))
(
defclass
st3
()
((
b
:initform
0
:accessor
b
)))
(
deftest
update-instance-for-redefined-class.0
(
progn
(
setq
*instance*
(
make-instance
'st3
))
t
)
t
)
(
defmethod
update-instance-for-redefined-class
:after
((
instance
st3
)
added-slots
discarded-slots
property-list
&rest
initargs
)
(
setq
*update-instance-result*
(
list
instance
added-slots
discarded-slots
property-list
initargs
)))
(
deftest
update-instance-for-redefined-class.1
(
progn
(
defclass
st3
(
st2
)
((
b
:initform
0
:accessor
b
)))
(
values
(
slot-value
*instance*
'b
)
(
eq
*instance*
(
first
*update-instance-result*
))
(
rest
*update-instance-result*
)))
0
t
((
a
)
nil
nil
nil
))
(
deftest
update-instance-for-redefined-class.2
(
progn
(
defclass
st3
()
((
b
:initform
0
:accessor
b
)))
(
values
(
slot-value
*instance*
'b
)
(
eq
*instance*
(
first
*update-instance-result*
))
(
rest
*update-instance-result*
)))
0
t
(
nil
(
a
)
(
a
0
)
nil
))
(
deftest
defclass-sxhash.0
(
let
((
i1
(
make-instance
'st2
))
(
i2
(
make-instance
'st2
)))
(
/=
(
sxhash
i1
)
(
sxhash
i2
)))
t
)
(
deftest
generic-function-sxhash.0
(
/=
(
sxhash
#'
allocate-instance
)
(
sxhash
#'
make-instance
))
t
)
(
deftest
defclass-redefinition.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
rd0
()
())
(
defclass
rd1
(
rd0
)
())
(
defclass
rd2
()
())
(
defclass
rd0
(
rd2
)
())
(
make-instance
'rd1
))
(
values
(
not
(
null
r
))
(
null
c
)))
t
t
)
;;; This failed to compile in an old version, that's why it's here.
(
deftest
defclass-inherited-class-slots.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
ics0
()
((
a
:allocation
:class
:accessor
ics0-a
)))
(
defclass
ics1
(
ics0
)
())
(
make-instance
'ics1
))
(
values
(
not
(
null
r
))
(
null
c
)))
t
t
)
(
defmacro
define-defclass-syntax-test
(
name
class-body
&rest
options
)
`
(
deftest
,
name
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dc0
()
,
class-body
,@
options
))
(
declare
(
ignore
r
))
(
typep
c
'error
))
t
))
;; CLHS: allocation should be :class or :instance
(
define-defclass-syntax-test
defclass.0
((
a
:allocation
:foo
)))
;; Reader names should be symbols.
(
define-defclass-syntax-test
defclass.1
((
a
:reader
(
setf
a
))))
;;; initarg names must be symbols.
(
define-defclass-syntax-test
defclass.2
((
a
:initarg
1
)))
;; Duplicate :default-initargs is an error.
(
define-defclass-syntax-test
defclass.3
()
(
:default-initargs
:a
1
)
(
:default-initargs
:b
2
))
;; Duplicate :metaclass.
(
define-defclass-syntax-test
defclass.4
()
(
:metaclass
pcl::funcallable-standard-class
)
(
:metaclass
1
))
;; class option that is not implemented locally -> error
(
define-defclass-syntax-test
defclass.5
()
(
:foo
t
))
(
deftest
defclass-structure-class.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dscl.0
()
(
a
b
)
(
:metaclass
pcl::structure-class
))
t
)
(
values
r
(
null
c
)))
t
t
)
(
deftest
defclass-structure-class.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
make-instance
'dscl.0
)
t
)
(
values
r
(
null
c
)))
t
t
)
;;;
;;; The change of DFR1 from forward-referenced to standard class
;;; caused problems at some point, which were fixed by passing
;;; initargs to CHANGE-CLASS in ENSURE-CLASS-USING-CLASS.
;;;
(
deftest
defclass-forward-referenced-class.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr0
(
dfr1
dfr2
)
())
(
defclass
dfr1
(
dfr3
dfr4
)
())
t
)
(
values
r
(
null
c
)))
t
t
)
(
deftest
defclass-forward-referenced-class.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr.c1
(
dfr.c2
)
())
(
defclass
dfr.c2
(
dfr.c3
)
())
(
defclass
dfr.c3
()
())
(
make-instance
'dfr.c1
)
t
)
(
values
r
(
null
c
)))
t
t
)
;;;
;;; TYPEP and SUBTYPEP used to fail with forward-referenced/unfinalized
;;; classes.
;;;
(
deftest
defclass-types.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr5
(
dfr6
)
())
(
typep
t
(
find-class
'dfr6
)))
(
values
r
(
null
c
)))
nil
t
)
(
deftest
defclass-types.2
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr7
(
dfr8
)
())
(
multiple-value-list
(
subtypep
(
find-class
'dfr7
)
(
find-class
'dfr8
))))
(
values
r
(
null
c
)))
(
t
t
)
t
)
(
deftest
defclass-types.3
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr7
(
dfr8
)
())
(
multiple-value-list
(
subtypep
(
find-class
'dfr8
)
(
find-class
'dfr7
))))
(
values
r
(
null
c
)))
(
nil
t
)
t
)
(
deftest
defclass-types.4
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr9
(
dfr10
)
())
(
defclass
dfr11
(
dfr9
dfr12
)
())
(
append
(
multiple-value-list
(
subtypep
(
find-class
'dfr9
)
(
find-class
'dfr10
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr11
)
(
find-class
'dfr10
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr11
)
(
find-class
'dfr9
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr11
)
(
find-class
'dfr12
)))))
(
values
r
(
null
c
)))
(
t
t
t
t
t
t
t
t
)
t
)
(
deftest
defclass-types.5
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr13
()
())
(
defclass
dfr14
(
dfr15
dfr13
)
())
(
defclass
dfr16
(
dfr14
dfr17
)
())
(
append
(
multiple-value-list
(
subtypep
(
find-class
'dfr16
)
(
find-class
'dfr14
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr16
)
(
find-class
'dfr17
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr16
)
(
find-class
'dfr15
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr16
)
(
find-class
'dfr13
)))))
(
values
r
(
null
c
)))
(
t
t
t
t
t
t
t
t
)
t
)
(
deftest
defclass-types.6
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dfr20
(
dfr21
)
())
(
defclass
dfr21
(
dfr22
)
())
(
append
(
multiple-value-list
(
subtypep
(
find-class
'dfr20
)
(
find-class
'dfr21
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr21
)
(
find-class
'dfr22
)))
(
multiple-value-list
(
subtypep
(
find-class
'dfr20
)
(
find-class
'dfr22
)))))
(
values
r
(
null
c
)))
(
t
t
t
t
t
t
)
t
)
;; defmethod.lisp
(
defmethod
dm0
(
x
)
x
)
(
defmethod
dm1
(
x
&rest
y
)
(
list
x
y
))
(
defmethod
dm2
(
x
&optional
y
)
(
list
x
y
))
(
defmacro
define-defmethod-test
(
name
method
qual
lambda-list
&rest
values
)
`
(
deftest
,
name
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defmethod
,
method
,@
(
when
qual
`
(
,
qual
))
,
lambda-list
#+
cmu
(
declare
(
optimize
(
ext:inhibit-warnings
3
)))
nil
))
(
values
(
typep
r
'method
)
(
typep
c
'error
)
(
length
(
pcl:generic-function-methods
#'
,
method
))))
,@
values
))
(
defmacro
define-defmethod-test-1
(
name
method
qual
lambda-list
)
`
(
define-defmethod-test
,
name
,
method
,
qual
,
lambda-list
nil
t
1
))
(
define-defmethod-test-1
defmethod.0
dm0
nil
(
x
y
))
(
define-defmethod-test-1
defmethod.1
dm0
nil
(
x
&rest
y
))
(
define-defmethod-test-1
defmethod.2
dm0
nil
(
x
&key
y
))
(
define-defmethod-test-1
defmethod.4
dm0
:before
(
x
y
))
(
define-defmethod-test-1
defmethod.5
dm0
:before
(
x
&rest
y
))
(
define-defmethod-test-1
defmethod.6
dm0
:before
(
x
&key
y
))
(
define-defmethod-test
defmethod.7
dm0
nil
(
x
)
t
nil
1
)
(
define-defmethod-test-1
defmethod.10
dm1
nil
(
x
y
))
(
define-defmethod-test-1
defmethod.11
dm1
nil
(
x
))
(
define-defmethod-test
defmethod.12
dm1
nil
(
x
&key
y
)
t
nil
1
)
(
define-defmethod-test
defmethod.13
dm1
nil
(
x
&key
y
z
)
t
nil
1
)
(
define-defmethod-test
defmethod.14
dm1
nil
(
x
&rest
y
)
t
nil
1
)
(
define-defmethod-test-1
defmethod.20
dm2
nil
(
x
))
(
define-defmethod-test-1
defmethod.21
dm2
nil
(
x
&optional
y
z
))
(
define-defmethod-test-1
defmethod.22
dm2
nil
(
x
&key
y
))
;;;
;;; A forward-referenced class used as specializer signaled an
;;; error at some point.
;;;
(
deftest
defmethod-forwared-referenced.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dm.3
()
())
(
defclass
dm.4
(
dm.forward
)
())
(
defmethod
dm.5
((
x
dm.3
))
x
)
(
defmethod
dm.5
((
x
dm.4
))
x
)
t
)
(
values
r
(
null
c
)))
t
t
)
(
deftest
defmethod-forwared-referenced.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dm.3
()
())
(
defclass
dm.4
(
dm.forward
)
())
(
defmethod
dm.5
((
x
dm.3
))
x
)
(
defmethod
dm.5
((
x
dm.4
))
x
)
(
dm.5
(
make-instance
'dm.3
))
t
)
(
values
r
(
null
c
)))
t
t
)
(
deftest
defmethod-metacircle.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
dmm.0
()
())
(
defclass
dmm.1
()
())
(
defclass
dmm.0+1
(
dmm.0
dmm.1
)
())
(
defmethod
dmm.0
((
x
dmm.0
)
(
y
dmm.1
))
1
)
(
defmethod
dmm.0
((
x
dmm.1
)
(
y
dmm.0
))
2
)
(
dmm.0
(
make-instance
'dmm.0+1
)
(
make-instance
'dmm.0+1
))
(
defmethod
dmm.0
((
x
dmm.0+1
)
(
y
dmm.0+1
))
3
)
(
dmm.0
(
make-instance
'dmm.0+1
)
(
make-instance
'dmm.0+1
)))
(
values
r
(
null
c
)))
3
t
)
(
deftest
defmethod-setf-fdefinition.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defgeneric
dsf.0
(
x
))
(
defmethod
dsf.0
((
x
integer
))
x
)
(
setf
(
fdefinition
'dsf.1
)
#'
dsf.0
)
(
defmethod
dsf.1
((
x
string
))
x
)
(
list
(
length
(
mop:generic-function-methods
#'
dsf.0
))
(
equal
(
mop:generic-function-methods
#'
dsf.1
)
(
mop:generic-function-methods
#'
dsf.0
))))
(
values
r
(
null
c
)))
(
2
t
)
t
)
(
deftest
defmethod-setf-fdefinition.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defgeneric
dsf.2
(
x
))
(
defmethod
dsf.2
((
x
integer
))
x
)
(
setf
(
fdefinition
'dsf.3
)
#'
dsf.2
)
(
defmethod
dsf.3
((
x
integer
))
x
)
(
list
(
length
(
mop:generic-function-methods
#'
dsf.2
))
(
equal
(
mop:generic-function-methods
#'
dsf.3
)
(
mop:generic-function-methods
#'
dsf.2
))))
(
values
r
(
null
c
)))
(
1
t
)
t
)
;; find-method.lisp
(
defmethod
fm0
(
x
y
)
(
list
x
y
))
(
deftest
find-method.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
find-method
#'
fm0
nil
(
list
t
)))
(
values
r
(
typep
c
'error
)))
nil
t
)
(
deftest
find-method.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
find-method
#'
fm0
nil
(
list
t
t
)))
(
values
(
typep
r
'method
)
(
typep
c
'error
)))
t
nil
)
;; inline-access.lisp
(
defun
test-walk
(
form
test-function
&optional
env
)
(
let
((
result
nil
))
(
flet
((
walk-function
(
form
context
env
)
(
declare
(
ignore
context
))
(
when
(
and
(
consp
form
)
(
eq
(
car
form
)
'test
))
(
push
(
funcall
test-function
env
)
result
))
form
))
(
walker:walk-form
form
env
#'
walk-function
)
(
nreverse
result
))))
(
defmacro
define-declaration-test
(
name
declaration
test
&key
values
)
`
(
deftest
,
name
(
test-walk
'
(
defun
dummy
()
,
declaration
(
test
))
(
lambda
(
env
)
,
test
))
,@
values
))
(
define-declaration-test
slot-declaration.0
(
declare
(
ext:slots
(
slot-boundp
xx
)))
(
pcl::slot-declaration
env
'slot-boundp
'xx
)
:values
((
t
)))
(
define-declaration-test
slot-declaration.1
(
declare
(
ext:slots
(
inline
xx
)))
(
pcl::slot-declaration
env
'inline
'xx
)
:values
((
t
)))
(
define-declaration-test
slot-declaration.2
(
declare
(
ext:slots
(
inline
(
xx
))))
(
pcl::slot-declaration
env
'inline
'xx
)
:values
((
t
)))
(
define-declaration-test
slot-declaration.3
(
declare
(
ext:slots
(
inline
(
xx
a
))))
(
pcl::slot-declaration
env
'inline
'xx
'a
)
:values
((
t
)))
(
define-declaration-test
slot-declaration.4
(
declare
(
ext:slots
(
inline
(
xx
a
))))
(
pcl::slot-declaration
env
'inline
'xx
'b
)
:values
((
nil
)))
(
define-declaration-test
slot-declaration.5
(
declare
(
ext:slots
(
inline
(
xx
a
)
yy
)))
(
pcl::slot-declaration
env
'inline
'yy
)
:values
((
t
)))
(
define-declaration-test
slot-declaration.6
(
declare
(
ext:slots
(
inline
(
xx
a
)
(
yy
a
))))
(
pcl::slot-declaration
env
'inline
'yy
'a
)
:values
((
t
)))
(
define-declaration-test
slot-declaration.7
(
declare
(
ext:slots
(
inline
(
xx
a
)
(
yy
a
))))
(
pcl::slot-declaration
env
'inline
'yy
'b
)
:values
((
nil
)))
(
deftest
global-slot-declaration.0
(
progn
(
proclaim
'
(
ext:slots
(
slot-boundp
gsd
)))
(
not
(
null
(
pcl::slot-declaration
nil
'slot-boundp
'gsd
))))
t
)
(
deftest
global-slot-declaration.1
(
progn
(
proclaim
'
(
ext:slots
(
inline
(
gsd
gsd-a
))))
(
not
(
null
(
pcl::slot-declaration
nil
'inline
'gsd
'gsd-a
))))
t
)
(
deftest
auto-compile-declaration.0
(
progn
(
proclaim
'
(
ext:auto-compile
acd
))
(
pcl::auto-compile-p
'acd
nil
nil
))
t
)
(
deftest
auto-compile-declaration.1
(
progn
(
proclaim
'
(
ext:auto-compile
acd
))
(
pcl::auto-compile-p
'acd
'
(
:around
)
'
(
t
t
)))
t
)
(
deftest
auto-compile-declaration.2
(
progn
(
proclaim
'
(
ext:not-auto-compile
acd
))
(
proclaim
'
(
ext:auto-compile
(
acd
:around
(
t
t
))))
(
values
(
pcl::auto-compile-p
'acd
nil
nil
)
(
pcl::auto-compile-p
'acd
nil
'
(
t
t
))
(
pcl::auto-compile-p
'acd
'
(
:around
)
'
(
t
t
))))
nil
nil
t
)
(
deftest
auto-compile-declaration.3
(
progn
(
proclaim
'
(
ext:auto-compile
acd
))
(
proclaim
'
(
ext:not-auto-compile
(
acd
:around
(
t
t
))))
(
values
(
pcl::auto-compile-p
'acd
nil
nil
)
(
pcl::auto-compile-p
'acd
nil
'
(
t
t
))
(
pcl::auto-compile-p
'acd
'
(
:around
)
'
(
t
t
))))
t
t
nil
)
(
deftest
auto-compile-declaration.4
(
progn
(
proclaim
'
(
ext:auto-compile
))
(
proclaim
'
(
ext:not-auto-compile
acd
))
(
values
(
pcl::auto-compile-p
'foo
nil
nil
)
(
pcl::auto-compile-p
'acd
nil
'
(
t
t
))
(
pcl::auto-compile-p
'acd
'
(
:around
)
'
(
t
t
))))
t
nil
nil
)
(
deftest
auto-compile-declaration.5
(
progn
(
proclaim
'
(
ext:auto-compile
(
setf
acd
)))
(
pcl::auto-compile-p
'
(
setf
acd
)
'
(
:around
)
'
(
t
t
)))
t
)
(
declaim
(
ext:slots
(
inline
sacc.0
)))
(
defclass
sacc.0
()
((
a
:initform
0
:initarg
:a
:accessor
sacc.0-a
)))
(
defclass
sacc.1
(
sacc.0
)
((
b
:initform
0
:initarg
:b
:accessor
sacc.1-b
)
(
a
:initform
0
:initarg
:a
:accessor
sacc.0-a
)))
(
defmethod
sacc.0.0
((
x
sacc.0
))
(
slot-value
x
'a
))
(
defmethod
sacc.0.1
((
x
sacc.0
))
(
sacc.0-a
x
))
(
defmethod
sacc.0.2
((
x
sacc.0
)
nv
)
(
setf
(
slot-value
x
'a
)
nv
))
(
defmethod
sacc.0.3
((
x
sacc.0
)
nv
)
(
setf
(
sacc.0-a
x
)
nv
))
(
defun
method-using-inline-access-p
(
class-name
method-name
qualifiers
specializers
)
(
let
((
method
(
find-method
(
fdefinition
method-name
)
qualifiers
specializers
)))
(
car
(
member
class-name
(
pcl::plist-value
method
'pcl::inline-access
)
:test
#'
eq
))))
(
deftest
inline-access-p.0
(
and
(
method-using-inline-access-p
'sacc.0
'sacc.0.0
nil
'
(
sacc.0
))
(
method-using-inline-access-p
'sacc.0
'sacc.0.1
nil
'
(
sacc.0
))
(
method-using-inline-access-p
'sacc.0
'sacc.0.2
nil
'
(
sacc.0
t
))
(
method-using-inline-access-p
'sacc.0
'sacc.0.3
nil
'
(
sacc.0
t
)))
sacc.0
)
(
deftest
inline-access-p.1
(
let
((
methods
(
pcl::methods-using-inline-slot-access
(
pcl::find-class
'sacc.0
))))
(
length
methods
))
4
)
(
deftest
inline-access.0
(
sacc.0.0
(
make-instance
'sacc.0
))
0
)
(
deftest
inline-access.1
(
let
((
instance
(
make-instance
'sacc.0
:a
11
)))
(
values
(
sacc.0.0
instance
)
(
sacc.0.1
instance
)))
11
11
)
(
deftest
inline-access.2
(
let
((
instance
(
make-instance
'sacc.0
:a
11
)))
(
sacc.0.2
instance
10
)
(
slot-value
instance
'a
))
10
)
(
deftest
inline-access.3
(
let
((
instance
(
make-instance
'sacc.0
:a
11
)))
(
sacc.0.3
instance
10
)
(
slot-value
instance
'a
))
10
)
(
defmacro
define-warning-test
(
name
(
value
)
&body
body
)
`
(
deftest
,
name
(
let
(
warning
)
(
flet
((
note-warning
(
c
)
(
declare
(
ignore
c
))
(
setq
warning
t
)
(
muffle-warning
)))
(
handler-bind
((
warning
#'
note-warning
))
,@
body
)
warning
))
,
value
))
(
define-warning-test
warn.0
(
t
)
(
warn
"Test the test"
))
(
define-warning-test
warn.1
(
nil
)
nil
)
(
define-warning-test
inline-warn.0
(
nil
)
(
defclass
sacc.0
()
((
a
:initform
0
:initarg
:a
:accessor
sacc.0-a
))))
(
define-warning-test
inline-warn.1
(
t
)
(
defclass
sacc.0
()
((
a
:initform
0
:initarg
:a
:accessor
sacc.0-a
)
(
b
:initform
0
))))
(
define-warning-test
inline-warn.2
(
t
)
(
progn
(
defmethod
inline-warn.2.method
((
x
sacc.1
))
(
declare
(
pcl::slots
(
inline
sacc.1
)))
(
slot-value
x
'b
))
(
defclass
sacc.0
()
((
a
:initform
0
:initarg
:a
:accessor
sacc.0-a
)))))
;; make-instance.lisp
;;; *********************
;;; MAKE-INSTANCE ******
;;; *********************
;;; Test forms in DEFTEST are not compiled, that is, a compiler
;;; macro won't be used in them. Also, we want tests using
;;; both the optimized constructor functions, and the default.
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
defmacro
define-mi-test
(
name
form
&key
values
opt-values
)
(
let
((
optimized-name
(
let
((
*print-case*
:upcase
)
(
*print-pretty*
nil
)
(
*print-gensym*
t
))
(
intern
(
format
nil
"~S.OPT"
name
))))
(
optimized-values
(
or
opt-values
values
)))
`
(
progn
(
defun
,
name
()
(
macrolet
((
mi
(
&rest
args
)
`
(
funcall
#'
make-instance
,@
args
)))
,
form
))
(
defun
,
optimized-name
()
(
macrolet
((
mi
(
&rest
args
)
`
(
make-instance
,@
args
)))
,
form
))
(
deftest
,
name
(
,
name
)
,@
values
)
(
deftest
,
optimized-name
(
,
optimized-name
)
,@
optimized-values
))))
)
(
defclass
m1
()
((
a
:initarg
:a
:initarg
:both
:initform
1
)
(
b
:initarg
:b
:initarg
:both
:initform
2
)))
(
define-mi-test
make-instance.0
(
with-slots
(
a
b
)
(
mi
'm1
)
(
values
a
b
))
:values
(
1
2
))
(
define-mi-test
make-instance.1
(
with-slots
(
a
b
)
(
mi
'm1
:a
3
)
(
values
a
b
))
:values
(
3
2
))
(
define-mi-test
make-instance.2
(
with-slots
(
a
b
)
(
mi
'm1
:b
3
)
(
values
a
b
))
:values
(
1
3
))
(
define-mi-test
make-instance.3
(
with-slots
(
a
b
)
(
mi
'm1
:b
3
:a
4
)
(
values
a
b
))
:values
(
4
3
))
(
define-mi-test
make-instance.4
(
with-slots
(
a
b
)
(
mi
'm1
:both
(
list
nil
))
(
eq
a
b
))
:values
(
t
))
(
defclass
m2
(
m1
)
((
a
:initarg
:a
:initform
3
)))
;;; Overriding slot in subclass -> new initform should be used.
(
define-mi-test
make-instance.5
(
with-slots
(
a
b
)
(
mi
'm2
)
(
values
a
b
))
:values
(
3
2
))
;;; :BOTH should be inherited by slot A.
(
define-mi-test
make-instance.6
(
with-slots
(
a
b
)
(
mi
'm2
:both
11
)
(
values
a
b
))
:values
(
11
11
))
(
defclass
m3
(
m2
)
((
a
:allocation
:class
:initform
nil
)))
;;; Class slot should not be overwritten when there's no initarg for it.
;;; Note that slot A overrides an instance slot A in M2 which itself
;;; overrides an instance slot in M1.
(
define-mi-test
make-instance.7
(
progn
(
setf
(
slot-value
(
pcl:class-prototype
(
pcl:find-class
'm3
))
'a
)
1
)
(
with-slots
(
a
b
)
(
mi
'm3
)
(
values
a
b
)))
:values
(
1
2
))
;;; Class slot should be written when there is an initarg for it.
(
define-mi-test
make-instance.8
(
with-slots
(
a
)
(
mi
'm3
:a
11
)
a
)
:values
(
11
))
;;; Class slot should be written when there is an initarg for it.
(
define-mi-test
make-instance.9
(
with-slots
(
a
b
)
(
mi
'm3
:both
12
)
(
values
a
b
))
:values
(
12
12
))
(
define-mi-test
make-instance.10
(
with-slots
(
a
b
)
(
mi
'm3
:both
13
)
(
values
a
b
))
:values
(
13
13
))
;;; Invalid initialization arguments
(
define-mi-test
make-instance.11
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mi
'm3
:hansi
t
))
(
values
r
(
typep
c
'condition
)))
:values
(
nil
t
))
(
define-mi-test
make-instance.12
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mi
'm3
:hansi
t
:allow-other-keys
t
))
(
values
(
slot-value
r
'b
)
(
typep
c
'condition
)))
:values
(
2
nil
))
;;; Default initargs
(
defclass
m5
(
m1
)
()
(
:default-initargs
:a
'a
:b
'b
))
(
define-mi-test
make-instance.13
(
with-slots
(
a
b
)
(
mi
'm5
)
(
values
a
b
))
:values
(
a
b
))
(
defclass
m6
(
m5
)
()
(
:default-initargs
:a
'c
))
(
define-mi-test
make-instance.14
(
with-slots
(
a
b
)
(
mi
'm6
)
(
values
a
b
))
:values
(
c
b
))
(
defclass
m7
(
m6
)
((
a
:allocation
:class
:initform
nil
)))
(
define-mi-test
make-instance.15
(
with-slots
(
a
b
)
(
mi
'm7
)
(
values
a
b
))
:values
(
c
b
))
;;; Lexical environment.
(
let
((
x
0
))
(
defclass
m8
()
((
a
:initform
(
incf
x
))))
(
defun
reset-counter
()
(
setq
x
0
)))
(
define-mi-test
make-instance.16
(
progn
(
reset-counter
)
(
loop
for
i
below
5
collect
(
slot-value
(
mi
'm8
)
'a
)))
:values
((
1
2
3
4
5
)))
(
defclass
m9
()
((
a
:initarg
:a
)
(
b
:initarg
:b
)
(
c
:initarg
:c
)
(
d
:initarg
:d
)))
(
define-mi-test
make-instance.17
(
let*
((
x
'x
)
(
instance
(
mi
'm9
:a
()
:b
x
:c
'
(
baz
bar
foo
)
:d
(
lambda
()
()))))
(
with-slots
(
a
b
c
)
instance
(
values
a
b
c
)))
:values
(
nil
x
(
baz
bar
foo
)))
;; After and before methods.
(
defclass
m10
()
((
a
:initform
0
:initarg
:a
)
(
b
:initarg
:b
)
(
c
:initform
2
:initarg
:c
))
(
:default-initargs
:c
1
))
(
defvar
*result*
())
(
defmethod
initialize-instance
:before
((
x
m10
)
&rest
args
)
(
declare
(
ignore
args
))
(
push
(
list
'm10
:before
(
slot-boundp
x
'a
)
(
slot-boundp
x
'b
)
(
slot-boundp
x
'c
))
*result*
))
(
define-mi-test
make-instance.18
(
progn
(
setq
*result*
())
(
with-slots
(
a
b
c
)
(
mi
'm10
:b
42
)
(
values
*result*
a
b
c
)))
:values
(((
m10
:before
nil
nil
nil
))
0
42
1
))
(
defclass
m11
(
m10
)
()
(
:default-initargs
:c
11
))
(
defmethod
initialize-instance
:before
((
x
m11
)
&rest
args
)
(
declare
(
ignore
args
))
(
push
(
list
'm11
:before
(
slot-boundp
x
'a
)
(
slot-boundp
x
'b
)
(
slot-boundp
x
'c
))
*result*
))
(
defmethod
initialize-instance
:after
((
x
m11
)
&rest
args
)
(
declare
(
ignore
args
))
(
push
(
list
'm11
:after
(
slot-boundp
x
'a
)
(
slot-boundp
x
'b
)
(
slot-boundp
x
'c
))
*result*
))
(
define-mi-test
make-instance.19
(
progn
(
setq
*result*
())
(
with-slots
(
a
b
c
)
(
mi
'm11
:b
42
)
(
values
*result*
a
b
c
)))
:values
(((
m11
:after
t
t
t
)
(
m10
:before
nil
nil
nil
)
(
m11
:before
nil
nil
nil
))
0
42
11
))
(
defclass
m12
(
m10
)
()
(
:default-initargs
:c
13
))
(
defmethod
initialize-instance
:before
((
x
m12
)
&rest
args
)
(
declare
(
ignore
args
))
(
setf
(
slot-value
x
'a
)
77
))
(
define-mi-test
make-instance.20
(
progn
(
setq
*result*
())
(
with-slots
(
a
b
c
)
(
mi
'm12
:b
42
)
(
values
*result*
a
b
c
)))
:values
(((
m10
:before
t
nil
nil
))
77
42
13
))
(
define-mi-test
make-instance.21
(
progn
(
setq
*result*
())
(
with-slots
(
a
b
c
)
(
mi
'm12
:b
41
:c
67
)
(
values
*result*
a
b
c
)))
:values
(((
m10
:before
t
nil
nil
))
77
41
67
))
;;; :ALLOW-OTHER-KEYS
(
define-mi-test
make-instance.22
(
let
((
obj
(
ignore-errors
(
mi
'm12
:b
41
:allow-other-keys
t
))))
(
when
obj
(
with-slots
(
a
b
c
)
obj
(
values
a
b
c
))))
:values
(
77
41
13
))
(
define-mi-test
make-instance.23
(
let
((
obj
(
ignore-errors
(
mi
'm12
:b
41
:x
11
:allow-other-keys
t
))))
(
when
obj
(
with-slots
(
a
b
c
)
obj
(
values
a
b
c
))))
:values
(
77
41
13
))
(
define-mi-test
make-instance.24
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mi
'm12
:b
41
:x
11
))
(
values
r
(
typep
c
'condition
)))
:values
(
nil
t
))
(
define-mi-test
make-instance.25
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mi
'm12
:b
41
:x
11
:allow-other-keys
nil
))
(
values
r
(
typep
c
'condition
)))
:values
(
nil
t
))
;; Create a constructor, than rename the package of the class it was
;; defined for.
(
defpackage
"%CTOR"
(
:use
"COMMON-LISP"
))
(
in-package
"%CTOR"
)
(
defclass
p1
()
((
a
:initform
0
)))
(
defun
f1
()
(
make-instance
'p1
))
(
in-package
"PCL-TESTS"
)
(
define-mi-test
make-instance.26
(
progn
(
rename-package
"%CTOR"
"%CTOR2"
)
(
let*
((
f
(
find-symbol
"F1"
"%CTOR2"
))
(
a
(
find-symbol
"A"
"%CTOR2"
))
(
i
(
funcall
f
)))
(
prog1
(
slot-value
i
a
)
(
rename-package
"%CTOR2"
"%CTOR"
))))
:values
(
0
))
(
defclass
stru.0
()
((
a
:initarg
:a
:accessor
a-accessor
)
(
b
:initform
2
:reader
b-reader
))
(
:metaclass
structure-class
))
(
defclass
stru.1
(
stru.0
)
((
c
:initarg
:c
:writer
c-writer
:accessor
c-accessor
))
(
:metaclass
structure-class
))
(
define-mi-test
make-instance.27
(
with-slots
(
a
b
)
(
mi
'stru.0
)
(
values
a
b
))
:values
(
nil
2
))
(
define-mi-test
make-instance.28
(
with-slots
(
a
b
)
(
mi
'stru.0
:a
1
)
(
values
a
b
))
:values
(
1
2
))
(
define-mi-test
make-instance.29
(
with-slots
(
a
b
c
)
(
mi
'stru.1
)
(
values
a
b
c
))
:values
(
nil
2
nil
))
(
define-mi-test
make-instance.30
(
with-slots
(
a
b
c
)
(
mi
'stru.1
:a
1
:c
3
)
(
values
a
b
c
))
:values
(
1
2
3
))
(
deftest
make-instance.31
(
let
((
*m30*
nil
))
(
declare
(
special
*m30*
))
(
defclass
m30
()
())
(
defclass
m31
(
m30
)
())
(
defun
f
()
(
make-instance
'm31
))
(
compile
'f
)
(
f
)
(
defmethod
initialize-instance
:before
((
x
m30
)
&rest
args
)
(
declare
(
ignore
args
))
(
declare
(
special
*m30*
))
(
setq
*m30*
t
))
(
f
)
*m30*
)
t
)
(
defclass
mi13
()
((
s1
:initarg
:s1a
:initarg
:s1b
:reader
s1
)
(
s2
:initarg
:s2
:reader
s2
)))
(
define-mi-test
make-instance.32
(
with-slots
(
s1
s2
)
(
make-instance
'mi13
:s2
'a
:s1a
'b
:s2
'x
:s1a
'y
:s1b
'z
)
(
values
s1
s2
))
:values
(
b
a
))
;; (setf find-class), class redefinitions
;; method-combination.lisp
;;; ********************************
;;; Method Group Specifiers ********
;;; ********************************
(
define-method-combination
mgs0
(
x
)
((
primary
()
:required
t
))
(
progn
x
`
(
call-method
,
(
first
primary
))))
;;; This should simply not signal an error as it did in 18d.
(
deftest
method-group-specifiers.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defgeneric
mgs0
(
obj
)
(
:method-combination
mgs0
1
))
(
defmethod
mgs0
(
obj
)
obj
)
(
mgs0
1
))
(
values
r
c
))
1
nil
)
;;; **************************
;;; :generic-function *******
;;; **************************
;;; *******************
;;; :arguments *******
;;; *******************
(
defvar
*result*
nil
)
(
defvar
*mca0-value*
(
define-method-combination
mca0
()
((
methods
*
))
(
:arguments
x
y
&optional
opt
)
(
:generic-function
gf
)
`
(
progn
(
setq
*result*
(
list
(
pcl:generic-function-name
,
gf
)
,
x
,
y
,
opt
))
(
call-method
,
(
first
methods
)))))
(
defgeneric
mca0
(
a
)
(
:method-combination
mca0
)
(
:method
(
a
)
a
))
(
defgeneric
mca1
(
a
b
)
(
:method-combination
mca0
)
(
:method
(
a
b
)
(
list
a
b
)))
(
defgeneric
mca2
(
a
&optional
b
)
(
:method-combination
mca0
)
(
:method
(
a
&optional
b
)
(
list
a
b
)))
(
defgeneric
mca3
(
&optional
b
)
(
:method-combination
mca0
)
(
:method
(
&optional
b
)
b
))
(
deftest
method-combination.0
*mca0-value*
mca0
)
(
deftest
method-combination-arguments.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca0
1
)
*result*
)
(
values
r
(
null
c
)))
(
mca0
1
nil
nil
)
t
)
(
deftest
method-combination-arguments.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca1
1
2
)
*result*
)
(
values
r
(
null
c
)))
(
mca1
1
2
nil
)
t
)
(
deftest
method-combination-arguments.2
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca2
1
)
*result*
)
(
values
r
(
null
c
)))
(
mca2
1
nil
nil
)
t
)
(
deftest
method-combination-arguments.3
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca2
1
2
)
*result*
)
(
values
r
(
null
c
)))
(
mca2
1
nil
2
)
t
)
(
deftest
method-combination-arguments.4
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca3
)
*result*
)
(
values
r
(
null
c
)))
(
mca3
nil
nil
nil
)
t
)
(
deftest
method-combination-arguments.5
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca3
1
)
*result*
)
(
values
r
(
null
c
)))
(
mca3
nil
nil
1
)
t
)
(
define-method-combination
mca1
()
((
methods
*
))
(
:arguments
x
y
&rest
r
)
(
:generic-function
gf
)
`
(
progn
(
setq
*result*
(
list
(
pcl:generic-function-name
,
gf
)
,
x
,
y
,
r
))
(
call-method
,
(
first
methods
))))
(
defgeneric
mca1.0
(
&rest
b
)
(
:method-combination
mca1
)
(
:method
(
&rest
b
)
b
))
(
deftest
method-combination-arguments.6
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca1.0
)
*result*
)
(
values
r
(
null
c
)))
(
mca1.0
nil
nil
nil
)
t
)
(
deftest
method-combination-arguments.7
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca1.0
1
)
*result*
)
(
values
r
(
null
c
)))
(
mca1.0
nil
nil
(
1
))
t
)
(
define-method-combination
mca2
()
((
methods
*
))
(
:arguments
&key
a
b
)
(
:generic-function
gf
)
`
(
progn
(
setq
*result*
(
list
(
pcl:generic-function-name
,
gf
)
,
a
,
b
))
(
call-method
,
(
first
methods
))))
(
defgeneric
mca2.0
(
&key
a
b
)
(
:method-combination
mca2
)
(
:method
(
&key
(
a
0
)
(
b
1
))
(
list
a
b
)))
(
deftest
method-combination-arguments.8
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca2.0
)
*result*
)
(
values
r
(
null
c
)))
(
mca2.0
nil
nil
)
t
)
(
deftest
method-combination-arguments.9
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca2.0
:a
1
)
*result*
)
(
values
r
(
null
c
)))
(
mca2.0
1
nil
)
t
)
(
deftest
method-combination-arguments.10
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca2.0
:b
1
)
*result*
)
(
values
r
(
null
c
)))
(
mca2.0
nil
1
)
t
)
(
deftest
method-combination-arguments.11
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca2.0
:b
1
:a
0
)
*result*
)
(
values
r
(
null
c
)))
(
mca2.0
0
1
)
t
)
(
define-method-combination
mca3
()
((
methods
*
))
(
:arguments
&whole
w
x
&key
k
)
(
:generic-function
gf
)
`
(
progn
(
setq
*result*
(
list
(
pcl:generic-function-name
,
gf
)
,
w
,
x
,
k
))
(
call-method
,
(
first
methods
))))
(
defgeneric
mca3.0
(
x
&key
k
)
(
:method-combination
mca3
)
(
:method
(
x
&key
k
)
(
list
x
k
)))
(
deftest
method-combination-arguments.12
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca3.0
1
)
*result*
)
(
values
r
(
null
c
)))
(
mca3.0
(
1
)
1
nil
)
t
)
(
deftest
method-combination-arguments.13
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
mca3.0
1
:k
2
)
*result*
)
(
values
r
(
null
c
)))
(
mca3.0
(
1
:k
2
)
1
2
)
t
)
;; methods.lisp
;;; Old PCL has a bug wrt rebinding a parameter around
;;; CALL-NEXT-METHOD.
(
deftest
methods.0
(
progn
(
defclass
mt0
()
())
(
defmethod
mt0
((
m
mt0
)
x
)
x
)
(
defmethod
mt0
:around
((
m
mt0
)
x
)
(
let
((
x
(
1+
x
)))
#+
cmu
(
declare
(
optimize
(
ext:inhibit-warnings
3
)))
(
call-next-method
)))
(
mt0
(
make-instance
'mt0
)
42
))
42
)
;; pv.lisp
;;;**************************
;;; With Optimization ******
;;; *************************
#+
gerds-pcl
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
setq
pcl::*optimize-gf-calls-p*
t
))
(
defclass
pv0
()
((
a
:accessor
pv0-a
:initform
0
)))
(
defmethod
pv0.0
((
x
pv0
))
1
)
(
defmethod
pv0.1
((
x
pv0
)
&rest
r
)
(
car
r
))
(
defmethod
pv0.2
((
x
pv0
)
&key
k
)
k
)
(
defmethod
pv0.3
((
x
pv0
)
&optional
o
)
o
)
(
defmethod
pv0.4
((
x
pv0
)
(
y
pv0
))
1
)
(
defmethod
call-pv0
((
x
pv0
))
(
list
(
pv0.0
x
)
(
pv0.1
x
2
)
(
pv0.2
x
:k
3
)
(
pv0.2
x
)
(
pv0.3
x
1
)
(
pv0.3
x
)
(
pv0.4
x
x
)))
(
deftest
pv-gf-call-optimized.0
(
ignore-errors
(
call-pv0
(
make-instance
'pv0
)))
(
1
2
3
nil
1
nil
1
))
(
defclass
pv0.1
(
pv0
)
())
(
defmethod
pv0.0
((
x
pv0.1
))
(
call-next-method
))
(
defmethod
pv0.1
((
x
pv0.1
)
&rest
r
)
(
declare
(
ignorable
r
))
(
call-next-method
))
(
defmethod
pv0.2
((
x
pv0.1
)
&key
k
)
(
declare
(
ignorable
k
))
(
call-next-method
))
(
defmethod
pv0.3
((
x
pv0.1
)
&optional
o
)
(
declare
(
ignorable
o
))
(
call-next-method
))
(
defmethod
pv0.4
((
x
pv0.1
)
(
y
pv0.1
))
(
call-next-method
))
(
defmethod
call-pv0
((
x
pv0.1
))
(
call-next-method
))
(
deftest
pv-gf-call-optimized.1
(
ignore-errors
(
call-pv0
(
make-instance
'pv0.1
)))
(
1
2
3
nil
1
nil
1
))
(
deftest
pv-gf-call-optimized.2
(
ignore-errors
(
call-pv0
(
make-instance
'pv0
)))
(
1
2
3
nil
1
nil
1
))
;;;*****************************
;;; Without Optimization ******
;;; ****************************
#+
gerds-pcl
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
setq
pcl::*optimize-gf-calls-p*
nil
))
(
defclass
pv1
()
((
a
:accessor
pv1-a
:initform
0
)))
(
defmethod
pv1.0
((
x
pv1
))
1
)
(
defmethod
pv1.1
((
x
pv1
)
&rest
r
)
(
car
r
))
(
defmethod
pv1.2
((
x
pv1
)
&key
k
)
k
)
(
defmethod
pv1.3
((
x
pv1
)
&optional
o
)
o
)
(
defmethod
call-pv1
((
x
pv1
))
(
list
(
pv1.0
x
)
(
pv1.1
x
2
)
(
pv1.2
x
:k
3
)
(
pv1.2
x
)
(
pv1.3
x
1
)
(
pv1.3
x
)))
(
deftest
pv-gf-call.1
(
call-pv1
(
make-instance
'pv1
))
(
1
2
3
nil
1
nil
))
;; reinitialize-instance.lisp
(
deftest
reinitialize-instance.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
ri0
()
((
a
:initarg
:a
)))
(
reinitialize-instance
(
make-instance
'ri0
)
:a
1
))
(
values
(
null
r
)
(
typep
c
'error
)))
nil
nil
)
(
deftest
reinitialize-instance.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
ri1
()
())
(
reinitialize-instance
(
make-instance
'ri1
)
:a
1
))
(
values
(
null
r
)
(
typep
c
'error
)))
t
t
)
(
deftest
reinitialize-instance.2
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
ri2
()
())
(
defmethod
shared-initialize
((
x
ri2
)
slots
&rest
initargs
&key
a
)
(
declare
(
ignore
slots
initargs
a
)))
(
reinitialize-instance
(
make-instance
'ri2
)
:a
1
))
(
values
(
null
r
)
(
typep
c
'error
)))
nil
nil
)
(
deftest
reinitialize-instance.3
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
ri3
()
())
(
defmethod
reinitialize-instance
:after
((
x
ri3
)
&rest
initargs
&key
a
)
(
declare
(
ignore
initargs
a
)))
(
reinitialize-instance
(
make-instance
'ri3
)
:a
1
))
(
values
(
null
r
)
(
typep
c
'error
)))
nil
nil
)
(
deftest
reinitialize-instance.4
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
ri4
()
())
(
defmethod
reinitialize-instance
:after
((
x
ri4
)
&rest
initargs
&key
a
&allow-other-keys
)
(
declare
(
ignore
initargs
a
)))
(
reinitialize-instance
(
make-instance
'ri4
)
:a
1
:b
2
))
(
values
(
null
r
)
(
typep
c
'error
)))
nil
nil
)
(
deftest
reinitialize-instance.5
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
defclass
ri5
()
())
(
reinitialize-instance
(
make-instance
'ri4
)
:a
1
:b
2
:allow-other-keys
t
))
(
values
(
null
r
)
(
typep
c
'error
)))
nil
nil
)
;; slot-accessors.lisp
(
defclass
sa0
()
((
a
:accessor
a-of
:initarg
:a
)))
(
deftest
slot-accessor.0
(
let
((
instance
(
make-instance
'sa0
:a
0
)))
(
a-of
instance
))
0
)
(
deftest
slot-accessor.1
(
let
((
instance
(
make-instance
'sa0
)))
(
setf
(
a-of
instance
)
1
)
(
a-of
instance
))
1
)
(
defmethod
sa0.0
((
x
sa0
))
(
a-of
x
))
(
deftest
slot-accessor.2
(
let
((
instance
(
make-instance
'sa0
)))
(
setf
(
a-of
instance
)
2
)
(
sa0.0
instance
))
2
)
;;; Redefining the class should update the PV table cache of
;;; method SA0.0 so that is reads the right slot.
(
deftest
slot-accessor.3
(
progn
(
defclass
sa0
()
((
c
:accessor
c-of
)
(
a
:accessor
a-of
:initarg
:a
)
(
b
:accessor
b-of
)))
(
sa0.0
(
make-instance
'sa0
:a
42
)))
42
)
(
defclass
sa1
(
sa0
)
((
b
:accessor
a-of
:initarg
:b
)))
(
deftest
slot-accessor.4
(
let
((
instance
(
make-instance
'sa1
:b
0
)))
(
sa0.0
instance
))
0
)
(
defclass
sa2
(
sa0
)
())
(
defmethod
(
setf
a-of
)
(
new-value
(
obj
sa2
))
(
setf
(
slot-value
obj
'a
)
(
*
2
new-value
)))
(
defmethod
sa2.0
((
obj
sa2
))
(
setf
(
a-of
obj
)
42
))
(
deftest
slot-accessor.5
(
let
((
instance
(
make-instance
'sa2
)))
(
sa2.0
instance
))
84
)
(
defclass
sa3
()
())
(
defmethod
(
setf
foo-of
)
(
n
(
obj
sa3
))
n
)
(
defmethod
sa3.0
((
obj
sa3
))
(
setf
(
foo-of
obj
)
11
))
(
deftest
slot-accessor.6
(
let
((
instance
(
make-instance
'sa3
)))
(
sa3.0
instance
))
11
)
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
defclass
sa4
()
((
a
:initform
0
:accessor
sa4-a
))))
(
defmethod
sa4.0
((
x
sa4
))
(
sa4-a
x
))
(
deftest
slot-accessor.7
(
sa4.0
(
make-instance
'sa4
))
0
)
(
deftest
slot-accessor.8
(
progn
(
defun
sa4-a
(
x
)
(
declare
(
ignore
x
))
11
)
(
prog1
(
sa4.0
(
make-instance
'sa4
))
(
fmakunbound
'sa4-a
)))
11
)
;; slot-boundp.lisp
(
defclass
sbp0
()
((
a
:initarg
:a
:initform
0
)
(
b
:initarg
:b
)
(
c
:allocation
:class
)))
(
defmethod
sbp0.0
((
x
sbp0
)
slot
)
(
null
(
slot-boundp
x
slot
)))
(
deftest
slot-boundp.0
(
null
(
slot-boundp
(
make-instance
'sbp0
)
'a
))
nil
)
(
define-compiled-test
slot-boundp.1
(
null
(
slot-boundp
(
make-instance
'sbp0
)
'a
))
nil
)
(
deftest
slot-boundp.2
(
null
(
slot-boundp
(
make-instance
'sbp0
)
'b
))
t
)
(
define-compiled-test
slot-boundp.3
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
slot-boundp
(
make-instance
'sbp0
)
'b
))
(
values
(
null
r
)
c
))
t
nil
)
(
deftest
slot-boundp.4
(
null
(
slot-boundp
(
make-instance
'sbp0
)
'c
))
t
)
(
define-compiled-test
slot-boundp.5
(
null
(
slot-boundp
(
make-instance
'sbp0
)
'c
))
t
)
(
deftest
slot-boundp.6
(
sbp0.0
(
make-instance
'sbp0
)
'b
)
t
)
(
deftest
slot-boundp.7
(
sbp0.0
(
make-instance
'sbp0
:a
2
)
'a
)
nil
)
;; slot-missing.lisp
;;; in method (pv table optimization)
;;; in compiled defun
;;; uncompiled.
(
defmacro
define-sm-test
(
name
(
instance
class
)
access
&rest
values
)
(
let*
((
*print-case*
:upcase
)
(
*print-pretty*
nil
)
(
*print-gensym*
t
)
(
method-name
(
intern
(
format
nil
"~S.METHOD"
name
)))
(
method-test
(
intern
(
format
nil
"~S.METHOD-TEST"
name
)))
(
compiled-test
(
intern
(
format
nil
"~S.COMPILED"
name
))))
`
(
progn
(
defmethod
,
method-name
((
,
instance
,
class
))
,
access
)
(
deftest
,
name
(
multiple-value-bind
(
r
c
)
(
let
((
,
instance
(
make-instance
',class
)))
(
ignore-errors
,
access
))
(
values
r
(
typep
c
'condition
)))
,@
values
)
(
deftest
,
method-test
(
multiple-value-bind
(
r
c
)
(
let
((
,
instance
(
make-instance
',class
)))
(
ignore-errors
(
,
method-name
,
instance
)))
(
values
r
(
typep
c
'condition
)))
,@
values
)
(
define-compiled-test
,
compiled-test
(
multiple-value-bind
(
r
c
)
(
let
((
,
instance
(
make-instance
',class
)))
(
ignore-errors
,
access
))
(
values
r
(
typep
c
'condition
)))
,@
values
))))
(
defclass
sm0
()
())
(
define-sm-test
slot-missing.0
(
instance
sm0
)
(
slot-value
instance
'a
)
nil
t
)
(
define-sm-test
slot-missing.1
(
instance
sm0
)
(
setf
(
slot-value
instance
'a
)
1
)
nil
t
)
(
define-sm-test
slot-missing.2
(
instance
sm0
)
(
slot-boundp
instance
'a
)
nil
t
)
(
defclass
sm1
()
())
(
defvar
*sm-result*
nil
)
(
defmethod
slot-missing
(
class
(
obj
sm1
)
slot-name
operation
&optional
new-value
)
(
setq
*sm-result*
(
list
slot-name
operation
new-value
)))
(
define-sm-test
slot-missing.3
(
instance
sm1
)
(
progn
(
slot-value
instance
'a
)
*sm-result*
)
(
a
slot-value
nil
)
nil
)
(
define-sm-test
slot-missing.4
(
instance
sm1
)
(
progn
(
setf
(
slot-value
instance
'a
)
1
)
*sm-result*
)
(
a
setf
1
)
nil
)
(
define-sm-test
slot-missing.5
(
instance
sm1
)
(
progn
(
slot-boundp
instance
'a
)
*sm-result*
)
(
a
slot-boundp
nil
)
nil
)
;; slot-type.lisp
#+
gerds-pcl
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
setq
pcl::*use-slot-types-p*
t
))
;;; Check that we check slot types, at least sometimes.
(
defclass
stype
()
((
a
:type
fixnum
:initform
0
:initarg
:a
)))
(
defmethod
stype.0
((
obj
stype
))
(
slot-value
obj
'a
))
(
defmethod
stype.1
((
obj
stype
)
value
)
(
setf
(
slot-value
obj
'a
)
value
))
(
deftest
slot-type.0
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
stype.0
(
make-instance
'stype
:a
1
)))
(
values
r
(
null
c
)))
1
t
)
(
deftest
slot-type.1
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
stype.0
(
make-instance
'stype
:a
1.0
)))
(
values
r
(
typep
c
'error
)))
nil
t
)
(
deftest
slot-type.2
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
stype.1
(
make-instance
'stype
)
1
))
(
values
r
(
typep
c
'error
)))
1
nil
)
(
deftest
slot-type.3
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
stype.1
(
make-instance
'stype
)
1.0
))
(
values
r
(
typep
c
'error
)))
nil
t
)
(
deftest
slot-type.4
(
multiple-value-bind
(
r
c
)
(
ignore-errors
(
setf
(
slot-value
(
make-instance
'stype
)
'a
)
"string"
))
(
values
r
(
typep
c
'error
)))
nil
t
)
;; slot-value.lisp
(
defclass
sv0
()
((
a
:allocation
:class
:initarg
:a
:initform
0
)))
(
defun
sv0.0
()
(
let*
((
x
(
random
10
))
(
obj
(
make-instance
'sv0
:a
x
)))
(
eql
x
(
slot-value
obj
(
identity
'a
)))))
;;; In previous versions of PCL (18d for example), the above
;;; slot-value fails when the class is redefined.
(
deftest
slot-value.0
(
sv0.0
)
t
)
(
deftest
slot-value.1
(
progn
(
defclass
sv0
()
((
a
:allocation
:class
:initarg
:a
:initform
0
)))
t
)
t
)
(
deftest
slot-value.2
(
sv0.0
)
t
)
(
require
:defsystem
)
(
setf
(
logical-pathname-translations
"pcl-test"
)
(
list
(
list
"*.*.*"
(
merge-pathnames
#p"pcl/*.*"
*load-truename*
))))
(
mk:defsystem
:pcl-test
:initially-do
(
progn
)
:source-pathname
"pcl-test:"
:binary-pathname
"pcl-test:"
:components
((
:file
"pkg"
:source-extension
"lisp"
)
#+
gerds-pcl
(
:file
"ctor"
:source-extension
"lisp"
:depends-on
(
"pkg"
))
(
:file
"defclass"
:source-extension
"lisp"
:depends-on
(
"pkg"
))
(
:file
"make-instance"
:source-extension
"lisp"
:depends-on
(
"pkg"
#+
gerds-pcl
"ctor"
))
(
:file
"reinitialize-instance"
:source-extension
"lisp"
:depends-on
(
"pkg"
"make-instance"
))
(
:file
"slot-value"
:source-extension
"lisp"
:depends-on
(
"pkg"
"make-instance"
))
(
:file
"slot-boundp"
:source-extension
"lisp"
:depends-on
(
"pkg"
"make-instance"
))
(
:file
"slot-missing"
:source-extension
"lisp"
:depends-on
(
"pkg"
"make-instance"
))
(
:file
"slot-accessors"
:source-extension
"lisp"
:depends-on
(
"pkg"
"make-instance"
))
(
:file
"slot-type"
:source-extension
"lisp"
:depends-on
(
"pkg"
"slot-value"
))
(
:file
"inline-access"
:source-extension
"lisp"
:depends-on
(
"pkg"
"slot-type"
))
(
:file
"method-combination"
:source-extension
"lisp"
:depends-on
(
"pkg"
))
(
:file
"pv"
:source-extension
"lisp"
:depends-on
(
"pkg"
))
(
:file
"defgeneric"
:source-extension
"lisp"
:depends-on
(
"pkg"
))
(
:file
"defmethod"
:source-extension
"lisp"
:depends-on
(
"pkg"
))
(
:file
"find-method"
:source-extension
"lisp"
:depends-on
(
"pkg"
))
(
:file
"methods"
:source-extension
"lisp"
:depends-on
(
"pkg"
))))
(
mk:oos
:pcl-test
:compile
)
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment