;;;  -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Cold-Load:Yes -*-
;;;
;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987-1989 Texas Instruments Incorporated.  All rights reserved.

;;;  ---------------------------------------------------------------------
;;;  A new implementation of the DEFSELECT macro for a world without select-methods.
;;;  This version will expand into a CASE or CCASE that will apply an internal
;;;  function to the supplied arguments according to the first argument.
;;;  ---------------------------------------------------------------------
;; Revised:
;;  2/13/87 DNG - Use NAMED-LAMBDA instead of LAMBDA and define :SELECT-METHOD
;;		function specs to be equivalent to :INTERNAL. 

(DEFMACRO DEFSELECT (FSPEC &BODY METHODS)
  "Define a function named FSPEC which dispatches on its first argument to
find a method.  Each element of METHODS is a method for one or several
possible first arguments.  Syntax:

   (DEFSELECT fspec           (DEFSELECT (fspec default-handler no-which-operations)
     (operation (args ...)      (operation (args ...)
       body ...)                  body ...)
     (operation (args ...)      (operation (args ...)
       body ...))                 body ...))

FSPEC is the name of the function to be defined.  OPERATION is a keyword or a
list of keywords that names the operations to be handled by the clause.  ARGS
is a lambda-list for the clause;  it should not include an argument for the
operation.  BODY is the body of the function for the clause.  When FSPEC is
called, it will choose a clause based on the first argument, bind its
parameters to the remaining arguments, and run the body, returning its
result.

A clause may instead look like (OPERATION . SYMBOL), in which SYMBOL is the
name of a function that will be called for the OPERATION.  It will be given
all the arguments, including the operation symbol itself, unlike the body of
a normal clause.

DEFAULT-HANDLER is optional;  it is a function which is called if the first
argument is an unknown operation.  If unsupplied or NIL, an unknown operation
will cause a continuable error.  NO-WHICH-OPERATIONS is also optional;  if
non-NIL, the automatically-generated clauses for :WHICH-OPERATIONS,
:OPERATION-HANDLED-P, and :SEND-IF-HANDLES are suppressed."

   (let* ((default-handler		    (if (consp fspec) (second fspec) nil))
	  (no-which-operations		    (if (consp fspec) (third fspec) nil))
	  (fspec (standardize-function-spec (if (consp fspec) (first fspec) fspec)))
	  (operation-list nil)
	  (clauses-list nil))

     ;;  Collect all operation keywords into the operation-list, and collect clauses for the
     ;;  eventual CASE.  Normal clauses are applied to just the arguments, while symbolic
     ;;  clauses are applied to the operation keyword and the arguments.
     (loop for (key . method-body) in methods
	   doing (if (consp key)
		     (setq operation-list (revappend key operation-list))
		     (push key operation-list))
	   doing (if (symbolp method-body)
		     (push `(,key (apply #',method-body op args)) clauses-list)
		     (push `(,key (apply #'(,(if (common-lisp-on-p) 'named-lambda 'global:named-lambda)
					    ,(if (atom key) key (car key))
					    ,@method-body)
					 args))
			   clauses-list)))

     ;;  If we are doing :which-operations, generate the standard operations.
     (cond (no-which-operations
	    (setq operation-list (nreverse operation-list)))
	   (:else
	    (setq operation-list
		  (nreconc operation-list '(:which-operations :operation-handled-p :send-if-handles)))
	    ;;  Sigh.  Named-structure-invoke always passes at least one argument, so :which-operations
	    ;;  has to take the &rest arg.  I don't know about :operation-handled-p, but the old version
	    ;;  had a &rest arg there, so I might as well.  - pf, July 23, 1986
	    (setq clauses-list
		  (append `((:which-operations
			      (apply #'(named-lambda :which-operations (&rest ignore) ',operation-list)
				     args))
			    (:operation-handled-p
			      (apply #'(named-lambda :operation-handled-p (op &rest ignore)
					 (not (null (member op ',operation-list :test #'eq))))
				     args))
			    (:send-if-handles
			      (apply #'(named-lambda :send-if-handles (op &rest to-send)
					 (when (member op ',operation-list :test #'eq)
					   (apply (function ,fspec) op to-send)))
				     args)))
			  clauses-list))))
     (setq clauses-list (nreverse clauses-list))	; Keep them in definition order.

     ;;  The eventual form.  Note the CCASE if there is no default handler (if it is important
     ;;  that an error signal the SYS:UNCLAIMED-MESSAGE condition, we may have to change it).
     `(defun ,fspec (op &rest args)
	 ,(if default-handler
	      `(case op
		 ,@clauses-list
		 (otherwise (apply #',default-handler op args)))
	      `(ccase op
		 ,@clauses-list)))))

(deff (:property :select-method function-spec-handler) 'internal-function-spec-handler)