X-Git-Url: http://christophe.rhodes.io/gitweb/?a=blobdiff_plain;f=src%2Fpattern-specializer%2Fpattern-specializer.lisp;fp=src%2Fpattern-specializer%2Fpattern-specializer.lisp;h=a3593e8c537b9d4c98de05729acfb1371360c0b3;hb=841bc8f5bed9d2e26716232d1b1788f96c65acd1;hp=0000000000000000000000000000000000000000;hpb=3f63bd12fd23084b8148a3ee37e2360553c674f7;p=specializable.git 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)))