;;;
;;;              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/util.sc,v 1.3 90/04/01 13:51:36 johani Exp $

;;; util.sc -- Utilities used by various SCIX routines.
;;;

(module util)

(include "../include/types.sch")
(define-external x-protocol-atoms global)

;;; byte-order -- returns #x6c if the processor has least significant byte
;;;               first, #x42 otherwise. The choice of returned values is
;;;               due to the fact that these values are the ones sent to
;;;               the X-server when a connection is requested representing
;;;               LSB first and MSB first respectively.
(define (byte-order)
  (let* ((indian 1) (old-val (scheme-int-ref 'indian 0)))
    (scheme-int-set! 'indian 0 1)	; Change the value...
    (let ((result (scheme-byte-ref 'indian 0))) ; Get first byte.
      (scheme-int-set! 'indian 0 old-val) ; ...and restore it.
      (if (zero? result)		; MSB is zero, thus if the
	  #x42				; First byte is zero we have MSB first
	  #x6c ))))			; else LSB first.

;;; Routines for handling length-tagged c-strings and the schemeified version
;;; consisting of a pair ((<current position> . <total length>) . <c-pointer>)

;;; selectors.
(define c-input-string-string cdr)
(define c-input-string-pos caar)
(define c-input-string-length cdar)
(define c-input-string-info car)

;;; mutator
(define (set-c-input-string-pos! the-pair new-pos)
  (set-car! (car the-pair) new-pos) )

;;; predicate
(define (end-of-input-string? the-pair)
  (>= (caar the-pair)
      (cdar the-pair) ))

;;; get-next-byte! -- returns bytes sequentially from a c-pointer. Takes an 
;;;                   argument created by 'make-c-input-string'.
(define (get-next-byte! the-pair)
  (if (end-of-input-string? the-pair)
      #f
      (let ((result (c-byte-ref (c-input-string-string the-pair)
				(c-input-string-pos the-pair) )))
	(set-car! (c-input-string-info the-pair)
		  (+ (c-input-string-pos the-pair) 1) )
	result )))

;;; get-next-int! -- returns next int from a c-input-string.
(define (get-next-int! the-pair)
  (if (end-of-input-string? the-pair)
      #f
      (let ((result (c-int-ref (c-input-string-string the-pair)
			       (c-input-string-pos the-pair) )))
	(set-car! (c-input-string-info the-pair)
		  (+ (c-input-string-pos the-pair) 4) )
	result )))

;;; get-next-unsigned! -- returns next unsigned from a c-input-string.
(define (get-next-unsigned! the-pair)
  (if (end-of-input-string? the-pair)
      #f
      (let ((result (c-unsigned-ref (c-input-string-string the-pair)
				    (c-input-string-pos the-pair) )))
	(set-car! (c-input-string-info the-pair)
		  (+ (c-input-string-pos the-pair) 4) )
	result )))

;;; peek-next-unsigned -- returns next unsigned that will be read from a
;;;                       c-input-string without updating position.
(define (peek-next-unsigned the-pair)
  (if (end-of-input-string? the-pair)
      #f
      (c-unsigned-ref (c-input-string-string the-pair)
		      (c-input-string-pos the-pair) )))

;;; get-next-short! -- returns next unsigned from a c-input-string.
(define (get-next-short! the-pair)
  (if (end-of-input-string? the-pair)
      #f
      (let ((result (c-shortint-ref (c-input-string-string the-pair)
				 (c-input-string-pos the-pair) )))
	(set-car! (c-input-string-info the-pair)
		  (+ (c-input-string-pos the-pair) 2) )
	result )))

;;; get-next-short-unsigned! -- returns next unsigned from a c-input-string.
(define (get-next-short-unsigned! the-pair)
  (if (end-of-input-string? the-pair)
      #f
      (let ((result (c-shortunsigned-ref (c-input-string-string the-pair)
					 (c-input-string-pos the-pair) )))
	(set-car! (c-input-string-info the-pair)
		  (+ (c-input-string-pos the-pair) 2) )
	result )))

;;; peek-byte -- returns byte nr from c-input-string str without side-effects.
(define (peek-byte str nr)
  (let ((the-pos (+ (c-input-string-pos str) nr)))
    (if (> the-pos (c-input-string-length str))
	#f
	(c-byte-ref (c-input-string-string str) the-pos)  )))

;;; peek-next-byte -- returns the next byte that would be returned by
;;;                   get-next-byte! Does not have any side-effects.
(define (peek-next-byte the-pair)
  (peek-byte the-pair 0) )

;;; make-c-input-string -- given a c-pointer and a length, returns a structure
;;;                        appropriate for get-c-byte.
(define (make-c-input-string pntr len)
  (cons (cons 0 len) pntr) )

;;; convert-length-tagged-string -- given a c-pointer pointing to a buffer 
;;;                                 containing <amount of bytes><the bytes>,
;;;                                 returns a structure appropriate for
;;;                                 next-c-byte.
(define (convert-length-tagged-string pntr)
  (make-c-input-string (+ pntr 4)
		       (c-int-ref pntr 0) ))

;;; lookup-constant -- return the value c as found in the alist.
;;; Note: The warning should probably be an error instead.
(define (lookup-constant c alist)
  (if (symbol? c)
      (let ((r (assoc c alist)))
	(if r
	    (cdr r)
	    (begin 
	      (format #t
      "Warning: lookup-constant: Substituting 0 for unknown constant ~a~%" c)
	      0)))
      c))

;;; s8->s16 -- converts a string8 to a string16 (I think)
(define (s8->s16 string)
  (let ((l (string->list string)))
    (list->string (apply append (map (lambda (e)
				       (list (integer->char 0) e))
				     l)))))

(define (remove-unused als)
  (let loop ((ls als))
    (let ((the-pair (assq 'unused ls)))
      (if the-pair
	  (loop (remq the-pair ls))
	  ls) )))	

;;; flatmap
(define (flatmap fun l)
  (flatten (map fun l)))

(define (flatten l)
  (if (null? l)
      '()
      (append (car l) (flatten (cdr l))) ))

;;; Used in HWOOPS
(define (filter pred l)
  (if (null? l)
      '()
      (let ((el (car l)))
	(if (pred el)
	    (cons el (filter pred (cdr l)))
	    (filter pred (cdr l))))))

;;; Used in HWOOPS
(define (remove-dup l)
  (let loop ((l l) (result '()))
    (if (null? l)
	result
	(let* ((f (car l))
	       (r (cdr l))
	       (m (car f)))
	  (if (assq m result)
	      (loop r result)
	      (if (assq m r)
		  (loop r (append result (list (cons m #f))))
		  (loop r (append result (list f)))))))))

;;; Used in HWOOPS
(define (common-id? l)
  (define (f l)
    (if (null? l)
	#f
	(let ((val (memq (car l) (cdr l))))
	  (if val
	      (car val)
	      (f (cdr l))))))
  (f (flatten l)) )

;;; Tree-copy and list-copy are not included in Scheme->C.
(define (tree-copy tr)
  (if (not (pair? tr))
      tr
      (cons (tree-copy (car tr))
	    (tree-copy (cdr tr)) )))

;;; This list-copy can deal with improper lists.
(define (list-copy ls)
  (cond ((null? ls) '())
	((pair? ls) (cons (car ls)
			  (list-copy (cdr ls)) ))
	(else ls) ))

;;; rem-dupl-name -- used by define-class
(define (rem-dupl-name l1 l2)
    (define (rem-dup l rem-all)
	(if (null? l)
	    '()
	    (let ((m (car l)))
		(if (memq m (cdr l))
		    (let ((r (rem-dup (remq m (cdr l)) rem-all)))
			(if rem-all r (cons m r)))
		    (cons m (rem-dup (cdr l) rem-all))))))
    (rem-dup (append l1 (rem-dup l2 #t)) #f))

;;; list-pad4 -- pads the list l with (pad (length l)) zeroes at the end.
(define (list-pad4 l)
  (let ((p (modulo (- 4 (modulo (length l) 4)) 4)))
    (append l
	    (cdr (assoc p 
			'((0 . ()) (1 . (0)) (2 . (0 0)) (3 . (0 0 0)))))) ))

;;; pad -- returns the amount of padding needed after a string of length n
(define (pad n)
  (modulo (- 4 (modulo n 4)) 4) )

(include "mktext.sc")

(include "mkatom.sc")

;;; A small handy predicate that extracts the color status of the hardware.
(define (color-screen? scr)
  (let* ((a-d (scr 'allowed-depths))
	 (visuals (flatmap (lambda (d)
			     (d 'visuals) )
			   a-d))
	 (classes (map (lambda (o)
			 (o 'class) )
		       visuals)))
    (or (memq 'directcolor classes)
	(memq 'pseudocolor classes)
	(memq 'truecolorcolor classes) )))
  
;;; strip-object is used to extract the optional unparsed object sent through
;;; the X assembler (in the display object).
(define (strip-object obj)
  (if (and (pair? obj) (null? (cdr obj)))
      (strip-object (car obj))
      obj))