initial import of pattern-specializer system

diff --git a/language-extension.pattern-specializer.asd b/language-extension.pattern-specializer.asd
new file mode 100644 (file)
index 0000000..1377c87
--- /dev/null
+++ b/language-extension.pattern-specializer.asd
@@ -0,0 +1,30 @@
+;;;; language-extension.pattern-specializer.asd --- System definition for the language-extension.pattern-specializer system.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:defpackage #:language-extension.pattern-specializer-sytem
+  (:use
+   #:cl
+   #:asdf))
+
+(cl:in-package #:language-extension.pattern-specializer-sytem)
+
+(defsystem :language-extension.pattern-specializer
+  :author      "Jan Moringen <jmoringe@techfak.uni-bielefeld.de>"
+  :license     "LLGPLv3; see COPYING file for details."
+  :description "Use optima patterns as specializers in CLOS methods - SBCL ONLY"
+  :depends-on  (;; (:feature :sbcl) this works differently than one might think; it's more like (:if-features :sbcl :foo :bar)
+
+                :specializable
+
+                :alexandria
+                :optima)
+  :components  ((:module     "src"
+                 :pathname   "src/pattern-specializer"
+                 :serial     t
+                 :components ((:file       "package")
+                              (:file       "protocol")
+                              (:file       "optima-extensions")
+                              (:file       "pattern-specializer")))))

diff --git a/src/pattern-specializer/optima-extensions.lisp b/src/pattern-specializer/optima-extensions.lisp
new file mode 100644 (file)
index 0000000..644194a
--- /dev/null
+++ b/src/pattern-specializer/optima-extensions.lisp
@@ -0,0 +1,254 @@
+;;;; 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"))

diff --git a/src/pattern-specializer/package.lisp b/src/pattern-specializer/package.lisp
new file mode 100644 (file)
index 0000000..2f86c44
--- /dev/null
+++ b/src/pattern-specializer/package.lisp
@@ -0,0 +1,51 @@
+;;;; package.lisp --- Package definition for the language-extension.pattern-specializer system.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:defpackage #:pattern-specializer
+  (:use
+   #:cl
+   #:alexandria)
+
+  (:import-from #:sb-mop
+
+   #:funcallable-standard-class
+   #:set-funcallable-instance-function
+
+   #:specializer
+   #:specializer-direct-methods
+
+   #:method-specializers
+   #:method-function
+
+   #:compute-discriminating-function
+   #:compute-effective-method
+
+   #:generic-function-name
+   #:generic-function-methods
+   #:add-direct-method
+   #:remove-direct-method)
+
+  (:import-from #:sb-pcl
+   #:parse-specializer-using-class
+   #:unparse-specializer-using-class
+   #:make-specializer-form-using-class
+
+   #:make-method-lambda-using-specializers)
+
+  ;; Specifier symbol for the pattern specializer
+  (:export
+   #:pattern)
+
+  ;; Pattern specializer class
+  (:export
+   #:pattern-specializer
+   #:specializer-pattern)
+
+  ;; Generic function and method
+  (:export
+   #:pattern-generic-function
+
+   #:pattern-method))

diff --git a/src/pattern-specializer/pattern-specializer.lisp b/src/pattern-specializer/pattern-specializer.lisp
new file mode 100644 (file)
index 0000000..a3593e8
--- /dev/null
+++ b/src/pattern-specializer/pattern-specializer.lisp
@@ -0,0 +1,446 @@
+;;;; 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)))

diff --git a/src/pattern-specializer/protocol.lisp b/src/pattern-specializer/protocol.lisp
new file mode 100644 (file)
index 0000000..2835810
--- /dev/null
+++ b/src/pattern-specializer/protocol.lisp
@@ -0,0 +1,46 @@
+;;;; protocol.lisp --- Protocol used by pattern specializers.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:pattern-specializer)
+
+;;; Pattern specializer protocol
+
+(defgeneric specializer-accepts-generalizer-p-using-pattern
+    (generic-function specializer pattern generalizer)
+  (:documentation
+   "Like SPECIALIZER-ACCEPTS-GENERALIZER-P but with the ability to
+    dispatch on PATTERN."))
+
+;;; Pattern generic function protocol
+
+(defgeneric generic-function-specializer-clusters (generic-function)
+  (:documentation
+   "Return a list of specializer cluster for
+    GENERIC-FUNCTION. Assuming GENERIC-FUNCTION has N required
+    parameters, the returned list is of the following form
+
+      ((PARAM_1-CLUSTER_1 ... PARAM_1-CLUSTER_M_1)
+       ...
+       (PARAM_N-CLUSTER_1 ... PARAM_N-CLUSTER_M_N)
+
+    where each PARAM_I_CLUSTER_J is a sorted list of `pattern-specializer's
+
+      (SPECIALIZER_1 ... SPECIALIZER_L)
+
+    such that for an object O
+
+      SPECIALIZER_I accepts O => SPECIALIZER_K accepts O
+
+    for K >= I."))
+
+(defgeneric generic-function-generalizer-makers (generic-function)
+  (:documentation
+   "TODO"))
+
+(defgeneric in-same-cluster-p (generic-function specializer1 specializer2)
+  (:documentation
+   "Return true if for GENERIC-FUNCTION SPECIALIZER1 and SPECIALIZER2
+    are in the same cluster."))