;;;
;;;              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/mkerror.sc,v 1.3 90/04/01 13:50:41 johani Exp $

;;; make-error -- Creates an error object from a byte stream. Not entirely
;;;               unlike make-event, only errors are easier, as they only have
;;;               one field that may vary from error to error. The message for
;;;               obtaining the error-name is 'error-name.

(define (make-error str dpy)
  (let* ((type (d-card8 str dpy))
	 (the-err (vector-ref *error-names* type))
	 (err-name (car the-err))
	 (info-type (cdr the-err))
	 (seq-nr (d-card16 str dpy))
	 (info (let ((the-info (d-card32 str dpy)))
		 (case info-type
		   ('bad-resource-id
		    ((dpy 'scix-id-vector) 'lookup the-info) )
		   ('bad-atom-id
		    ((dpy 'atombox) 'lookup-name the-info) )
		   (else the-info) )))
	 (minor-opcode (d-card16 str dpy))
	 (major-opcode (d-card8 str dpy))
	 (unused ((gobble! 21) str dpy))
	 (valid-msgs (remove 'unused `(error-name seq-nr display
				       ,info-type minor-opcode
				       major-opcode))))
    (define (me msg . args)
      (cond ((eq? msg 'supported-messages) valid-msgs)
            ((eq? msg 'object-class) 'error)
	    ((eq? msg 'object-system) 'light-weight)
	    ((eq? msg 'me) (lambda () me))
            ((eq? msg 'error-name) err-name)
	    ((eq? msg 'seq-nr) seq-nr)
	    ((and (eq? msg info-type)
		  (not (eq? msg 'unused)) ) info)
	    ((eq? msg 'minor-opcode) minor-opcode)
	    ((eq? msg 'major-opcode) major-opcode)
	    ((eq? msg 'display) dpy)
	    ((eq? msg 'object-desc) #f)	; Not meaningful
	    (else (error 'error "No such message ~a" msg)) ))
    me))