- (cases (sort cases #'type-test-order :key #'car)))
- `((typecase ,var
- ,@(mapcar (lambda (case)
- `(,(first case)
- ,@(generate-number-dispatch (rest vars)
- (rest error-tags)
- (cdr case))))
- cases)
- (t (go ,(first error-tags))))))
+ (cases (sort cases #'type-test-order :key #'car)))
+ (flet ((error-if-sub-or-supertype (type1 type2)
+ (when (or (subtypep type1 type2)
+ (subtypep type2 type1))
+ (error "Types not disjoint: ~S ~S." type1 type2)))
+ (error-if-supertype (type1 type2)
+ (when (subtypep type2 type1)
+ (error "Type ~S ordered before subtype ~S."
+ type1 type2)))
+ (test-type-pairs (fun)
+ ;; Apply FUN to all (ordered) pairs of types from the
+ ;; cases.
+ (mapl (lambda (cases)
+ (when (cdr cases)
+ (let ((type1 (caar cases)))
+ (dolist (case (cdr cases))
+ (funcall fun type1 (car case))))))
+ cases)))
+ ;; For the last variable throw an error if a type is followed
+ ;; by a subtype, for all other variables additionally if a
+ ;; type is followed by a supertype.
+ (test-type-pairs (if (cdr vars)
+ #'error-if-sub-or-supertype
+ #'error-if-supertype)))
+ `((typecase ,var
+ ,@(mapcar (lambda (case)
+ `(,(first case)
+ ,@(generate-number-dispatch (rest vars)
+ (rest error-tags)
+ (cdr case))))
+ cases)
+ (t (go ,(first error-tags))))))