;;; -*- Mode:LISP; Package:(GF USE CL); Readtable:CL; Base:10 -*-
;;;; Fake Generic Functions for the Lambda -- uses CLOS method-arg syntax

(EVAL-WHEN (EVAL LOAD COMPILE)

(defun decode-lambda-list (lambda-list)
  (declare (values instance-arg positional-args keyword-args keyword-names
		   rest-arg allow-other-keys))
  (let* ((aux-vars (member '&AUX lambda-list))
	 (most-args (ldiff lambda-list aux-vars))
	 (instance-arg (first most-args)))
    (if (or (null instance-arg)
	    (member instance-arg lambda-list-keywords))
	(error "No instance argument was given in the lambda list.")
      (setq most-args (rest most-args)))
    (let* ((rest-arg (member '&REST most-args))
	   (keyword-args (member '&KEY most-args))
	   (positional-args (ldiff most-args (or keyword-args rest-arg)))
	   (allow-other-keys (member '&ALLOW-OTHER-KEYS lambda-list))
	   keyword-names)
      (setq positional-args
	    (remove '&OPTIONAL
		    (mapcar #'(lambda (arg) (if (consp arg) (car arg) arg))
			    positional-args)))
      (setq keyword-args (loop for k in (cdr keyword-args)
			       until (member k lambda-list-keywords)
			       when (consp k) do (setq k (car k))
			       appending (list (intern (symbol-name k) si:pkg-keyword-package) k)))
      
      (setq keyword-names (mapcar #'cdr keyword-args))
      (setq rest-arg (cadr rest-arg))
      (values instance-arg
	      positional-args
	      keyword-args
	      keyword-names
	      rest-arg
	      allow-other-keys))))

(defun check-method-arglist (generic-function-name method-lambda-list)
  (unless (get generic-function-name 'generic-function)
    (error "There is no generic ~S function" generic-function-name))
  (multiple-value-bind (nil m-pos nil m-key m-rst m-aok)
      (decode-lambda-list method-lambda-list)
    (multiple-value-bind (nil g-pos nil g-key g-rst g-aok)
	(decode-lambda-list (si:arglist generic-function-name))
      (unless (and (equal m-pos g-pos)
		   (equal m-key g-key)
		   (equal m-rst g-rst)
		   (equal m-aok g-aok))
	(error "The arglist supplied, ~S, does not match the generic arglist for ~S"
	       method-lambda-list generic-function-name)))))

);EVAL-WHEN

(defmacro defgeneric (function-name lambda-list &body declarations)
  (multiple-value-bind (instance-arg positional-args keyword-args nil rest-arg)
      (decode-lambda-list lambda-list)
    (assert (atom instance-arg) (lambda-list))
    (let ((message-sender (if rest-arg 'apply 'funcall))
	  (message-arglist (append positional-args
				   keyword-args
				   (if rest-arg (list rest-arg)))))
      `(progn
	 (eval-when (compile load eval)
	   (setf (get ',function-name 'generic-function) t))
	 (defun ,function-name ,lambda-list
	   ,@declarations
	   (,message-sender ,instance-arg ',function-name ,@message-arglist))))))

(defmacro defmethod (function-name lambda-list &body body)
  (let ((specialized-arg (first lambda-list))
	(ordinary-args (rest lambda-list)))
    (assert (consp specialized-arg) (lambda-list)
	    "First argument must be of the form (ARGUMENT INSTANCE-TYPE)")
    (check-method-arglist function-name lambda-list)
    (let ((flavor (cadr specialized-arg))
	  (self-var (car specialized-arg)))
      `(zl:defmethod (,flavor ,function-name) (,@ordinary-args)
	 (let ((,self-var self))
	   ,@body)))))