;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 121.35
;;; Reason:
;;;  Mostly Brand S compatible DEFGENERIC.
;;; Written 17-Feb-87 15:03:07 by RpK (Robert P. Krajewski) at site LMI Cambridge
;;; while running on Cthulhu from band 3
;;; with Experimental System 121.34, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental Site Data Editor 5.0, Experimental GRUNCH 4.5, microcode 1742, SDU Boot Tape 3.12, SDU ROM 102, the old ones.

(eval-when (load) ; sigh....

(intern "DEFGENERIC" "GLOBAL")
(export "DEFGENERIC" "GLOBAL")

)

; From modified file DJ: L.SYS2; FLAVOR.LISP#315 at 17-Feb-87 15:35:54
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; FLAVOR  "

(eval-when (load compile eval)
(defun arglist-has-lambda-list-keywords-p (arglist)
  (lisp:some #'(lambda (x) (member x lambda-list-keywords)) (the list arglist)))
)

;;; Tentative support for generic functions.
;;; The main motivation for this is to make it easy to define functional interfaces
;;; to system facilities that used to only have message interfaces.
(defvar *function-support* '())

(defstruct (function-support (:type list) (:conc-name fs-))
  function
  message
  optimizer)

(defun find-function-support (function)
  (lisp:assoc function *function-support*))

(defun generic-function-message (function)
  (fs-message (find-function-support function)))

;;; Let's get rid of obsolete messages while we're are it.
(defvar *message-synonyms* '())

(defsubst get-message-synonym (message)
  (cdr (lisp:assoc message *message-synonyms*)))

(defun find-message-support-1 (message)
  (car (lisp:member message *function-support* :key #'fs-message)))

(defun find-message-support (message)
  (find-message-support-1 (or (get-message-synonym message) message)))

(defmacro defmessage-synonym (message for)
  `(set-message-synonym ',message ',for))

(defun set-message-synonym (message for)
  (setq *function-support* (lisp:delete (find-message-support message) *function-support*))
  (let ((entry (lisp:assoc message *message-synonyms*)))
    (if entry
	(setf (cdr entry) for)
      (consing-in-area (permanent-storage-area)
	(push (cons message for) *message-synonyms*))))
  message)
    
(defun message-generic-function (message)
  (fs-function (find-message-support message)))

(defun msg-function (message)
  (or (message-generic-function message)
      (error "No generic function for message ~S" message)))

(defun function-msg (function)
  (or (generic-function-message function)
      (error "No message for generic function ~S" function)))
  
;;; Note that this preserves optimizers
(defun set-generic-operation (function flavor-message)
  (let ((fs (find-function-support function)))
    (if fs
	(setf (fs-message fs) flavor-message)
      (consing-in-area (permanent-storage-area)
	(push (make-function-support :function function :message flavor-message)
	      *function-support*))))
  function)

(defun set-optimizer-support (function optimizer)
  (let ((fs (find-function-support function)))
    (unless fs
      (error "No support previously defined for ~S" function))
    (setf (fs-optimizer fs) optimizer)))

(defun optimize-generic-call (form)
  (let ((optimizer (fs-optimizer (find-function-support (car form)))))
    (if optimizer
	(funcall optimizer form)
      form)))

(defun generic-inline-send (form)
  (let ((message (generic-function-message (car form))))
    (if message
	`(zl:send ,(cadr form) ',message ,@(cddr form))
      form)))

(defvar *use-generic-function-as-message* nil)

(defun check-compatible-message (generic-function-name message)
  (cond (message)
	(*use-generic-function-as-message*
	 (setq message generic-function-name)
	 (when (eq *use-generic-function-as-message* :warn)
	   (warn "No explicit message message for generic function ~S." generic-function-name)))
	(t
	 (multiple-cerror '(no-compatible-message) ()
	     ("No compatible message for generic function ~S." generic-function-name)
	   ("Use the generic function name as the message."
	    (setq message generic-function-name))
	   ("Supply a message name for the generic function."
	    (loop
	      (setq message (prompt-and-read (list :eval-read :default generic-function-name)
					      "Message name for ~S: " generic-function-name))
	      (if (typep message '(and symbol (not null)))
		  (return nil)
		(format *query-io* "~&~S is not a valid message name.~%" message)))))))
  message)

(defun expand-defgeneric-old-flavors (function arglist options)
  (let ((declarations '()) (documentation nil) (message nil) (pending-methods '())
	;; There seems to be a bug in the spec -- Brand S says that :METHOD-ARGLIST
	;; is used only by :FUNCTION (which we can't implement right now).  The :METHOD
	;; option, which allows DEFMETHODS to happen, says it uses main arglist.  But it
	;; would seem more proper to use the :METHOD-ARGLIST if :METHODS and :FUNCTION were
	;; supplied as well.
	(method-arglist (cdr arglist)))
    (dolist (option options)
      (typecase option
	(string (setq documentation option))
	((member :inline-methods)) ; ignore
	(cons
	 (let ((keyword (car option)))
	   (case keyword
	     (:compatible-message
	      (setq message (second option))
	      (check-type message (and symbol (not null))))
	     (declare
	      (setq declarations (nconc declarations (copy-list (cdr option)))))
	     (:documentation
	      (setq documentation (cadr option))
	      (check-type documentation string))
	     ((:dispatch :function)
	      (cerror "Ignore the option."
		      "The old flavors version of ~S cannot implement the ~S option."
		      'defgeneric keyword))
	     ((:inline-methods :optimize)) ; safe to ignore
	     (:method-arglist (setq method-arglist (cdr option)))
	     (:method (setq pending-methods (nconc pending-methods (ncons (cdr option)))))
	     (:method-combination
	      (warn "The old flavors version of ~S cannot implement ~S; use ~S instead."
		    'defgeneric keyword 'defflavor))
	     (otherwise
	      (error "Unknown option keyword to ~S: ~S" 'defgeneric keyword)))))
	(t (error "Strange object in ~S options: ~S" 'defgeneric option))))
    (setq message (check-compatible-message function message))
    (let ((defmethods (mapcar #'(lambda (spec)
				  `(defmethod (,(caar spec) ,@(cdar spec) ,message)
					      ,method-arglist ; See note above
				     ,@(cdr spec)))
			      pending-methods))
	  (hairy-p (arglist-has-lambda-list-keywords-p arglist)))
      (values
	(list* 'progn
	       (if hairy-p
		   `(defun ,function (,(car arglist) &rest .args.)
		      ,@(and documentation (list documentation))
		      (declare (zl:arglist ,@arglist) ,@declarations)
		      (zl:lexpr-send ,(car arglist) ',message .args.))
		 `(zl:defsubst ,function ,arglist
		    ,@(and documentation (list documentation))
		    (declare ,@declarations)
		    (zl:send ,(car arglist) ',message ,@(cdr arglist))))
	       defmethods)
	message
	(and hairy-p 'generic-inline-send)))))

(defmacro defgeneric (function arglist &rest options)
  "Define a generic FUNCTION with ARGLIST.
ARGLIST should have at least one parameter.

Understood options are:
 a string : the documentation string.  
/(:DOCUMENTATION string) works as well.
/(DECLARE declarations), which can be repeated any number of times.
 The declarations should refer to the function as whole.
/(:COMPATIBLE-MESSAGE message), specifying which message implements this
 generic function.  In old Flavors, this is required.
/(:METHOD (flavor . options) body), which defines a method for the flavor
 with body.  This can appear more than once, with different flavors.
/(:METHOD-ARGLIST . arglist), specifying the argument list of the methods
 which implements this generic function.

:INLINE-METHODS and :OPTIMIZE have no effect.  :METHOD-COMBINATION is not
 accepted and must be specified under DEFFLAVOR.
:DISPATCH and :FUNCTION are currently not allowed."
  (check-type function (and symbol (not keyword)))
  (check-type arglist cons)
  (assert (and (symbolp (car arglist))
	       (not (lisp:member (car arglist) lambda-list-keywords)))
	  ()
	  "The first element of the argument list must be an argument")
  (multiple-value-bind (functional-support message optimizer)
      (expand-defgeneric-old-flavors function arglist options)
    `(progn
       (eval-when (compile load eval)
	 (set-generic-operation ',function ',message)
	 ,@(when optimizer
	     `((compiler:defoptimizer optimize-generic-call ,function)))
	 (set-optimizer-support ',function ,(and optimizer (list 'quote optimizer))))
       ,functional-support)))


))