X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=src%2Fpattern-specializer.lisp;fp=src%2Fpattern-specializer.lisp;h=9b201a8fdf6d99c83b5c942dc7b60827e8343e56;hp=0000000000000000000000000000000000000000;hb=149a7b3d9c1eceaeddad8404137383545ac044e8;hpb=9dd8f1378407cae8ec7b6b05a8b3c152bc4a5f9b diff --git a/src/pattern-specializer.lisp b/src/pattern-specializer.lisp new file mode 100644 index 0000000..9b201a8 --- /dev/null +++ b/src/pattern-specializer.lisp @@ -0,0 +1,289 @@ +;;;; pattern-specializer.lisp --- Implementation of pattern specializers. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(cl:in-package #:pattern-specializer) + +;;; `pattern-specializer' class + +(defclass pattern-specializer (specializer) + ((pattern :initarg :pattern + :reader specializer-pattern) + (direct-methods :type list + :initform '() + :reader specializer-direct-methods + :accessor specializer-%direct-methods)) + (:default-initargs + :pattern (required-argument :pattern))) + +(defun specializer-parsed-pattern (specializer) + (optima::parse-pattern (specializer-pattern specializer))) + +(defun specializer-pattern-variables (specializer) + (optima::pattern-variables (specializer-parsed-pattern specializer))) + +;; TODO why did i need this again? +(defmethod class-name ((class (eql (find-class 'pattern-specializer)))) + 'pattern-specializer) + +(defmethod add-direct-method ((specializer pattern-specializer) + (method t)) + (pushnew method (specializer-%direct-methods specializer))) + +(defmethod remove-direct-method ((specializer pattern-specializer) + (method t)) + (removef (specializer-%direct-methods specializer) method :count 1)) + +(defmethod print-object ((object pattern-specializer) stream) + (print-unreadable-object (object stream :type t :identity t) + (princ (specializer-pattern object) stream))) + +;;; + +(defvar *pattern-specializer-table* + (make-hash-table :test 'equal :weakness :key-and-value)) + +(defun ensure-pattern-specializer (pattern) + (ensure-gethash pattern *pattern-specializer-table* + (make-instance 'pattern-specializer :pattern pattern))) + +;;; pattern-method + +;; Forward definition. Actual definition is below. +(defclass pattern-generic-function (standard-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) + ;; + ;; TODO obviously, this has to parse the original lambda-list + ;; properly in the future. + (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))) + + (format t "make-method-lambda-using-specializers~% ~A~% ~A~% ~A~% ~A~%=>" + gf method specializers lambda-expression) + (print new-lambda-list) + (print new-lambda-expression) + + (call-next-method + gf method qualifiers specializers new-lambda-expression environment)))))) + +(defgeneric method-more-specific-p (gf method1 method2)) + +(defmethod method-more-specific-p ((gf pattern-generic-function) + (method1 pattern-method) + (method2 pattern-method)) + (let* ((specializers1 (method-pattern-specializers gf method1)) + (specializers2 (method-pattern-specializers gf method2)) + (more-index (mismatch specializers1 specializers2 + :test (complement #'pattern-more-specific-p) + :key #'specializer-parsed-pattern)) + (less-index (mismatch specializers1 specializers2 + :test #'pattern-more-specific-p + :key #'specializer-parsed-pattern))) + (or (and more-index (not less-index)) + (and more-index (< more-index less-index))))) + +(defun in-same-cluster-p (gf method1 method2) + (or (equal (mapcar #'specializer-pattern + (method-pattern-specializers gf method1)) + (mapcar #'specializer-pattern + (method-pattern-specializers gf method2))) + (method-more-specific-p gf method1 method2) + (method-more-specific-p gf method2 method1))) + +(defun cluster-methods (gf methods) + (let ((clusters '())) + (dolist (method1 methods) + (dolist (cluster clusters (push (list (list method1)) clusters)) + (when (every (lambda (entry) (in-same-cluster-p gf method1 (first entry))) + cluster) + (dolist (entry cluster + (nconcf cluster (list (list method1)))) + (when (equal (mapcar #'specializer-pattern ; TODO repeated in in-same-cluster-p + (method-pattern-specializers gf method1)) + (mapcar #'specializer-pattern + (method-pattern-specializers gf (first entry)))) + (nconcf entry (list method1)) + (return))) + (return)))) + (mapcar (lambda (cluster) + (stable-sort cluster (lambda (entry1 entry2) + (method-more-specific-p gf (first entry1) (first entry2))))) + clusters))) + +;;; pattern-generic-function + +(defclass pattern-generic-function (standard-generic-function) + () + (:metaclass funcallable-standard-class) + (:default-initargs + :method-class (find-class 'pattern-method))) + +(defmethod parse-specializer-using-class + ((gf pattern-generic-function) (specializer-name t)) + (if (typep specializer-name '(cons (eql pattern))) + (let ((pattern (second specializer-name))) + (ensure-pattern-specializer pattern)) + (call-next-method))) + +(defmethod parse-specializer-using-class + ((gf pattern-generic-function) (specializer-name pattern-specializer)) + specializer-name) + +(defmethod unparse-specializer-using-class + ((gf pattern-generic-function) (specializer pattern-specializer)) + `(pattern ,(specializer-pattern specializer))) + +(defmethod make-specializer-form-using-class or + ((proto-generic-function pattern-generic-function) + (proto-method pattern-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))) + +(defun make-matching-lambda-form (gf methods) + (let ((arity (when-let ((first-method (first methods))) + (length (method-specializers first-method)))) + (clusters (cluster-methods gf methods))) + (labels ((specializer-pattern1 (specializer) + (typecase specializer + (pattern-specializer (specializer-pattern specializer)) + (t '*))) + (method-variables (method) + (mappend #'specializer-pattern-variables + (method-pattern-specializers gf method))) + (cluster-clause (most-specific-method other-methods) + (let ((specializers (method-specializers most-specific-method))) + `(,(case arity + (1 (specializer-pattern1 (first specializers))) + (t (mapcar #'specializer-pattern1 specializers))) + (values + '(,most-specific-method ,@other-methods) + (list ,@(method-variables most-specific-method)))))) + (cluster-clauses (cluster) + (loop :for ((head-first . head-rest) . rest) :on cluster + :collect (cluster-clause + head-first (reduce #'append rest + :initial-value head-rest))))) + `(lambda ,(case arity + (1 '(arg)) + (t '(&rest args))) + ,(case arity + (1 '(format t "dispatch: ~A~%" arg)) + (t '(format t "dispatch: ~A~%" args))) + (,@(case arity + (1 `(optima:match arg)) + (t `(optima:multiple-value-match (values-list args)))) + ,@(loop :for cluster :in clusters + :appending (cluster-clauses cluster))))))) + +(defun make-method-interpreting-function (gf) + (format t "~&method-interpreting-function: ~A~%" gf) + (let* ((methods (generic-function-methods gf)) + (f (compile nil (print (make-matching-lambda-form gf methods))))) + (named-lambda method-pattern-matching-function (&rest args) ; TODO just return the (compile …) above after debugging + (apply f args)))) + +(defmethod compute-discriminating-function + ((gf pattern-generic-function)) + (lambda (&rest args) + (format t "~&discriminating function: ~A~%" args) + (labels ((make-effective-method-form (spec) + `(lambda (&rest args) + (locally + (declare (sb-ext:disable-package-locks make-method call-method)) + (macrolet ((make-method (spec) + (let ((make-effective-method-function ,#'make-effective-method-function)) + (make-instance 'standard-method + :specializers nil ; TODO + :qualifiers nil ; TODO + :function (let ((f (funcall make-effective-method-function spec))) + (lambda (a n) + (apply f a)))))) + (call-method (method next-methods) + ;; TODO we could do method-specific parsing here + ;; TODO can we extract the method-function like ,(method-function method)? + `(progn + (format t "~& trying to call~% ~A~% ~A~% ~A~%" + ,method args (list ,@next-methods)) + (funcall (method-function ,method) args (list ,@next-methods))))) + ,spec)))) + (make-effective-method-function (spec) + (compile nil (make-effective-method-form spec)))) + (let* ((function2 (make-method-interpreting-function gf)) + (function4 (lambda (&rest args) + (multiple-value-bind (methods variables) (apply function2 args) + + (loop :for spec :in (method-pattern-specializers gf (first methods)) + :for gen :in (mapcar #'class-of args) + :do (print (list spec gen (multiple-value-list (specializer-accepts-generalizer-p + gf spec gen))))) + + (let ((function3 (progn + (format t "~& methods~% ~A~& variables~& ~A~%" methods variables) + (multiple-value-bind (effective-method options) + (compute-effective-method + gf (sb-mop::generic-function-method-combination gf) methods) + (format t "~& effective method:~& ") + (print effective-method) + (format t "~& options:~& ") + (print options) + (make-effective-method-function effective-method))))) + (apply function3 (append args (loop :for value :in variables + :for name :in (when methods + (mappend + #'specializer-pattern-variables + (method-pattern-specializers gf (first methods)))) + :collect (make-keyword name) + :collect value)))))))) + (set-funcallable-instance-function gf function4) ; TODO seems to be wrong + (apply function4 args)))))