+;;;; 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-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)))))
projects / specializable.git / blobdiff