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
6b223b43
Commit
6b223b43
authored
24 years ago
by
dtc
Browse files
Options
Downloads
Patches
Plain Diff
Add support for computing class precedence lists, and use this to
correctly calculate the CPL for the condition classes.
parent
e390f5a4
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
code/class.lisp
+86
-2
86 additions, 2 deletions
code/class.lisp
code/error.lisp
+5
-16
5 additions, 16 deletions
code/error.lisp
code/exports.lisp
+2
-1
2 additions, 1 deletion
code/exports.lisp
with
93 additions
and
19 deletions
code/class.lisp
+
86
−
2
View file @
6b223b43
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.4
5
2000/08/0
7
1
4:27:25
dtc Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.4
6
2000/08/0
8
1
3:41:18
dtc Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -34,7 +34,7 @@
built-in-class-direct-superclasses
find-class-cell
class-cell-name
class-cell-class
make-layout
make-undefined-class
insured-find-class
redefine-layout-warning
))
redefine-layout-warning
std-compute-class-precedence-list
))
(
in-package
"LISP"
)
(
export
'
(
class
structure-class
standard-class
class-name
find-class
class-of
...
...
@@ -1125,6 +1125,90 @@
old
)))
(
t
old
))))
;;; Class precedence lists
;;; topological-sort -- Public.
;;;
;;; Topologically sort the list of objects to meet a set of ordering
;;; constraints given by pairs (A . B) constraining A to precede B. When
;;; there are multiple objects to choose, the tie-breaker function is called
;;; with both the list of object to choose from and the reverse ordering built
;;; so far.
;;;
(
defun
topological-sort
(
objects
constraints
tie-breaker
)
(
declare
(
list
objects
constraints
)
(
function
tie-breaker
))
(
let
((
obj-info
(
make-hash-table
:size
(
length
objects
)))
(
free-objs
nil
)
(
result
nil
))
(
dolist
(
constraint
constraints
)
(
let
((
obj1
(
car
constraint
))
(
obj2
(
cdr
constraint
)))
(
let
((
info2
(
gethash
obj2
obj-info
)))
(
if
info2
(
incf
(
first
info2
))
(
setf
(
gethash
obj2
obj-info
)
(
list
1
))))
(
let
((
info1
(
gethash
obj1
obj-info
)))
(
if
info1
(
push
obj2
(
rest
info1
))
(
setf
(
gethash
obj1
obj-info
)
(
list
0
obj2
))))))
(
dolist
(
obj
objects
)
(
let
((
info
(
gethash
obj
obj-info
)))
(
when
(
or
(
not
info
)
(
zerop
(
first
info
)))
(
push
obj
free-objs
))))
(
loop
(
flet
((
next-result
(
obj
)
(
push
obj
result
)
(
dolist
(
successor
(
rest
(
gethash
obj
obj-info
)))
(
let*
((
successor-info
(
gethash
successor
obj-info
))
(
count
(
1-
(
first
successor-info
))))
(
setf
(
first
successor-info
)
count
)
(
when
(
zerop
count
)
(
push
successor
free-objs
))))))
(
cond
((
endp
free-objs
)
(
do-hash
(
obj
info
obj-info
)
(
unless
(
zerop
(
first
info
))
(
error
"Topological sort failed due to constrain on ~S."
obj
)))
(
return
(
nreverse
result
)))
((
endp
(
rest
free-objs
))
(
next-result
(
pop
free-objs
)))
(
t
(
let
((
obj
(
funcall
tie-breaker
free-objs
result
)))
(
setf
free-objs
(
remove
obj
free-objs
))
(
next-result
obj
))))))))
;;; std-compute-class-precedence-list -- Internal.
;;;
;;; Standard class precedence list computation.
;;;
(
defun
std-compute-class-precedence-list
(
class
)
(
let
((
classes
nil
)
(
constraints
nil
))
(
labels
((
note-class
(
class
)
(
unless
(
member
class
classes
)
(
push
class
classes
)
(
let
((
superclasses
(
class-direct-superclasses
class
)))
(
do
((
prev
class
)
(
rest
superclasses
(
rest
rest
)))
((
endp
rest
))
(
let
((
next
(
first
rest
)))
(
push
(
cons
prev
next
)
constraints
)
(
setf
prev
next
)))
(
dolist
(
class
superclasses
)
(
note-class
class
)))))
(
std-cpl-tie-breaker
(
free-classes
rev-cpl
)
(
dolist
(
class
rev-cpl
(
first
free-classes
))
(
let*
((
superclasses
(
class-direct-superclasses
class
))
(
intersection
(
intersection
free-classes
superclasses
)))
(
when
intersection
(
return
(
first
intersection
)))))))
(
note-class
class
)
(
topological-sort
classes
constraints
#'
std-cpl-tie-breaker
))))
;;; PCL stuff:
...
...
This diff is collapsed.
Click to expand it.
code/error.lisp
+
5
−
16
View file @
6b223b43
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.5
6
2000/08/0
6
1
9:12
:1
7
dtc Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.5
7
2000/08/0
8
1
3:41
:1
8
dtc Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -437,9 +437,6 @@
;;;; Condition reporting:
;;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
;;; superclasses in define-condition call!
(
defun
%print-condition
(
s
stream
d
)
(
declare
(
ignore
d
))
(
if
*print-escape*
...
...
@@ -583,18 +580,10 @@
(
setf
(
find-class
name
)
class
)
;;
;; Initialize CPL slot from layout.
(
collect
((
cpl
))
(
cpl
class
)
(
let
((
inherits
(
layout-inherits
layout
)))
(
do
((
i
(
1-
(
length
inherits
))
(
1-
i
)))
((
minusp
i
))
(
let
((
super
(
find-class
(
class-name
(
layout-class
(
svref
inherits
i
))))))
(
when
(
typep
super
'condition-class
)
(
cpl
super
)))))
(
setf
(
condition-class-cpl
class
)
(
cpl
))))
;; Initialize CPL slot.
(
setf
(
condition-class-cpl
class
)
(
remove-if-not
#'
condition-class-p
(
std-compute-class-precedence-list
class
))))
(
undefined-value
))
)
; eval-when (compile load eval)
...
...
This diff is collapsed.
Click to expand it.
code/exports.lisp
+
2
−
1
View file @
6b223b43
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.17
1
2000/08/0
6
1
9:12
:1
8
dtc Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.17
2
2000/08/0
8
1
3:41
:1
9
dtc Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -1594,6 +1594,7 @@
"SIMPLE-ARRAY-SIGNED-BYTE-32-P"
"SIMPLE-ARRAY-SIGNED-BYTE-8-P"
"SIMPLE-UNBOXED-ARRAY"
"SINGLE-FLOAT-BITS"
"SINGLE-FLOAT-EXPONENT"
"SINGLE-FLOAT-P"
"SINGLE-VALUE-TYPE"
"SPECIFIER-TYPE"
"STACK-REF"
"STD-COMPUTE-CLASS-PRECEDENCE-LIST"
"STREAMLIKE"
"STRINGABLE"
"STRINGLIKE"
"%INSTANCE-LENGTH"
"%INSTANCE-REF"
"%INSTANCE-SET"
...
...
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