From 841bc8f5bed9d2e26716232d1b1788f96c65acd1 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Sun, 18 May 2014 20:33:50 +0200 Subject: [PATCH] initial import of pattern-specializer system --- language-extension.pattern-specializer.asd | 30 ++ .../optima-extensions.lisp | 254 ++++++++++ src/pattern-specializer/package.lisp | 51 ++ .../pattern-specializer.lisp | 446 ++++++++++++++++++ src/pattern-specializer/protocol.lisp | 46 ++ 5 files changed, 827 insertions(+) create mode 100644 language-extension.pattern-specializer.asd create mode 100644 src/pattern-specializer/optima-extensions.lisp create mode 100644 src/pattern-specializer/package.lisp create mode 100644 src/pattern-specializer/pattern-specializer.lisp create mode 100644 src/pattern-specializer/protocol.lisp diff --git a/language-extension.pattern-specializer.asd b/language-extension.pattern-specializer.asd new file mode 100644 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 + +(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 " + :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 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 + +(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 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 + +(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 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 + +(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 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 + +(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.")) -- 2.39.5