- (root-class 'standard-db-object)
- (database *default-database*))
- "Returns a list of View Classes connected to a given DATABASE which
-defaults to *DEFAULT-DATABASE*."
- (declare (ignore root-class))
- (remove-if #'(lambda (c) (not (funcall test c)))
- (database-view-classes database)))
+ (root-class (find-class 'standard-db-object))
+ (database *default-database*))
+ "The LIST-CLASSES function collects all the classes below
+ROOT-CLASS, which defaults to standard-db-object, that are connected
+to the supplied DATABASE and which satisfy the TEST function. The
+default for the TEST argument is identity. By default, LIST-CLASSES
+returns a list of all the classes connected to the default database,
+*DEFAULT-DATABASE*."
+ (flet ((find-superclass (class)
+ (member root-class (class-precedence-list class))))
+ (let ((view-classes (and database (database-view-classes database))))
+ (when view-classes
+ (remove-if #'(lambda (c) (or (not (funcall test c))
+ (not (find-superclass c))))
+ view-classes)))))