;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/mkreply.sc,v 1.2 90/04/01 13:50:46 johani Exp $

;;; make-reply -- Fetches format for 'name' from *reply-formats* and
;;;               unpacks 'reply' according to this. This is done in the
;;;               following way:
;;;               *reply-formats* is an association list of the form
;;;               '((reply-name . ((name type) ...)
;;;                               ...) ...)
;;;               The appropriate field is copied (so as to not destroy the
;;;               list itself), whereafter a
;;;               (map (lambda (ls)
;;;                      (set-cdr! (car ls) ((cadar ls) str))
;;;                     <local copy of format>))
;;;               essentially is performed. Thus, the local format-copy is
;;;               transformed into an association list of the form
;;;               '((id . val) ...), in which we then can search for messages
;;;               using assq.
;;;               (Isn't functional programming fun? :-)
;;;               The fiddling with *current-reply* appears to be inevitable,
;;;               as the binding of symbols is, to say the least, subtle. The
;;;               (let ((safe *current-reply*) ...) (set! *current-reply* safe)
;;;               is a push/pop version needed for parsing replies which 
;;;               themselves parse replies (initial reply and replies with
;;;               charinfos). Hopefully these will be remade, and we won't
;;;               have this problem...

(define (make-reply name str dpy)
  (let* ((safe *current-reply*)         ; This is ugly!!!
	 (fl
	  (let ((format (tree-copy (cdr (assq name *reply-formats*)))))
	    (set! *current-reply* format)
	    format))
	 (the-reply (let loop ((ls fl))	; Change cdr of each sub-list
		      (if (null? ls)
			  (remove-unused fl)
			  (begin
			    (set-cdr! (car ls) ((cadar ls) str dpy))
			    (loop (cdr ls)) )))))
    (set! *current-reply* safe)		; See above...

    ;; Note: the args are there to conform with the protocol used when sub-
    ;;       classing. It is not used for anything within a reply.
    (define (me msg . args)
      (cond ((eq? msg 'supported-messages)
	     (cons 'display (map car the-reply)))
	    ((eq? msg 'object-class) 'reply)
	    ((eq? msg 'object-system) 'light-weight)
	    ((eq? msg 'me) (lambda () me))
	    ((eq? msg 'object-desc)
	     (list 'reply
		   the-reply
		   'dont-care
		   (cons (cons 'me (lambda () me)) the-reply)
		   'dont-care))
	    ((eq? msg 'reply-name) name)
	    ((eq? msg 'display) dpy)
	    (else
	     (let ((the-pair (assq msg the-reply)))
	       (if the-pair
		   (cdr the-pair)
		   (error name "No such message: ~a" msg) )))))
    me))