;;;
;;;              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/mkevent.sc,v 1.2 90/04/01 13:50:43 johani Exp $

;;; make-event --- creates an event of type event-no from the input-string str.
;;;                The string is parsed sequentially, and each local binding
;;;                "strips off" as many bytes as it needs. The format (i.e,
;;;                the definition of the event) is fetched from the vector
;;;                *event-formats*, which contains name and type of each field
;;;                in the object as a pair. This information is copied, and
;;;                the type is replaced by the value obtained by applying it
;;;                to the input string when parsing. Example of usage:
;;;                      (define the-event (make-event event-type reply))
;;;                for construction, and eg,
;;;                       (the-event 'event)
;;;                to obtain the name of the event.
(define (make-event event-no str dpy)
  ;; sent-event is true if the event is created through a SendEvent request
  ;; from some client.
  (let* ((sent-event (not (zero? (bit-and event-no #x80))))
	 (event-code (bit-and event-no #x7f))
	 (evf (let loop ((ls (vector-ref *event-formats* event-code))
			 (result '()))
		(if (null? ls)
		    result
		    (loop (cdr ls) (append result (list (cons (caar ls)
							      (cdar ls) )))))))
	 (the-event (let lop ((ls evf))
		      (if (null? ls)
			  (remove-unused evf)
			  (begin
			    (set-cdr! (car ls) ((cdar ls) str dpy))
			    (lop (cdr ls)) ))))
	 (valid-msgs (append '(display sent-event?)
			     (map car the-event) )))
    (define (me msg . args)
      (let ((the-pair (assq msg the-event)))
	(if the-pair
	    (cdr the-pair)
	    (cond ((eq? msg 'supported-messages) valid-msgs)
		  ((eq? msg 'object-class) 'event)
		  ((eq? msg 'object-system) 'light-weight)
		  ((eq? msg 'me) (lambda () me))
		  ((eq? msg 'sent-event?) sent-event)
		  ((eq? msg 'display) dpy)
		  ((eq? msg 'object-desc) #f) ; Not meaningful.
		  (else (error 'event "No such message ~a" msg)) ))))
    me))