Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
ansi-test
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Deploy
Releases
Package registry
Container registry
Model registry
Operate
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor 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
Mark Evenson
ansi-test
Commits
0ec144c6
Commit
0ec144c6
authored
22 years ago
by
pfdietz
Browse files
Options
Downloads
Patches
Plain Diff
Added routine to compute class precedence list. Added more defclass tests.
parent
66491a8d
Branches
Branches containing commit
Tags
Tags containing commit
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
ansi-tests/defclass-aux.lsp
+75
-7
75 additions, 7 deletions
ansi-tests/defclass-aux.lsp
ansi-tests/defclass.lsp
+2
-0
2 additions, 0 deletions
ansi-tests/defclass.lsp
with
77 additions
and
7 deletions
ansi-tests/defclass-aux.lsp
+
75
−
7
View file @
0ec144c6
...
@@ -20,6 +20,12 @@
...
@@ -20,6 +20,12 @@
(default-initargs nil :type list)
(default-initargs nil :type list)
(metaclass 'standard-class :type symbol)
(metaclass 'standard-class :type symbol)
(documentation nil :type (or null string))
(documentation nil :type (or null string))
;; Internal fields
(preds nil :type list)
(succs nil :type list)
(count 0 :type integer)
(index nil)
(min-pred-index 1000000)
)
)
(defstruct my-slot
(defstruct my-slot
...
@@ -42,6 +48,10 @@
...
@@ -42,6 +48,10 @@
(defun find-my-class (class-name)
(defun find-my-class (class-name)
(gethash class-name *my-classes*))
(gethash class-name *my-classes*))
;;; This macro will assume that all the superclasses have already
;;; been defined. Tests will be written with defclass itself
;;; to test forward referenced superclasses
(defmacro defclass-with-tests
(defmacro defclass-with-tests
(&whole args
(&whole args
class-name superclasses slot-specifiers
class-name superclasses slot-specifiers
...
@@ -224,14 +234,72 @@
...
@@ -224,14 +234,72 @@
'(,sym))))
'(,sym))))
nil))))
nil))))
#|
(defun compute-class-precedence-list (class-name)
(defun compute-class-precedence-list (class-name)
"Compute the class precdence list for classes defined using
"Compute the class precdence list for classes defined using
DEFCLASS-WITH-TESTS."
DEFCLASS-WITH-TESTS."
(let ((classes nil)
(let ((class-names nil)
(classes-to-consider class-name))
(class-names-to-consider (list class-name))
classes)
;; Find all classes
;; Find all classes
(loop
|#
while class-names-to-consider
do (let ((name (pop class-names-to-consider)))
\ No newline at end of file
(unless (member name class-names)
(push name class-names)
(let ((my-class (find-my-class name)))
(assert my-class)
(setq class-names-to-consider
(append (my-class-direct-superclass-names my-class)
class-names-to-consider))))))
(setq class-names (reverse class-names))
(assert (eq class-name (first class-names)))
;; class-names now contains class-name (which occurs first) and
;; the names of all its superclasses except T
(setq classes (mapcar #'find-my-class class-names))
;; Walk the classes and set the predecessor links in the
;; class precedence DAG
(loop for c in classes
for dsns = (my-class-direct-superclass-names c)
do (let ((pred c))
(loop for superclass-name in dsns
for superclass = (find-my-class superclass-name)
do (push pred (my-class-preds superclass))
do (pushnew superclass (my-class-succs pred))
do (incf (my-class-count superclass))
do (setq pred superclass))))
;; The list candidates will contain all the classes
;; for which the count is zero. These are the candidates
;; for selection as the next class in the class precedence list
(let ((candidates (loop for c in classes
when (zerop (my-class-count c))
collect c))
(n 0)
(result nil))
(assert (equal candidates (list (first classes))))
(loop
while candidates
do (let* ((next (first candidates))
(min-pred-index (my-class-min-pred-index next)))
(loop
for c in (rest candidates)
for c-min-pred-index = (my-class-min-pred-index c)
do
(cond
((< c-min-pred-index min-pred-index)
(setq next c
min-pred-index c-min-pred-index))
(t (assert (not (= c-min-pred-index min-pred-index))))))
(setq candidates (remove next candidates))
(setf (my-class-index next) (incf n))
(push next result)
(loop
for succ in (my-class-succs next)
do (decf (my-class-count succ))
do (setf (my-class-min-pred-index succ)
(min (my-class-min-pred-index succ)
n))
do (when (zerop (my-class-count succ))
(push succ candidates)))))
(assert (eql (length result) (length classes)))
(setq result (reverse result))
(mapcar #'my-class-name result))))
This diff is collapsed.
Click to expand it.
ansi-tests/defclass.lsp
+
2
−
0
View file @
0ec144c6
...
@@ -72,6 +72,8 @@
...
@@ -72,6 +72,8 @@
(defclass-with-tests defclass-1 nil nil)
(defclass-with-tests defclass-1 nil nil)
(defclass-with-tests defclass-2 nil (slot1 slot2 slot3))
(defclass-with-tests defclass-2 nil (slot1 slot2 slot3))
(defclass-with-tests defclass-3 (defclass-1) nil)
(defclass-with-tests defclass-4 (defclass-1 defclass-2) (slot1 slot4))
;;; At end, generate slot tests
;;; At end, generate slot tests
...
...
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