;;;
;;; mv-setf.lisp
;;;
;;; Multiple-value SETF with generic functions.
;;;

(cl:defpackage :nq-clim/mv-setf
  (:use :cl)
  (:export "DEFGENERIC*"
           "DEFMETHOD*"))
(cl:in-package :nq-clim/mv-setf)


;;; Internal helper functions

(deftype setf-function-name ()
  ;; A proper list of the form (SETF <foo>), for some symbol <foo>.
  '(cons (eql setf) (cons symbol null)))

(defun accessor-name (name)
  "Return the name of the accessor embedded in the SETF-FUNCTION name NAME."
  ;; While we're at it, make sure it's actually a SETF-FUNCTION name.
  (unless (typep name 'setf-function-name)
    (error "~S is not a SETF-FUNCTION name" name))
  (cadr name))

(defun setf*-function-name (name)
  "Return a version of the SETF-FUNCTION name NAME suitably mangled to uniquely identify a ``SETF* GENERIC FUNCTION'' for NAME."
  ;; Ideally, this should return `(SETF* ,NAME), but that's not a
  ;; valid function name.  Using `(SETF ,NAME) is also out, because
  ;; the implementations of these functions do not conform to the
  ;; protocol defined for SETF-functions and a Sufficiently Paranoid
  ;; Compiler might detect this.  Interning symbols into our package
  ;; is out because it would almost certainly confuse users.
  ;; Interning symbols into *PACKAGE* is out because it's dependent on
  ;; state that can change from invocation to invocation.  The only
  ;; option left is to intern a new symbol into the symbol-package of
  ;; NAME, and hope that the package isn't locked and that the new
  ;; name doesn't collide anything.
  (let ((accessor-name (accessor-name name)))
    (intern (format nil "~A-SETF*-FUNCTION" (symbol-name accessor-name))
            (symbol-package accessor-name))))

(defun parse-defmethod*-args (args)
  "Parse the argument list ARGS for DEFMETHOD*, returning three values: A list of method qualifiers, the specialized-lambda-list for the method to be defined, and the body (declarations and forms) of the method."
  (let* ((args-without-qualifiers (member-if #'listp args))
         (qualifiers (ldiff args args-without-qualifiers))
         (lambda-list (car args-without-qualifiers))
         (body (cdr args-without-qualifiers)))
    (values qualifiers lambda-list body)))


;;; The public interface

(defmacro defgeneric* (name lambda-list &body options)
  "Define a generic function for multiple-value SETF.  NAME must be a SETF-FUNCTION name, and LAMBDA-LIST is a list of the values to be set followed by the single parameter to the corresponding accessor.  OPTIONS is as per DEFGENERIC."
  (let ((function-name (setf*-function-name name)))
    `(progn
       (defgeneric ,function-name ,lambda-list ,@options)
       (defsetf ,(accessor-name name) ,(last lambda-list) ,(butlast lambda-list)
         `(,',function-name ,lambda-list)))))

(defmacro defmethod* (name &body args)
  "Define a method for a multiple-value SETF function.  The true arglist is ``name {method-qualifier}* specialized-lambda-list &body body''.  NAME must be a SETF-FUNCTION name, and the last argument in SPECIALIZED-LAMBDA-LIST is intended to be specialized as the single argument to the corresponding accessor.  {METHOD-QUALIFIER}* and BODY are as per DEFMETHOD.  Unlike DEFMETHOD, DEFMETHOD* cannot be relied upon to implicitly create a suitable generic-function."
  ;; FIXME: Ideally, this should do the same defaulting with respect
  ;; to DEFGENERIC* that DEFMETHOD does with respect to DEFGENERIC.
  (multiple-value-bind
        (qualifiers arglist body)
      (parse-defmethod*-args args)
    `(defmethod ,(setf*-function-name name) ,@qualifiers ,arglist
       ,@body)))


;;; EOF