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
Container registry
Model registry
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
Michał Herda
ansi-test
Commits
b2af4d89
Commit
b2af4d89
authored
22 years ago
by
pfdietz
Browse files
Options
Downloads
Patches
Plain Diff
Added more infrastructure for testing defclass.
parent
f36e37b9
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
ansi-tests/defclass-aux.lsp
+99
-6
99 additions, 6 deletions
ansi-tests/defclass-aux.lsp
with
99 additions
and
6 deletions
ansi-tests/defclass-aux.lsp
+
99
−
6
View file @
b2af4d89
...
...
@@ -13,6 +13,35 @@
(defparameter *defclass-slot-writers* nil)
(defparameter *defclass-slot-accessors* nil)
(defstruct my-class
(name nil :type symbol)
(direct-superclass-names nil :type list)
(slots nil :type list)
(default-initargs nil :type list)
(metaclass 'standard-class :type symbol)
(documentation nil :type (or null string))
)
(defstruct my-slot
(name nil :type symbol)
(has-initform nil :type boolean)
initform
(initargs nil :type list)
(documentation nil :type (or null string))
(readers nil :type list)
(writers nil :type list)
(accessors nil :type list)
(allocation :instance :type (member :instance :class))
(type t)
)
(defparameter *my-classes* (make-hash-table)
"Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS
to their my-class objects.")
(defun find-my-class (class-name)
(gethash class-name *my-classes*))
(defmacro defclass-with-tests
(&whole args
class-name superclasses slot-specifiers
...
...
@@ -35,7 +64,7 @@
(assert (eql (length class-options)
(length (remove-duplicates class-options))))
(let* ((default-initargs (
second
(assoc :default-initargs class-options)))
(let* ((default-initargs (
rest
(assoc :default-initargs class-options)))
(metaclass (or (second (assoc :metaclass class-options))
'standard-class))
(doc (second (assoc :documentation class-options)))
...
...
@@ -62,7 +91,7 @@
append (collect-properties slot-option :accessor)))
(allocations
(loop for slot-option in slot-options
collect (or (get
:allocation slot-op
tion)
collect (or (get
slot-option :alloca
tion)
:instance)))
(initargs
(loop for slot-option in slot-options
...
...
@@ -87,6 +116,40 @@
(setf *defclass-slot-accessors*
(append accessors *defclass-slot-accessors*))
;;; Store away information about the class and its slots
;;; in a my-class object and associated my-slot objects.
(let* ((my-slots
(loop for name in slot-names
for slot-option in slot-options
for readers = (collect-properties slot-option :reader)
for writers = (collect-properties slot-option :writer)
for accessors = (collect-properties slot-option :accessor)
for documentation = (getf slot-option :documentation)
for initarg-list in initargs
for type-list in types
for initform-list in initforms
for allocation in allocations
collect
(make-my-slot
:name name
:has-initform (notnot initform-list)
:initform (first initform-list)
:documentation documentation
:readers readers
:writers writers
:accessors accessors
:type (if type-list (first type-list) t)
)))
(my-class-obj
(make-my-class :name class-name
:direct-superclass-names superclasses
:default-initargs default-initargs
:documentation doc
:metaclass metaclass
:slots my-slots)))
(setf (gethash class-name *my-classes*) my-class-obj))
`(progn
(eval-when (load eval compile)
...
...
@@ -113,13 +176,31 @@
t))
(deftest ,(make-defclass-test-name class-name
"-INSTANCES-CLASS-IS-THIS-ONE")
(let ((class (find-class ',class-name)))
(eqlt (class-of (allocate-instance class)) class))
t)
"-ALLOCATE-INSTANCE")
(defclass-allocate-instance-test ',class-name ',slot-names)
nil)
)))
(defun defclass-allocate-instance-test (class-name slot-names)
(let* ((class (find-class class-name))
(instance (allocate-instance class)))
(append
(unless (eql (class-of instance) class)
(list (list 'not-instance-of class-name)))
(loop for slot in slot-names
when (slot-boundp instance slot)
collect (list 'is-bound slot))
(loop for slot in slot-names
(unless (equal (multiple-value-list
(notnot-mv (slot-exists-p instance slot)))
'(t))
(list 'does-not-exist slot)))
(let ((bad-slot #:foo))
(when (slot-exists-p instance bad-slot)
(list (list 'should-not-exist bad-slot))))
)))
(defmacro generate-slot-tests ()
"Generate generic tests from the read/writer/accessor functions
for slots from defclass-with-tests."
...
...
@@ -142,3 +223,15 @@
'generic-function))
'(,sym))))
nil))))
#|
(defun compute-class-precedence-list (class-name)
"Compute the class precdence list for classes defined using
DEFCLASS-WITH-TESTS."
(let ((classes nil)
(classes-to-consider class-name))
;; Find all classes
|#
\ No newline at end of file
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