;;;; miscellaneous side-effectful tests of the MOP

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

;;; a test of a non-standard specializer class.  Some context: a
;;; (mostly content-free) discussion on comp.lang.lisp around
;;; 2007-05-08 about the merits of Lisp, wherein an F#/OCaml advocate
;;; implies roughly "I've heard that CLOS is slower than pattern
;;; matching"

;;; This implements a generic function type which dispatches on
;;; patterns in its methods.  The implementation below is a simple
;;; interpreter of patterns; compiling the patterns into a
;;; discrimination net, or other optimized dispatch structure, would
;;; be an interesting exercise for the reader.  (As would fixing some
;;; other marked issues).

(defpackage "MOP-27"
  (:use "CL" "SB-MOP"))

(in-package "MOP-27")

(defclass pattern-specializer (specializer)
  ((pattern :initarg pattern :reader pattern)
   (direct-methods :initform nil :reader specializer-direct-methods)))

(defvar *pattern-specializer-table* (make-hash-table :test 'equal))

(defun ensure-pattern-specializer (pattern)
  (or (gethash pattern *pattern-specializer-table*)
      (setf (gethash pattern *pattern-specializer-table*)
            (make-instance 'pattern-specializer 'pattern pattern))))

;;; only one arg for now
(defclass pattern-gf/1 (standard-generic-function) ()
  (:metaclass funcallable-standard-class)
  (:default-initargs :method-class (find-class 'pattern-method)))

(defclass pattern-method (standard-method)
  ((lambda-expr :initarg :lambda-expr :reader pattern-method-lambda-expr)))

(defmethod compute-discriminating-function ((generic-function pattern-gf/1))
  (lambda (arg)
    (let* ((methods (generic-function-methods generic-function))
	   (function (method-interpreting-function methods generic-function))
	   #+nil
           (function (method-compiled-function methods generic-function)))
      (set-funcallable-instance-function generic-function function)
      (funcall function arg))))

(defmethod sb-pcl:make-method-specializers-form 
    ((gf pattern-gf/1) method snames env)
  `(list ,@(mapcar (lambda (s) `(ensure-pattern-specializer ',s)) snames)))

(defun method-compiled-function (methods gf)
  (let* ((arg (gensym "ARG"))
	 (definitions (list (cons (gensym "FAIL")
				  `(no-applicable-method ',gf
							 (list ,arg))))))
    (loop
       for pattern in (reverse (mapcar (lambda (x)
					 (pattern (car (method-specializers x))))
				       methods))
       for m in (reverse methods)
       do (push (cons (gensym "MATCH")
		      (compile-matcher arg
				       pattern
				       (let ((args (gensym "ARGS")))
					 `(locally (declare (optimize speed sb-c::stack-allocate-dynamic-extent))
					    (let ((,args (list nil ,arg)))
					      (declare (dynamic-extent ,args))
					      (,(pattern-method-lambda-expr m)
						(cdr ,args)
						nil))))
				       `(,(car (first definitions)))))
		definitions))
    (let ((body `(lambda (,arg)
		   (labels ,(mapcar (lambda (definition)
				      `(,(car definition) ()
					 ,(cdr definition)))
				    definitions)
		     (,(car (first definitions)))))))
      (compile nil body))))

(defun method-interpreting-function (methods gf)
  (lambda (arg)
    (dolist (method methods (no-applicable-method gf (list arg)))
      (when (matchesp arg (pattern (car (method-specializers method))))
	(locally (declare (optimize sb-c::stack-allocate-dynamic-extent))
	  (let ((args (list nil arg)))
	    (declare (dynamic-extent args))
	    (return (funcall (method-function method) (cdr args) nil))))))))

(defun matchesp (arg pattern)
  (cond
    ((or (null pattern) (eq pattern '_)) t)
    ((atom pattern) (eql arg pattern))
    (t (and (matchesp (car arg) (car pattern)) 
            (matchesp (cdr arg) (cdr pattern))))))

(defun compile-matcher (arg pattern success fail)
  (cond
    ((or (null pattern) (eq pattern '_)) success)
    ((atom pattern) `(if (eql ,arg ',pattern) ,success ,fail))
    (t (let ((car-name (gensym "CAR")) (cdr-name (gensym "CDR")))
	 `(if (consp ,arg)
	      (let ((,car-name (car ,arg)) (,cdr-name (cdr ,arg)))
		(declare (ignorable ,car-name ,cdr-name))
		,(compile-matcher car-name (car pattern)
				  (compile-matcher cdr-name (cdr pattern) 
                                                   success fail)
				  fail))
              ,fail)))))

(defmethod make-method-lambda ((gf pattern-gf/1) method lambda-expr env)
  (multiple-value-bind (lambda args) 
      (call-next-method)
    (values lambda (list* :lambda-expr lambda args))))

;;; protocol functions.  SPECIALIZER-DIRECT-METHODS is implemented by
;;; a reader on the specializer.  FIXME: implement
;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS.
(defmethod add-direct-method ((specializer pattern-specializer) method)
  (pushnew method (slot-value specializer 'direct-methods)))
(defmethod remove-direct-method ((specializer pattern-specializer) method)
  (setf (slot-value specializer 'direct-methods)
        (remove method (slot-value specializer 'direct-methods))))

(defgeneric simplify (x)
  (:generic-function-class pattern-gf/1))
;;; KLUDGE: order of definition matters, as we simply traverse
;;; generic-function-methods until a pattern matches our argument.
;;; Additionally, we're not doing anything interesting with regard to
;;; destructuring the pattern for use in the method body; a real
;;; implementation would make it more convenient.
(defmethod simplify ((y _)) y)
(defmethod simplify ((x (* _ 0))) 0)
(defmethod simplify ((x (* 0 _))) 0)
(defmethod simplify ((x (* _ 1))) (simplify (cadr x)))
(defmethod simplify ((x (* 1 _))) (simplify (caddr x)))

(assert (eql (simplify '(* 0 3)) 0))
(assert (eql (simplify '(* (+ x y) 0)) 0))
(assert (equal (simplify '(+ x y)) '(+ x y)))