bufmac.lisp 6.88 KB
Newer Older
ram's avatar
ram committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-

;;; This file contains macro definitions for the BUFFER object for Common-Lisp
;;; X windows version 11

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
fgilham's avatar
fgilham committed
21

ram's avatar
ram committed
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
(in-package :xlib)

;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.

(defmacro write-card8 (byte-index item)
  `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))

(defmacro write-int8 (byte-index item)
  `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))

(defmacro write-card16 (byte-index item)
  #+clx-overlapping-arrays
  `(aset-card16 (the card16 ,item) buffer-wbuf
		(index+ buffer-woffset (index-ash ,byte-index -1)))
  #-clx-overlapping-arrays
  `(aset-card16 (the card16 ,item) buffer-bbuf
		(index+ buffer-boffset ,byte-index)))

(defmacro write-int16 (byte-index item)
  #+clx-overlapping-arrays
  `(aset-int16 (the int16 ,item) buffer-wbuf
	       (index+ buffer-woffset (index-ash ,byte-index -1)))
  #-clx-overlapping-arrays
  `(aset-int16 (the int16 ,item) buffer-bbuf
	       (index+ buffer-boffset ,byte-index)))

(defmacro write-card32 (byte-index item)
  #+clx-overlapping-arrays
  `(aset-card32 (the card32 ,item) buffer-lbuf
		(index+ buffer-loffset (index-ash ,byte-index -2)))
  #-clx-overlapping-arrays
  `(aset-card32 (the card32 ,item) buffer-bbuf
		(index+ buffer-boffset ,byte-index)))

(defmacro write-int32 (byte-index item)
  #+clx-overlapping-arrays
  `(aset-int32 (the int32 ,item) buffer-lbuf
	       (index+ buffer-loffset (index-ash ,byte-index -2)))
  #-clx-overlapping-arrays
  `(aset-int32 (the int32 ,item) buffer-bbuf
	       (index+ buffer-boffset ,byte-index)))

(defmacro write-card29 (byte-index item)
  #+clx-overlapping-arrays
  `(aset-card29 (the card29 ,item) buffer-lbuf
		(index+ buffer-loffset (index-ash ,byte-index -2)))
  #-clx-overlapping-arrays
  `(aset-card29 (the card29 ,item) buffer-bbuf
		(index+ buffer-boffset ,byte-index)))
ram's avatar
ram committed
71 72 73 74 75 76 77 78 79 80 81

;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries
;; and always are written high-order byte first.
(defmacro write-char2b (byte-index item)
  ;; It is impossible to do an overlapping write, so only nonoverlapping here.
  `(let ((%item ,item)
	 (%byte-index (index+ buffer-boffset ,byte-index)))
     (declare (type card16 %item)
	      (type array-index %byte-index))
     (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index)
     (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1))))
ram's avatar
ram committed
82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122

(defmacro set-buffer-offset (value &environment env)
  env
  `(let ((.boffset. ,value))
     (declare (type array-index .boffset.))
     (setq buffer-boffset .boffset.)
     #+clx-overlapping-arrays
     ,@(when (member 16 (macroexpand '(%buffer-sizes) env))
	 `((setq buffer-woffset (index-ash .boffset. -1))))
     #+clx-overlapping-arrays
     ,@(when (member 32 (macroexpand '(%buffer-sizes) env))
	 `((setq buffer-loffset (index-ash .boffset. -2))))
     #+clx-overlapping-arrays
     .boffset.))

(defmacro advance-buffer-offset (value)
  `(set-buffer-offset (index+ buffer-boffset ,value)))

(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
  (unless (listp sizes) (setq sizes (list sizes)))
  `(let ((%buffer ,buffer))
     (declare (type display %buffer))
     ,(declare-bufmac)
     ,(when length
	`(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer))
	   (buffer-flush %buffer)))
     (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer))))
	    #-clx-overlapping-arrays
	    (buffer-bbuf (buffer-obuf8 %buffer))
	    #+clx-overlapping-arrays
	    ,@(append
		(when (member 8 sizes)
		  `((buffer-bbuf (buffer-obuf8 %buffer))))
		(when (or (member 16 sizes) (member 160 sizes))
		  `((buffer-woffset (index-ash buffer-boffset -1))
		    (buffer-wbuf (buffer-obuf16 %buffer))))
		(when (member 32 sizes)
		  `((buffer-loffset (index-ash buffer-boffset -2))
		    (buffer-lbuf (buffer-obuf32 %buffer))))))
       (declare (type array-index buffer-boffset))
       #-clx-overlapping-arrays
ram's avatar
ram committed
123
       (declare (type buffer-bytes buffer-bbuf))
ram's avatar
ram committed
124 125 126
       #+clx-overlapping-arrays
       ,@(append
	   (when (member 8  sizes)
ram's avatar
ram committed
127
	     '((declare (type buffer-bytes buffer-bbuf))))
ram's avatar
ram committed
128 129
	   (when (member 16 sizes)
	     '((declare (type array-index buffer-woffset))
ram's avatar
ram committed
130
	       (declare (type buffer-words buffer-wbuf))))
ram's avatar
ram committed
131 132
	   (when (member 32 sizes)
	     '((declare (type array-index buffer-loffset))
ram's avatar
ram committed
133
	       (declare (type buffer-longs buffer-lbuf)))))
ram's avatar
ram committed
134 135 136 137 138 139 140 141
       buffer-boffset
       #-clx-overlapping-arrays
       buffer-bbuf
       #+clx-overlapping-arrays
       ,@(append
	   (when (member 8  sizes) '(buffer-bbuf))
	   (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
	   (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
ram's avatar
ram committed
142
       #+clx-overlapping-arrays
ram's avatar
ram committed
143
       (macrolet ((%buffer-sizes () ',sizes))
ram's avatar
ram committed
144 145 146
	 ,@body)
       #-clx-overlapping-arrays
       ,@body)))
ram's avatar
ram committed
147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184

;;; This macro is just used internally in buffer

(defmacro writing-buffer-chunks (type args decls &body body)
  (when (> (length body) 2)
    (error "writing-buffer-chunks called with too many forms"))
  (let* ((size (* 8 (index-increment type)))
	 (form #-clx-overlapping-arrays
	       (first body)
	       #+clx-overlapping-arrays		; XXX type dependencies
	       (or (second body)
		   (first body))))
    `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
       ;; Loop filling the buffer
       (do* (,@args
	     ;; Number of bytes needed to output
	     (len ,(if (= size 8)
		       `(index- end start)
		       `(index-ash (index- end start) ,(truncate size 16)))
		  (index- len chunk))
	     ;; Number of bytes available in buffer
	     (chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
		    (index-min len (index- (buffer-size buffer) buffer-boffset))))
	    ((not (index-plusp len)))
	 (declare ,@decls
		  (type array-index len chunk))
	 ,form
	 (index-incf buffer-boffset chunk)
	 ;; Flush the buffer
	 (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer)))
	   (setf (buffer-boffset buffer) buffer-boffset)
	   (buffer-flush buffer)
	   (setq buffer-boffset (buffer-boffset buffer))
	   #+clx-overlapping-arrays
	   ,(case size
	      (16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
	      (32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
       (setf (buffer-boffset buffer) (lround buffer-boffset)))))