--- /dev/null
+;;;; optima-extensions.lisp --- Necessary extensions of the optima library.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:pattern-specializer)
+
+;;; Protocol
+
+(defgeneric pattern-more-specific-p (pattern1 pattern2)
+ (:documentation
+ "Return true if PATTERN1 is strictly more specific than
+ PATTERN2.
+
+ General principles:
+
+ * Constant pattern are more specific than all other patterns
+
+ * Variable patterns are less specific than all other patterns
+
+ * For most complex patterns, subpatterns are compared
+ lexicographically. Exceptions:
+
+ * For `class-pattern' s, subclass relations have higher
+ precedence. The above rule applies only when the classes are
+ identical.
+
+ * `and-pattern's are comparable to all patterns by checking
+ whether some of their subpatterns are more specific than the
+ pattern in question.
+
+ * `or-pattern's are similar."))
+
+(defun subpatterns-unrestricted-p (pattern)
+ (every (of-type 'optima.core:variable-pattern)
+ (optima.core:complex-pattern-subpatterns pattern)))
+
+;;; Implementation
+
+(defmethod pattern-more-specific-p :around ((pattern1 optima::pattern)
+ (pattern2 optima::pattern))
+ (if (eq pattern1 pattern2)
+ '=
+ (call-next-method)))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima::pattern))
+ '/=)
+
+;; `constant-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:constant-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 'optima.core:complex-pattern)
+ (call-next-method)
+ '<))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:constant-pattern))
+ (if (typep pattern1 'optima.core:complex-pattern)
+ (call-next-method)
+ '>))
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:constant-pattern)
+ (pattern2 optima.core:constant-pattern))
+ (if (equal (optima.core:constant-pattern-value pattern1)
+ (optima.core:constant-pattern-value pattern2))
+ '=
+ '/=))
+
+;; `variable-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:variable-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 '(or optima.core:or-pattern optima.core:and-pattern))
+ (call-next-method)
+ '>))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:variable-pattern))
+ (if (typep pattern1 '(or optima.core:or-pattern optima.core:and-pattern))
+ (call-next-method)
+ '<))
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:variable-pattern)
+ (pattern2 optima.core:variable-pattern))
+ '=)
+
+;;; `guard-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:guard-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 '(or optima.core:or-pattern optima.core:and-pattern)) ; TODO not-pattern
+ (call-next-method)
+ '<))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:guard-pattern))
+ (if (typep pattern1 '(or optima.core:or-pattern optima.core:and-pattern))
+ (call-next-method)
+ '>))
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:guard-pattern)
+ (pattern2 optima.core:guard-pattern))
+ (if (equal (optima.core:guard-pattern-test-form pattern1) ; TODO not enough because of variable names; encode variables with TODO numbers
+ (optima.core:guard-pattern-test-form pattern2))
+ (pattern-more-specific-p
+ (optima.core:guard-pattern-subpattern pattern1)
+ (optima.core:guard-pattern-subpattern pattern2))
+ '/=))
+
+;; `and-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:and-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 'optima.core:and-pattern)
+ (call-next-method)
+ (let ((result (pattern-more-specific-p pattern2 pattern1)))
+ (case result
+ (< '>)
+ (> '<)
+ (t result)))))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:and-pattern))
+ (reduce (lambda (result subpattern)
+ (case (pattern-more-specific-p pattern1 subpattern)
+ (< (case result
+ ((nil <) '<)
+ (= '=)
+ (t '/=)))
+ (> (case result
+ ((nil > =) '>)
+ (t '/=)))
+ (= (case result
+ ((nil < =) '=)
+ (> '>)
+ (t '/=)))
+ (t '/=)))
+ (optima.core:complex-pattern-subpatterns pattern2)
+ :initial-value nil))
+
+;; `or-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:or-pattern)
+ (pattern2 optima::pattern))
+ (if (typep pattern2 'optima.core:or-pattern)
+ (call-next-method)
+ (let ((result (pattern-more-specific-p pattern2 pattern1)))
+ (case result
+ (< '>)
+ (> '<)
+ (t result)))))
+
+(defmethod pattern-more-specific-p ((pattern1 optima::pattern)
+ (pattern2 optima.core:or-pattern))
+ (reduce (lambda (result subpattern)
+ (case (pattern-more-specific-p pattern1 subpattern)
+ (< '<)
+ (> (case result
+ ((nil >) '>)
+ (t result)))
+ (= (case result
+ ((nil = >) '=)
+ (t result)))
+ (/= (case result
+ ((nil) '/=)
+ (= '<)
+ (t result)))))
+ (optima.core:complex-pattern-subpatterns pattern2)
+ :initial-value nil))
+
+;; `cons-pattern'
+
+; TODO do this in a generic way via optima.core:complex-pattern-subpatterns
+(defmethod pattern-more-specific-p ((pattern1 optima.core:cons-pattern)
+ (pattern2 optima.core:cons-pattern))
+ (let* ((car1 (optima.core:cons-pattern-car-pattern pattern1))
+ (cdr1 (optima.core:cons-pattern-cdr-pattern pattern1))
+ (car2 (optima.core:cons-pattern-car-pattern pattern2))
+ (cdr2 (optima.core:cons-pattern-cdr-pattern pattern2))
+ (result/car (pattern-more-specific-p car1 car2))
+ (result/cdr (pattern-more-specific-p cdr1 cdr2)))
+ (cond
+ ((and (eq result/cdr '=) (eq result/car '=))
+ '=)
+ ((and (eq result/car '<) (member result/cdr '(< =)))
+ '<)
+ ((and (eq result/cdr '<) (member result/car '(< =)))
+ '<)
+ ((and (eq result/car '>) (member result/cdr '(> =)))
+ '>)
+ ((and (eq result/cdr '>) (member result/car '(> =)))
+ '>)
+ (t
+ '/=))))
+
+;; `class-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:class-pattern)
+ (pattern2 optima.core:class-pattern))
+ (let* ((class1 (optima.core:class-pattern-class-name pattern1))
+ (slots1 (optima.core:class-pattern-slot-names pattern1))
+ (subpatterns1 (optima.core:class-pattern-subpatterns pattern1))
+ (class2 (optima.core:class-pattern-class-name pattern2))
+ (slots2 (optima.core:class-pattern-slot-names pattern2))
+ (subpatterns2 (optima.core:class-pattern-subpatterns pattern2))
+ (fewer-slots1-p (set-difference slots2 slots1))
+ (fewer-slots2-p (set-difference slots1 slots2)))
+ (labels ((lookup (slot)
+ (when-let ((position (position slot slots2)))
+ (nth position subpatterns2)))
+ (compare-slots (initial)
+ ;; TODO alternate idea: iterate over (union slots1 slots2); use lookup1 and lookup2 leading to :missing1 and :missing2
+ (reduce (lambda (result slot1-and-subpattern1)
+ (destructuring-bind (slot1 . subpattern1) slot1-and-subpattern1
+ (case (if-let ((subpattern2 (lookup slot1)))
+ (pattern-more-specific-p subpattern1 subpattern2)
+ :missing)
+ ((< :missing) (case result
+ ((nil < =) '<)
+ (t '/=)))
+ (> (case result
+ ((nil > =) '>)
+ (t '/=)))
+ (= result)
+ (t '/=))))
+ (mapcar #'cons slots1 subpatterns1)
+ :initial-value initial)))
+ (multiple-value-bind (result1 certain1-p) (subtypep class1 class2)
+ (multiple-value-bind (result2 certain2-p) (subtypep class2 class1)
+ (assert (and certain1-p certain2-p))
+ (cond
+ ((and result1 result2)
+ (compare-slots (if fewer-slots1-p '> '=)))
+ (result1
+ (cond
+ (fewer-slots1-p '/=)
+ (fewer-slots2-p (compare-slots '<))
+ (t (compare-slots '<))))
+ (result2
+ (cond
+ (fewer-slots2-p '/=)
+ (fewer-slots1-p (compare-slots '>))
+ (t (compare-slots '>))))
+ (t
+ '/=)))))))
+
+;; `structure-pattern'
+
+(defmethod pattern-more-specific-p ((pattern1 optima.core:structure-pattern)
+ (pattern2 optima.core:structure-pattern))
+ (error "not implemented"))
--- /dev/null
+;;;; pattern-specializer.lisp --- Implementation of pattern specializers.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:pattern-specializer)
+
+;;; `pattern-generalizer' class
+
+(defstruct (pattern-generalizer
+ (:constructor make-pattern-generalizer (specializers key variables &optional next))
+ (:copier nil))
+ (specializers nil :type list :read-only t)
+ (key nil :type t :read-only t)
+ (variables nil :type list :read-only t)
+ (next nil :type t))
+
+(defmethod specializable:generalizer-equal-hash-key
+ ((generic-function specializable:specializable-generic-function)
+ (generalizer pattern-generalizer))
+ (let ((key (pattern-generalizer-key generalizer)))
+ (if-let ((next (pattern-generalizer-next generalizer))) ; TODO compute lazily?
+ (cons key (specializable:generalizer-equal-hash-key
+ generic-function next))
+ key)))
+
+(defmethod specializable::generalizer-args
+ ((generic-function specializable:specializable-generic-function)
+ (generalizer pattern-generalizer))
+ (pattern-generalizer-variables generalizer))
+
+;;; `pattern-specializer' class
+
+(defclass pattern-specializer (specializable:extended-specializer)
+ ((pattern :initarg :pattern
+ :reader specializer-pattern))
+ (:default-initargs
+ :pattern (required-argument :pattern)))
+
+(defmethod print-object ((object pattern-specializer) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (princ (specializer-pattern object) stream)))
+
+(defun specializer-parsed-pattern (specializer)
+ (optima.core:parse-pattern (specializer-pattern specializer)))
+
+(defun specializer-pattern-variables (specializer)
+ (optima.core:pattern-variables (specializer-parsed-pattern specializer)))
+
+(specializable:define-extended-specializer pattern (generic-function pattern)
+ (declare (ignore generic-function))
+ (make-instance 'pattern-specializer :pattern pattern))
+
+;; Parsing is handled by `define-extended-specializer' above
+
+(defmethod unparse-specializer-using-class
+ ((gf specializable:specializable-generic-function) (specializer pattern-specializer))
+ `(pattern ,(specializer-pattern specializer)))
+
+(defmethod make-specializer-form-using-class or
+ ((proto-generic-function specializable:specializable-generic-function) ; TODO should work for all specializable generic functions
+ (proto-method specializable:specializable-method)
+ (specializer-name cons)
+ (environment t))
+ (when (typep specializer-name '(cons (eql pattern)))
+ `(sb-pcl:parse-specializer-using-class ; TODO packages
+ (sb-pcl:class-prototype (find-class ',(type-of proto-generic-function)))
+ ',specializer-name)))
+
+;;; Equality and ordering
+
+(defmethod sb-pcl::same-specializer-p ((specializer1 pattern-specializer)
+ (specializer2 pattern-specializer))
+ (let ((pattern1 (specializer-parsed-pattern specializer1))
+ (pattern2 (specializer-parsed-pattern specializer2)))
+ (eq (pattern-more-specific-p pattern1 pattern2) '=)))
+
+;; TODO should (pattern SOME-CLASS) be `same-specializer-p' to SOME-CLASS?
+
+(defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
+ (specializer1 pattern-specializer)
+ (specializer2 pattern-specializer)
+ (generalizer t))
+ (pattern-more-specific-p
+ (specializer-parsed-pattern specializer1)
+ (specializer-parsed-pattern specializer2)))
+
+;; TODO necessary?
+(defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
+ (specializer1 t)
+ (specializer2 pattern-specializer)
+ (generalizer t))
+ '/=)
+
+;; TODO necessary?
+(defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
+ (specializer1 pattern-specializer)
+ (specializer2 t)
+ (generalizer t))
+ '/=)
+
+(defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
+ (specializer1 class)
+ (specializer2 pattern-specializer)
+ (generalizer t))
+ (multiple-value-bind (result definitivep)
+ (specializable:specializer-accepts-generalizer-p
+ generic-function specializer2 specializer1)
+ (cond
+ ((and result definitivep) '<)
+ (result '>))))
+
+;; TODO can this be avoided?
+(defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
+ (specializer1 class)
+ (specializer2 class)
+ (generalizer pattern-generalizer))
+ (let ((next (pattern-generalizer-next generalizer)))
+ (cond
+ ((typep next 'class)
+ (specializable:specializer< generic-function specializer1 specializer2 next))
+ ((multiple-value-bind (result1 definitivep1)
+ (subtypep specializer1 specializer2)
+ (multiple-value-bind (result2 definitivep2)
+ (subtypep specializer2 specializer1)
+ (cond
+ ((not (and definitivep1 definitivep2)))
+ ((and result1 result2) '=)
+ (result1 '>)
+ (result2 '<)
+ (t '/=))))))))
+
+;;; Accepting objects and generalizers
+
+(defmethod specializable:specializer-accepts-p ((specializer pattern-specializer) object)
+ ;; TODO store in specializer later
+ (let* ((accept-form (with-gensyms (object)
+ `(lambda (,object)
+ (optima:match ,object
+ (,(specializer-pattern specializer)
+ (declare (ignore ,@(specializer-pattern-variables specializer)))
+ t)))))
+ (accept-function (compile nil accept-form)))
+ (funcall accept-function object)))
+
+(defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (generalizer pattern-generalizer))
+ (values (find specializer (pattern-generalizer-specializers generalizer)) t))
+
+(defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
+ (specializer t)
+ (generalizer pattern-generalizer))
+ (when-let ((next (pattern-generalizer-next generalizer))) ; TODO needed?
+ (specializable:specializer-accepts-generalizer-p gf specializer next)))
+
+(defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (generalizer t))
+ (specializer-accepts-generalizer-p-using-pattern
+ gf specializer (specializer-parsed-pattern specializer) generalizer))
+
+(defmethod specializer-accepts-generalizer-p-using-pattern
+ ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (pattern optima.core:variable-pattern)
+ (generalizer t))
+ (values t t))
+
+(defmethod specializer-accepts-generalizer-p-using-pattern
+ ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (pattern optima.core:and-pattern)
+ (generalizer t))
+ (let ((definitivep t))
+ (values
+ (block nil
+ (mapc (lambda (subpattern)
+ (multiple-value-bind (result definitivep)
+ (specializer-accepts-generalizer-p-using-pattern
+ gf specializer subpattern generalizer)
+ (unless result
+ (setf definitivep t) ; TODO correct?
+ (return nil))
+ (unless definitivep
+ (setf definitivep nil))))
+ (optima::complex-pattern-subpatterns pattern)))
+ definitivep)))
+
+(defmethod specializer-accepts-generalizer-p-using-pattern
+ ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (pattern optima.core:or-pattern)
+ (generalizer t))
+ (error "not implemented"))
+
+(defmethod specializer-accepts-generalizer-p-using-pattern
+ ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (pattern optima.core:not-pattern)
+ (generalizer t))
+ (multiple-value-bind (result definitivep)
+ (specializer-accepts-generalizer-p-using-pattern
+ gf specializer (optima.core:not-pattern-subpattern pattern) generalizer)
+ (values (not result) definitivep)))
+
+(defmethod specializer-accepts-generalizer-p-using-pattern
+ ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (pattern optima.core:cons-pattern)
+ (generalizer t))
+ (multiple-value-bind (result definitivep) (subtypep generalizer 'cons)
+ (if result
+ (values t (and definitivep (subpatterns-unrestricted-p pattern)))
+ (values nil definitivep))))
+
+(defmethod specializer-accepts-generalizer-p-using-pattern
+ ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (pattern optima.core:class-pattern)
+ (generalizer t))
+ (multiple-value-bind (result definitivep)
+ (specializable:specializer-accepts-generalizer-p
+ gf (find-class (optima.core:class-pattern-class-name pattern)) generalizer)
+ (if result
+ (values t (and definitivep (subpatterns-unrestricted-p pattern)))
+ (values nil definitivep))))
+
+(defmethod specializer-accepts-generalizer-p-using-pattern
+ ((gf specializable:specializable-generic-function)
+ (specializer pattern-specializer)
+ (pattern optima.core:guard-pattern)
+ (generalizer t))
+ (values t nil)) ; TODO
+
+;; TODO why did i need this again?
+(defmethod class-name ((class (eql (find-class 'pattern-specializer))))
+ 'pattern-specializer)
+;; at least this one is for slime
+(defmethod class-name ((class pattern-specializer))
+ 'pattern-specializer)
+
+;;; pattern-method
+
+;; Forward definition. Actual definition is below.
+(defclass pattern-generic-function (specializable:specializable-generic-function)
+ ()
+ (:metaclass funcallable-standard-class))
+
+(defclass pattern-method (standard-method)
+ ())
+
+(defmethod method-pattern-specializers ((gf pattern-generic-function)
+ (method pattern-method))
+ (remove-if-not (of-type 'pattern-specializer)
+ (mapcar (curry #'parse-specializer-using-class gf) ; TODO necessary?
+ (method-specializers method))))
+
+(defmethod make-method-lambda-using-specializers
+ ((gf pattern-generic-function) (method pattern-method) qualifiers specializers
+ lambda-expression environment)
+
+ ;; This transforms LAMBDA-EXPRESSION of the form
+ ;;
+ ;; (lambda (arg1 arg2 …) BODY)
+ ;;
+ ;; into
+ ;;
+ ;; (lambda (arg1 arg2 …
+ ;; &key
+ ;; ((:PATTERN-VAR1 PATTERN-VAR1)) ((:PATTERN-VAR2 PATTERN-VAR2)) …
+ ;; &allow-other-keys)
+ ;; BODY)
+ ;;
+ ;; where BODY contains uses of PATTERN-VAR1, PATTERN-VAR2, …
+ (destructuring-bind (operator lambda-list &body body) lambda-expression
+ (declare (ignore operator))
+ (multiple-value-bind (required optional rest keyword allow-other-keys-p)
+ (parse-ordinary-lambda-list lambda-list :normalize nil)
+ (flet ((make-keyword-parameter (variable)
+ (list `((,(make-keyword variable) ,variable)))))
+ (let* ((variables (mappend #'specializer-pattern-variables ; TODO this stuff is repeated in make-method-matching-form
+ (remove-if-not (of-type 'pattern-specializer)
+ (mapcar (curry #'parse-specializer-using-class gf)
+ specializers))))
+ (new-lambda-list `(,@required
+ ,@(when optional
+ `(&optional ,@optional))
+ ,@(when rest
+ `(&rest ,rest))
+ ,@(when (or keyword variables)
+ `(&key ,@keyword
+ ,@(mapcan #'make-keyword-parameter variables)))
+ ,@(when allow-other-keys-p
+ '(&allow-other-keys))))
+ (new-lambda-expression `(lambda ,new-lambda-list ,@body)))
+ (call-next-method
+ gf method qualifiers specializers new-lambda-expression environment))))))
+
+;;; pattern-generic-function
+
+(defclass pattern-generic-function (specializable:specializable-generic-function)
+ ((specializer-clusters :type list)
+ (generalizer-makers :type list #|of function|#))
+ (:metaclass funcallable-standard-class)
+ (:default-initargs
+ :method-class (find-class 'pattern-method))) ; TODO is pattern-method even needed?
+
+(defmethod reinitialize-instance :after ((instance pattern-generic-function)
+ &key)
+ (slot-makunbound instance 'specializer-clusters)
+ (slot-makunbound instance 'generalizer-makers))
+
+(defmethod generic-function-specializer-clusters ((generic-function pattern-generic-function))
+ (if (slot-boundp generic-function 'specializer-clusters) ; TODO ensure-slot-value
+ (slot-value generic-function 'specializer-clusters)
+ (setf (slot-value generic-function 'specializer-clusters)
+ ;; TODO copied from make-generalizer-makers
+ (when-let* ((methods (generic-function-methods generic-function))
+ (arity (when-let ((first-method (first methods)))
+ (length (method-specializers first-method)))) ; TODO improve
+ )
+ (loop :for i :below arity
+ :collect (let* ((specializers (mapcar (lambda (method)
+ (nth i (method-specializers method)))
+ methods))
+ (non-pattern-specializers
+ (remove-if (of-type 'pattern-specializer) specializers))
+ (pattern-specializers
+ (set-difference specializers non-pattern-specializers)))
+ (specializer-clusters generic-function pattern-specializers)))))))
+
+(defmethod generic-function-generalizer-makers ((generic-function pattern-generic-function))
+ (if (slot-boundp generic-function 'generalizer-makers)
+ (slot-value generic-function 'generalizer-makers)
+ (setf (slot-value generic-function 'generalizer-makers)
+ (make-generalizer-makers generic-function))))
+
+(defmethod specializable:generalizers-of-using-class ((generic-function pattern-generic-function) args)
+ (let ((nexts))
+ (loop
+ :for i :from 0
+ :for maker :in (generic-function-generalizer-makers generic-function)
+ :for arg :in args
+ :do (pop nexts)
+ :collect
+ (cond
+ ((funcall maker arg))
+ ((not nexts) (first (setf nexts (nthcdr i (call-next-method)))))
+ (t (first nexts))))))
+
+;;; Specializer clustering
+
+(defmethod in-same-cluster-p ((generic-function t) (specializer1 t) (specializer2 t))
+ nil)
+
+(defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
+ (specializer1 pattern-specializer)
+ (specializer2 pattern-specializer))
+ (let ((pattern1 (specializer-parsed-pattern specializer1))
+ (pattern2 (specializer-parsed-pattern specializer2)))
+ (member (pattern-more-specific-p pattern1 pattern2) '(= < >))))
+
+(defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
+ (specializer1 pattern-specializer)
+ (specializer2 class))
+ (specializable:specializer-accepts-generalizer-p
+ generic-function specializer1 specializer2))
+
+(defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
+ (specializer2 class)
+ (specializer1 pattern-specializer))
+ (specializable:specializer-accepts-generalizer-p
+ generic-function specializer1 specializer2))
+
+(defun specializer-clusters (generic-function specializers)
+ (let ((clusters '()))
+ (dolist (specializer specializers)
+ (dolist (cluster clusters (push (list (list specializer)) clusters))
+ (when (every (lambda (entry)
+ (in-same-cluster-p
+ generic-function specializer (first entry)))
+ cluster)
+ (dolist (entry cluster (nconcf cluster (list (list specializer))))
+ (when (sb-pcl::same-specializer-p specializer (first entry))
+ (nconcf entry (list specializer))
+ (return)))
+ (return))))
+ (mapcar (lambda (cluster)
+ (stable-sort cluster (lambda (entry1 entry2)
+ (eq '< (specializable:specializer<
+ generic-function entry1 entry2 :TODO)))
+ :key #'first))
+ clusters)))
+
+;;; Generalizers maker
+
+(defun make-generalizer-maker-form (generic-function specializers clusters)
+ (labels ((cluster-element-clause (element rest)
+ (let* ((specializer (first element))
+ (variables (specializer-pattern-variables specializer)))
+ `(,(specializer-pattern specializer)
+ (make-pattern-generalizer
+ '(,@(mappend #'identity (list* element rest)))
+ ',(specializer-pattern specializer)
+ (list ,@(loop :for variable in (remove-if-not #'symbol-package variables) ; TODO hack
+ :collect (make-keyword variable)
+ :collect variable))))))
+ (cluster-clauses (cluster)
+ (loop :for (element . rest) :on cluster
+ :collect (cluster-element-clause element rest))))
+ `(lambda (arg)
+ (optima:match arg
+ ,@(mappend #'cluster-clauses clusters)
+ (t ,(make-pattern-generalizer '() nil '()))))))
+
+(defun make-generalizer-maker (generic-function specializers clusters)
+ (let* ((non-pattern-specializers
+ (remove-if (of-type 'pattern-specializer) specializers))
+ (pattern-specializers
+ (set-difference specializers non-pattern-specializers)))
+ (values (compile nil (make-generalizer-maker-form
+ generic-function pattern-specializers clusters))
+ non-pattern-specializers)))
+
+(defun make-generalizer-makers (generic-function)
+ (let* ((clusters (generic-function-specializer-clusters generic-function))
+ (methods (generic-function-methods generic-function))
+ (arity (when-let ((first-method (first methods)))
+ (length (method-specializers first-method)))) ; TODO improve
+ (any-non-pattern-specializers-p nil))
+ (values
+ (loop :for i :below arity
+ :collect (multiple-value-bind
+ (generalizer-maker non-pattern-specializers-p)
+ (make-generalizer-maker
+ generic-function
+ (mapcar (lambda (method)
+ (nth i (method-specializers method)))
+ methods)
+ (nth i clusters))
+ (when non-pattern-specializers-p
+ (setf any-non-pattern-specializers-p t))
+ generalizer-maker))
+ any-non-pattern-specializers-p)))