+(defmacro deep-compare ((left right) &body body)
+ (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
+ (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
+ `(macrolet ((focus (expr &body body)
+ `(flet ((,',func (it) ,expr))
+ (let ((,',l (,',func ,',l))
+ (,',r (,',func ,',r)))
+ ,@body)))
+ (update (expr)
+ `(flet ((,',func (it) ,expr))
+ (psetf ,',l (,',func ,',l)
+ ,',r (,',func ,',r))))
+ (compare (expr)
+ `(cond ((let ((left ,',l) (right ,',r)) ,expr)
+ (return-from ,',block t))
+ ((let ((right ,',l) (left ,',r)) ,expr)
+ (return-from ,',block nil))))
+ (typesw (&rest clauses)
+ (labels ((iter (clauses)
+ (if (null clauses)
+ 'nil
+ (destructuring-bind (type &rest body)
+ (car clauses)
+ (if (eq type t)
+ `(progn ,@body)
+ `(if (typep ,',l ',type)
+ (if (typep ,',r ',type)
+ (progn ,@body)
+ (return-from ,',block t))
+ (if (typep ,',r ',type)
+ (return-from ,',block nil)
+ ,(iter (cdr clauses)))))))))
+ (iter clauses))))
+ (let ((,l ,left) (,r ,right))
+ (block ,block
+ ,@body)))))
+
+(defun order-specializers (la lb)
+ (deep-compare (la lb)
+ (loop (typesw (null (return nil)))
+ (focus (car it)
+ (typesw (sb-mop:eql-specializer
+ (focus (sb-mop:eql-specializer-object it)
+ (typesw (keyword
+ (compare (string< left right)))
+ (symbol
+ (focus (package-name (symbol-package it))
+ (compare (string< left right)))
+ (compare (string< left right)))
+ (t
+ (focus (with-output-to-string (out)
+ (prin1 it out)
+ (write-char #\nul))
+ (compare (string< left right)))))))
+ (class
+ (focus (class-name it)
+ (focus (package-name (symbol-package it))
+ (compare (string< left right)))
+ (compare (string< left right))))
+ (t
+ (error "unexpected things"))))
+ (update (cdr it)))))
+