;;;
;;;              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/types.sc,v 1.4 90/04/01 13:51:29 johani Exp $

;;; types.sc -- converters from the different datatypes used by the X
;;;             protocol to lists of integers. The integers should be in the
;;;             range 0..255 for subsequent conversion to characters.
;;;
;;;             We have a possible problem with byte-order, here it is 
;;;             hard-wired to LSB first, as that is the way of the R2000.
;;;

(module types (top-level))

(include "../include/util.sch")
(include "../include/masks.sch")
(include "../include/objects.sch")
(include "../include/lw-objects.sch")
(include "../include/lowlevel.sch")

(include "../macros/extend-syntax.sc")		; Needed by mask-object.sc
(include "../macros/mask-object.sc")

(define (a-listofvalue listofvalue buffer)
  (listofvalue buffer) )

;;; a-intlist -- assembles a list of small (one byte) integers -- for those
;;;              functions that still generate lists of ints.
(define (a-intlist l buffer)
  (a-string8 (list->string (map integer->char
				l))
	     buffer))

(define a-bitmask a-card32)

;;; Ideally these types (the ones mapped on X resources) should always work on
;;; objects, but that is not practical as we then would have to create dummy
;;; objects to match things like 'None 'CopyFromParent and so on. Therefore
;;; they work on numbers as well, at a slight performace penalty.
;;;
(define a-window    (lambda (o buffer)
		      (a-card32 (if (procedure? o)
				    (o 'id)
				    o)
				buffer)))
(define (a-window-or-none w buffer)
 (if (eq? w 'None)
     (a-card32 0 buffer)
     (a-window w buffer) ))

(define a-pixmap   a-window)
(define a-cursor   a-window)

(define (a-cursor-or-none c buffer)
  (if (eq? c 'None)
      (a-card32 0 buffer)
      (a-cursor c buffer) ))

(define a-font     a-window)
(define a-gcontext a-window)
(define a-colormap a-window)
(define a-drawable a-window)
(define a-fontable a-window)
(define a-atom     a-card32)
(define a-visualid a-window)
(define a-resource a-window)

(define a-timestamp (lambda (t buffer)
		      (a-card32 (if (eq? t 'CurrentTime)
				    0
				    t)
				buffer)))

(define a-keysym a-card32)

;;; color is a new datatype that is special to SCIX. It replaces card32 in
;;; the X protocol when reffering to pixel values. This enables us to keep
;;; colors as objects as long as possible.
(define a-color (lambda (o buffer)
		(a-card32 (o 'pixel) buffer) ))

(define (a-bitmask16 x buffer)       ; Due to protocol error in req #12
  (if x
      (a-card16 x buffer)
      (a-card16 0 buffer) ))


(define a-bitgravity a-card8)		; Eg only 0..10
(define a-wingravity a-card8)		; Eg only 0..10
(define a-setofevent a-card32)		; With some additional restrictions
(define a-setofpointerevent a-card16)	; With some additional restrictions (J)
(define a-setofdeviceevent a-card16)	; With some additional restrictions (J)
(define a-setofkeymask a-card16)	; (J)
(define a-setofkeybutmask a-card16)	; With some additional restrictions

;;; ...or CARD8's
(define a-keycode a-card8)
(define a-button  a-card8)
(define a-request a-card8)

(define (a-bool arg buffer)
  (cond ((eq? arg #t) (a-card8 1 buffer))
	((eq? arg #f) (a-card8 0 buffer))
	(else (error 'a-bool
		     "Argument does not evaluate to #t or #f: ~a" arg)) ))

(define a-string16 a-string8)

(define (a-point l buffer)
  (a-int16 (car l) buffer)
  (a-int16 (cadr l) buffer) )

(define (a-rectangle l buffer)
  (a-int16 (car l) buffer)
  (a-int16 (cadr l) buffer)
  (a-card16 (caddr l) buffer)
  (a-card16 (cadddr l) buffer) )

(define (a-arc l buffer)
  (a-int16 (car l) buffer)
  (a-int16  (cadr l) buffer)
  (a-card16 (caddr l) buffer)
  (a-card16 (cadddr l) buffer)
  (a-int16  (list-ref l 4) buffer)
  (a-int16  (list-ref l 5) buffer) )

;;; This is not really the best way to do it, but it will work until all
;;; intlists are gone.
(define (a-listofbyte l buffer)
  (cond ((pair? l) (a-intlist l buffer))
	((string? l) (a-string8 l buffer)) ))      

;;; A compound assembler type constructor.
(define (a-list type)
  (lambda (l buffer)
    (for-each (lambda (ls)
		(type ls buffer) )
	      l)))

;;;
;;; xdas type functions
;;;

(define (d-card8 str dpy)
  (get-next-byte! str) )

;;; NOTE! The following require sizeof(int) and sizeof(unsigned) to be 32,
;;;       sizeof(short) and sizeof(short unsigned) to be 16.

;;; d-const -- tries to parse a constant using the assoc-list clist. If
;;;            always-const is #t, an error is signaled if no constant
;;;            for the numeric value is found, otherwise it is parsed
;;;            normally. The latter case is often used when an id can
;;;            either be a resource or a constant eg, None.
(define (d-const always-const func clist)
  (lambda (str dpy)
    (if always-const			      ; Can it be an id or a constant?
	(let* ((val (func str dpy))
	       (pare (assv val clist)))
	  (if pare
	      (cdr pare)
	      (error 'd-const "No symbolic constant for value ~a" val) ))
	(let* ((val (peek-next-unsigned str)) ; Only card32 can have both.
	       (pare (assv val clist)) )
	  (if pare
	      (begin
		((gobble! 4) str dpy)         ; Read past the value.
		(cdr pare) )
	      (func str dpy) )))))

(define (d-card16 str dpy)
  (get-next-short-unsigned! str) )

(define (d-card32 str dpy)
  (get-next-unsigned! str) )

(define (d-int16 str dpy)
  (get-next-short! str) )

(define (d-int32 str dpy)
  (get-next-int! str) )

(define (d-drawable str dpy)
  (let ((id (d-card32 str dpy)))
    (cond (((dpy 'scix-id-vector) 'lookup id))
	  (else (error 'd-drawable "Unknown drawable id: ~a" id)) )))

;;; d-window -- Problem: what to do about the formal parameters to make-window
;;;             (width height depth x y parent)? Maybe they could be set to #f
;;;             or something to indicate "not known". This problem will arise
;;;             with other objects as well when the disassembler encounters
;;;             previously unknown id's.
;;;
(define (d-window str dpy)
  (let ((id (d-card32 str dpy)))
    (cond ((zero? id) 'None)
	  ((= id 1) 'PointerRoot)
	  (((dpy 'scix-id-vector) 'lookup id))	    ; Is this a known window?
	  (else (make-window #f #f #f #f #f #f #f #f #f dpy id)) )))

(define (d-pixmap str dpy)
  (let ((id (d-card32 str dpy)))
    (cond (((dpy 'scix-id-vector) 'lookup id))	 ; Is this a known pixmap?
	  (else (error 'd-pixmap "Unknown pixmap id: ~a" id)) )))

(define (d-colormap str dpy)
  (let ((id (d-card32 str dpy)))
    (cond ((zero? id) 'None)		         ; Colormaps can be 'None
	  (((dpy 'scix-id-vector) 'lookup id))	 ; Is this a known colormap?
	  (else (make-colormap dpy id)) )))

(define (d-cursor str dpy)
  (let ((id (d-card32 str dpy)))
    (cond (((dpy 'scix-id-vector) 'lookup id))	 ; Is this a known cursor?
	  (else (error 'd-cursor "Unknown cursor id: ~a" id)) )))

(define (d-font str dpy)
  (let ((id (d-card32 str dpy)))
    (cond (((dpy 'scix-id-vector) 'lookup id))	 ; Is this a known font?
	  (else (error 'd-font "Unknown font id: ~a" id)) )))

(define (d-gcontext str dpy)
  (let ((id (d-card32 str dpy)))
    (cond (((dpy 'scix-id-vector) 'lookup id))	 ; Is this a known gc?
	  (else (error 'd-gcontext "Unknown gcontext id: ~a" id)) )))

(define (d-fontable str dpy)
  (let ((id (d-card32 str dpy)))
    (cond (((dpy 'scix-id-vector) 'lookup id))   ; Is this a known "fontable"?
	  (else (error 'd-fontable "Unknown fontable id: ~a" id)))))

(define (d-atom str dpy)
  (let ((id (d-card32 str dpy)))
    (if (zero? id)
	'None
	((dpy 'atombox) 'lookup-name id) ))) ; Was (lookup-atomname id)

(define (d-visualid str dpy)
  (let ((id (d-card32 str dpy)))
    (cond (((dpy 'scix-id-vector) 'lookup id))	 ; Is this a known visualid?
	  (else id) )))

(define (d-timestamp str dpy)
  (let ((t (d-card32 str dpy)))
    (if (zero? t)
	'CurrentTime
	t) ))

;;; Several types are really CARD32's...
(define d-keysym  d-card32)

;;; ...or CARD8's
(define d-byte    d-card8)
(define d-keycode d-card8)
(define d-button  d-card8)

;;; This is cheating a bit...
(define d-int8 d-card8)

(define (d-bool str dpy)
  (not (zero? (d-card8 str dpy))) )

(define (d-bitgravity str dpy)
  ((d-const #t d-card8
	    '((0 . Forget)
	      (1 . NorthWest)
	      (2 . North)
	      (3 . NorthEast)
	      (4 . West)
	      (5 . Center)
	      (6 . East)
	      (7 . SouthWest)
	      (8 . South)
	      (9 . SouthEast)
	      (10 . Static) ))
   str dpy))

(define (d-wingravity str dpy)
  ((d-const #t d-card8
	    '((0 . Unmap)
	      (1 . NorthWest)
	      (2 . North)
	      (3 . NorthEast)
	      (4 . West)
	      (5 . Center)
	      (6 . East)
	      (7 . SouthWest)
	      (8 . South)
	      (9 . SouthEast)
	      (10 . Static) ))
   str dpy))

;;; masks...
(define (d-bitmask str dpy)		; Only used in event ConfigureRequest
  (let ((val (d-card32 str dpy))	; (event #23)
	(mask-obj (make-mask
		   (x y width height border-width sibling stack-mode) )))
    (mask-obj 'set-mask! val)
    mask-obj))

(define (d-setofevent str dpy)
  (let ((val (d-card32 str dpy))
	(mask-obj (make-event-mask)) )
    (mask-obj 'set-mask! val)
    mask-obj))

(define (d-setofpointerevent str dpy)
  (let ((val (d-card32 str dpy))
	(mask-obj (make-pointerevent-mask)) )
    (mask-obj 'set-mask! val)
    mask-obj))

(define (d-setofdeviceevent str dpy)
  (let ((val (d-card32 str dpy))
	(mask-obj (make-deviceevent-mask)) )
    (mask-obj 'set-mask! val)
    mask-obj))

(define (d-setofkeybutmask str dpy)
  (let ((val (d-card16 str dpy))
	(mask-obj (make-keybutmask-mask)) )
    (mask-obj 'set-mask! val)
    mask-obj))

(define (d-string8 len str dpy)
  (let* ((string-pos (c-input-string-pos str))         ; Position of string
	 (end-pos (+ string-pos len))                  ; End of string
	 (tmpbyte (c-byte-ref (c-input-string-string str)
			      end-pos))                ; Byte after string
	 (pad (modulo (- 4 (modulo len 4)) 4))         ; Amount of padding
	 (result '()))
    (c-byte-set! (c-input-string-string str)
		 end-pos
		 0)                                    ; Add NUL-byte
    (set! result (c-string->string
		  (+ (c-input-string-string str)
		     string-pos )))                    ; Get the string
    (c-byte-set! (c-input-string-string str)
		 end-pos
		 tmpbyte)                              ; Reset last byte
    (set-c-input-string-pos! str (+ pad end-pos))      ; Update position
    result ))                                          ; Return the string

(define (d-str str dpy)
  (let* ((len (get-next-byte! str))
	 (string-pos (c-input-string-pos str))
	 (end-pos (+ string-pos len))
	 (tmpbyte (c-byte-ref (c-input-string-string str)
			      end-pos))
	 (result '()) )
    (c-byte-set! (c-input-string-string str)
		 end-pos
		 0)                                    ; Add NUL-byte
    (set! result (c-string->string
		  (+ (c-input-string-string str)
		     string-pos )))                    ; Get the string
    (c-byte-set! (c-input-string-string str)
		 end-pos
		 tmpbyte)                              ; Reset last byte
    (set-c-input-string-pos! str end-pos)              ; Update position
    result ))                                          ; Return the string

;;; d-host -- Only used in ListHosts-reply, so it could preferrably be
;;;           declared inline. It is correct for IP addresses, but not for
;;;           DECnet ditto.
(define (d-host str dpy)
  (let* ((domain (lookup-constant
		  (get-next-byte! str)
		  '((0 . Internet)
		    (1 . DECnet)
		    (2 . Chaos) )))
	 (unused (get-next-byte! str))
	 (addr-len (d-card16 str dpy))
	 (addr (let loop ((n addr-len) (r '()))
		 (if (zero? n)
		     r
		     (loop (- n 1) 
			   (append r (list (get-next-byte! str))) )))) )
    (if (eq? domain 'DECnet)
	(let ((node-nr (bit-or (bit-lsh (bit-and 3 (cadr addr)) 8)
			       (car addr) ))
	      (area (bit-rsh (bit-and (cadr addr) 252) 2)) )
	  (set! addr (list addr (list area node-nr)) )))
    (list domain addr) ))

;;; d-list -- a compound disassembler type constructor.
(define (d-list type len)
  (lambda (str dpy)
    (let loop ((n len) (result '()))
      (if (or (end-of-input-string? str)
	      (zero? n) )
	  result
	  (loop (- n 1) (append result (list (type str dpy)))) ))))

;;; 
(define (d-object type)
  (lambda (str dpy)
    (let ((val (type str dpy)))
      (lambda ()
	val))))

;;; gobble! -- creates a procedure which strips off n bytes from its argument
;;;            when called.
;;; Note: It should perhaps change name to d-unused?
(define (gobble! n)
  (lambda (str dpy)
    (set-c-input-string-pos! str (+ (c-input-string-pos str) n)) ))