Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
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
Carl Shapiro
cmucl
Commits
f7c9cb07
Commit
f7c9cb07
authored
20 years ago
by
rtoy
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision.
parent
b8fdaa8a
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
tests/mop-1.impure-cload.lisp
+125
-0
125 additions, 0 deletions
tests/mop-1.impure-cload.lisp
tests/mop-2.impure-cload.lisp
+160
-0
160 additions, 0 deletions
tests/mop-2.impure-cload.lisp
with
285 additions
and
0 deletions
tests/mop-1.impure-cload.lisp
0 → 100644
+
125
−
0
View file @
f7c9cb07
;;;; miscellaneous side-effectful tests of the MOP
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;;; Note that the MOP is not in an entirely supported state.
;;;; However, this seems a good a way as any of ensuring that we have
;;;; no regressions.
;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
;;; fixups for running in the full MOP rather than closette: SLOTDs
;;; instead of slot-names, and so on.
(
defpackage
"TEST"
(
:use
"CL"
#+
sbcl
"SB-MOP"
#+
pcl
"PCL"
))
(
in-package
"TEST"
)
(
defclass
dynamic-slot-class
(
standard-class
)
())
(
defmethod
validate-superclass
((
class
dynamic-slot-class
)
(
super
standard-class
))
t
)
(
defmethod
compute-effective-slot-definition
((
class
dynamic-slot-class
)
name
direct-slots
)
(
let
((
slot
(
call-next-method
)))
(
setf
(
slot-definition-allocation
slot
)
:dynamic
)
slot
))
(
defun
dynamic-slot-p
(
slot
)
(
eq
(
slot-definition-allocation
slot
)
:dynamic
))
(
let
((
table
(
make-hash-table
)))
(
defun
allocate-table-entry
(
instance
)
(
setf
(
gethash
instance
table
)
()))
(
defun
read-dynamic-slot-value
(
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
if
(
null
entry
)
(
error
"slot ~S unbound in ~S"
slot-name
instance
)
(
cdr
entry
))))
(
defun
write-dynamic-slot-value
(
new-value
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
if
(
null
entry
)
(
push
`
(
,
slot-name
.
,
new-value
)
(
gethash
instance
table
))
(
setf
(
cdr
entry
)
new-value
))
new-value
))
(
defun
dynamic-slot-boundp
(
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
not
(
null
entry
))))
(
defun
dynamic-slot-makunbound
(
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
unless
(
null
entry
)
(
setf
(
gethash
instance
table
)
(
delete
entry
alist
))))
instance
)
)
(
defmethod
allocate-instance
((
class
dynamic-slot-class
)
&key
)
(
let
((
instance
(
call-next-method
)))
(
allocate-table-entry
instance
)
instance
))
(
defmethod
slot-value-using-class
((
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
slot
(
read-dynamic-slot-value
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
(
setf
slot-value-using-class
)
(
new-value
(
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
slot
(
write-dynamic-slot-value
new-value
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
slot-boundp-using-class
((
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
slot
(
dynamic-slot-boundp
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
slot-makunbound-using-class
((
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
slot
(
dynamic-slot-makunbound
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defclass
test-class-1
()
((
slot1
:initarg
:slot1
)
(
slot2
:initarg
:slot2
:initform
nil
))
(
:metaclass
dynamic-slot-class
))
(
defclass
test-class-2
(
test-class-1
)
((
slot2
:initarg
:slot2
:initform
t
)
(
slot3
:initarg
:slot3
))
(
:metaclass
dynamic-slot-class
))
(
defvar
*one*
(
make-instance
'test-class-1
))
(
defvar
*two*
(
make-instance
'test-class-2
:slot3
1
))
(
assert
(
not
(
slot-boundp
*one*
'slot1
)))
(
assert
(
null
(
slot-value
*one*
'slot2
)))
(
assert
(
eq
t
(
slot-value
*two*
'slot2
)))
(
assert
(
=
1
(
slot-value
*two*
'slot3
)))
This diff is collapsed.
Click to expand it.
tests/mop-2.impure-cload.lisp
0 → 100644
+
160
−
0
View file @
f7c9cb07
;;;; miscellaneous side-effectful tests of the MOP
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;;; Note that the MOP is not in an entirely supported state.
;;;; However, this seems a good a way as any of ensuring that we have
;;;; no regressions.
;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
;;; fixups for running in the full MOP rather than closette -- SLOTDs
;;; instead of slot-names, and so on -- and :allocation :dynamic for
;;; dynamic slots.
(
untrace
)
(
defpackage
"TEST"
(
:use
"CL"
#+
sbcl
"SB-MOP"
#+
pcl
"PCL"
))
(
in-package
"TEST"
)
(
defclass
dynamic-slot-class
(
standard-class
)
())
(
defmethod
validate-superclass
((
class
dynamic-slot-class
)
(
super
standard-class
))
t
)
(
defun
dynamic-slot-p
(
slot
)
(
eq
(
slot-definition-allocation
slot
)
:dynamic
))
(
let
((
table
(
make-hash-table
)))
(
defun
allocate-table-entry
(
instance
)
(
setf
(
gethash
instance
table
)
()))
(
defun
read-dynamic-slot-value
(
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
if
(
null
entry
)
(
error
"slot ~S unbound in ~S"
slot-name
instance
)
(
cdr
entry
))))
(
defun
write-dynamic-slot-value
(
new-value
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
if
(
null
entry
)
(
push
`
(
,
slot-name
.
,
new-value
)
(
gethash
instance
table
))
(
setf
(
cdr
entry
)
new-value
))
new-value
))
(
defun
dynamic-slot-boundp
(
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
not
(
null
entry
))))
(
defun
dynamic-slot-makunbound
(
instance
slot-name
)
(
let*
((
alist
(
gethash
instance
table
))
(
entry
(
assoc
slot-name
alist
)))
(
unless
(
null
entry
)
(
setf
(
gethash
instance
table
)
(
delete
entry
alist
))))
instance
)
)
(
defmethod
allocate-instance
((
class
dynamic-slot-class
)
&key
)
(
let
((
instance
(
call-next-method
)))
(
allocate-table-entry
instance
)
instance
))
(
defmethod
slot-value-using-class
((
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
(
and
slot
(
dynamic-slot-p
slot
))
(
read-dynamic-slot-value
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
(
setf
slot-value-using-class
)
(
new-value
(
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
(
and
slot
(
dynamic-slot-p
slot
))
(
write-dynamic-slot-value
new-value
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
slot-boundp-using-class
((
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
(
and
slot
(
dynamic-slot-p
slot
))
(
dynamic-slot-boundp
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
slot-makunbound-using-class
((
class
dynamic-slot-class
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
(
and
slot
(
dynamic-slot-p
slot
))
(
dynamic-slot-makunbound
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defclass
test-class-1
()
((
slot1
:initarg
:slot1
:allocation
:dynamic
)
(
slot2
:initarg
:slot2
:initform
nil
))
(
:metaclass
dynamic-slot-class
))
(
defclass
test-class-2
(
test-class-1
)
((
slot2
:initarg
:slot2
:initform
t
:allocation
:dynamic
)
(
slot3
:initarg
:slot3
))
(
:metaclass
dynamic-slot-class
))
(
defvar
*one*
(
make-instance
'test-class-1
))
(
defvar
*two*
(
make-instance
'test-class-2
:slot3
1
))
(
assert
(
not
(
slot-boundp
*one*
'slot1
)))
(
assert
(
null
(
slot-value
*one*
'slot2
)))
(
assert
(
eq
t
(
slot-value
*two*
'slot2
)))
(
assert
(
=
1
(
slot-value
*two*
'slot3
)))
;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
;;; overconservatism in accessing a class's precedence list deep in
;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
;;; finalizing a class.
(
defclass
dynamic-slot-subclass
(
dynamic-slot-class
)
())
(
defmethod
slot-value-using-class
((
class
dynamic-slot-subclass
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
(
and
slot
(
dynamic-slot-p
slot
))
(
read-dynamic-slot-value
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
(
setf
slot-value-using-class
)
(
new-value
(
class
dynamic-slot-subclass
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
(
and
slot
(
dynamic-slot-p
slot
))
(
write-dynamic-slot-value
new-value
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defmethod
slot-boundp-using-class
((
class
dynamic-slot-subclass
)
instance
slotd
)
(
let
((
slot
(
find
slotd
(
class-slots
class
))))
(
if
(
and
slot
(
dynamic-slot-p
slot
))
(
dynamic-slot-boundp
instance
(
slot-definition-name
slotd
))
(
call-next-method
))))
(
defclass
test-class-3
(
test-class-1
)
((
slot2
:initarg
:slot2
:initform
t
:allocation
:dynamic
)
(
slot3
:initarg
:slot3
))
(
:metaclass
dynamic-slot-subclass
))
(
defvar
*three*
(
make-instance
'test-class-3
:slot3
3
))
(
assert
(
not
(
slot-boundp
*three*
'slot1
)))
(
assert
(
eq
(
slot-value
*three*
'slot2
)
t
))
(
assert
(
=
(
slot-value
*three*
'slot3
)
3
))
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