;;;
;;;              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

;;; make-mask -- creates an object implementing the various bitmasks and
;;;              'list of value's used in the X protocol. Format of call:
;;;     (make-mask (<mask-bit> <type>) ...)
;;;              or
;;;     (make-mask (<mask-bit> ...))
;;;              for masks without values. In the former case, <type>
;;;              corresponds to the type of the value associated with
;;;              this bit in the ListOfValue. Supports the messages 
;;;              '<field> which returns the value of the field, 'set!
;;;              which takes additional arguments '(<field> . <value>) ..., and
;;;              sets the <field> to <value>, 'unset! which is the counterpart
;;;              of 'add!, 'mask which returns the value of the mask, and
;;;              'listofvalue which returns the ListOfValue as a list of
;;;              bytes (the latter renders an error if the simple make-mask
;;;              was used.
;;;              Symbolic constants are maintained as such until the value
;;;              is needed. This leads to overhead if a mask is repeatedly
;;;              asked for its ListOfValue, but since our general strategy
;;;              is to keep the symbolic names as far as possible, we have
;;;              chosen this implementation.

(eval-when (load compile eval)
(extend-syntax (make-mask)
  ((make-mask ((id type) ...))
   (with (((ids ...) (remq 'unused '(id ...))))
     (let ((id (cons 0 0)) ...)
       (define (me msg . args)
	 (cond ((eq? msg 'object-class) 'mask)
	       ((eq? msg 'object-system) 'light-weight)
	       ((eq? msg 'supported-messages)
		(append '(names set! unset! set-mask! mask listofvalue length
				clear! or-mask! set? unset?)
			'(ids ...) ))
	       ((eq? msg 'me) me)
	       ((eq? msg 'ids) (cdr ids))
	       ...
	       ((eq? msg 'names) '(ids ...))
	       ((eq? msg 'set!)
		(for-each (lambda (pare)
			    (let* ((qls (memq
					 (if (pair? pare)
					     (car pare)
					     pare)
					 '(ids ...)))
				   (vls (if qls
					    (list-tail (list ids ...)
						       (- (length '(ids ...))
							  (length qls) ))
					    #f)))
			      (if vls
				  (begin
				    (set-car! (car vls) 1)
				    (if (pair? pare)
					(set-cdr! (car vls) (cadr pare)) ; Obs
					(set-cdr! (car vls) 1) ))
				  (error 'set! "No such field: ~a"
					 (car pare)) )))
			  args)
		#t)
	       ((eq? msg 'unset!)
		(for-each (lambda (pare)
			    (let* ((qls (memq
					 (if (pair? pare)
					     (car pare)
					     pare)
					 '(ids ...)))
				   (vls (if qls
					    (list-tail (list ids ...)
						       (- (length '(ids ...))
							  (length qls) ))
					    #f)))
			      (if vls
				  (begin
				    (set-car! (car vls) 0)
				    (set-cdr! (car vls) 0) )
				  (error 'unset! "No such field: ~a"
					 (car pare)) )))
			  args)
		#t)
	       ((eq? msg 'set-mask!)
		(let iloop ((the-mask (car args)) (sym-names '(id ...)))
		  (if (null? sym-names)
		      (me 'mask)
		      (begin
			(if (not (zero? (bit-and the-mask 1)))
			    (me 'set! (car sym-names)) )
			(iloop (/ the-mask 2) (cdr sym-names)) ))))
	       ((eq? msg 'listofvalue)
		(lambda (str)
		  (if (equal? (car '(type ...)) ''()) ; Yes, '' is correct. See
     		                                      ; below for explanation.
		      (error 'mask "Not a mask with a listofvalue") )
		  (for-each (lambda (i t)
			      (cond ((zero? (car i)))    ; Ignore unset bits
				    ((symbol? (cdr i))   ; Symbolic const
				     (a-card32
				      (lookup-constant (cdr i)
						       *mask-constants*)
				      str))
				    (else                ; Default
				     (pad4 (t (cdr i) str) str) )))
			    (list id ...)
			    (list type ...) )))
	       ((eq? msg 'mask)
		(let loop ((ls (list id ...)) (factor 1) (result 0))
		  (if (null? ls)
		      result
		      (loop (cdr ls)
			    (* factor 2)
			    (+ result (* (caar ls) factor) )))))
	       ((eq? msg 'length)
		(let loop ((ls (list id ...)) (len 0))
		  (if (null? ls)
		      len
		      (loop (cdr ls) (+ len (caar ls))) )))
	       ((eq? msg 'clear!)
		(for-each (lambda (i)
			    (set-car! i 0)
			    (set-cdr! i 0) )
			  (list id ...) )) 
	       ((eq? msg 'or-mask!)
		(if (car args)
		    (let* ((lh me)
			   (rh (car args))
			   (set-names (filter (lambda (n)
						(rh 'set? n))
					      (rh 'names) )))
		      (for-each (lambda (n)
				  (lh 'set! `(,n ,(rh n))) )
				set-names) )))
	       ((eq? msg 'set?)
		(let* ((ls (list id ...))
		       (arg (car args))
		       (qls (memq arg '(ids ...)))
		       (vls (if qls
				(list-tail (list ids ...)
					   (- (length '(ids ...))
					      (length qls) ))
				#f)))
		  (if vls
		      (eq? (caar vls) 1)
		      (error 'set? "No such field: ~a" arg) )))
	       ((eq? msg 'unset?)
		(let* ((ls (list id ...))
		       (arg (car args))
		       (qls (memq arg '(ids ...)))
		       (vls (if qls
				(list-tail (list ids ...)
					   (- (length '(ids ...))
					      (length qls) ))
				#f)))
		  (if vls
		      (eq? (caar vls) 0)
		      (error 'set? "No such field: ~a" arg) )))
	       (else (error 'mask "undefined operation: ~a" msg))))
       me)))

;;; Simple mask without value-list. The quote in the expansion (which is
;;; responsible for the double quoting above) is needed since we have a
;;; construction of the form (list type ...), which would expand to
;;; (list () () ...) if the quote was omitted. This is, of course, illegal,
;;; but the code would never be executed, so it doesn't cause any trouble
;;; when used interactively. Alas, the compiler doesn't understand this fact...
  ((make-mask (id ...))
   (make-mask ((id '()) ...)) )) )