Commit a6ecd9e2 authored by ram's avatar ram

CLX R5 changes.

parent e80028ff
This diff is collapsed.
......@@ -29,8 +29,8 @@ compiled with (make-system "CLX" :compile :noconfirm) and loaded with
For Lucid systems, you should rename all the .l files to .lisp too (This might
not be possible on SysV systems). After loading the defsystem.l file, CLX can
be compiled with the (xlib:compile-clx) function and loaded with the
(xlib:load-clx) form.
be compiled with the (compile-clx) function and loaded with the
(load-clx) form.
The ms-patch.uu file is a patch to Lucid version 2 systems. You probably
don't need it, as you are probably running Lucid version 3 or later, but if
......@@ -40,7 +40,7 @@ uudecode it to produce the binary.
For kcl systems, after loading the defsystem.l file, CLX can be compiled with
the (xlib:compile-clx) function and loaded with the (xlib:load-clx) form.
the (compile-clx) function and loaded with the (load-clx) form.
......
......@@ -42,39 +42,6 @@
(in-package :xlib)
(export '(
with-state
window-visual-info
window-visual
window-class
window-background ;; setf only
window-border
window-bit-gravity
window-gravity
window-backing-store
window-backing-planes
window-backing-pixel
window-save-under
window-override-redirect
window-event-mask
window-do-not-propagate-mask
window-colormap
window-cursor
window-colormap-installed-p
window-all-event-masks
window-map-state
drawable-root
drawable-x
drawable-y
drawable-width
drawable-height
drawable-depth
drawable-border-width
window-priority
))
(eval-when (compile load eval) ;needed by Franz Lisp
(defconstant *attribute-size* 44)
(defconstant *geometry-size* 24)
......
This diff is collapsed.
......@@ -68,6 +68,17 @@
#-clx-overlapping-arrays
`(aset-card29 (the card29 ,item) buffer-bbuf
(index+ buffer-boffset ,byte-index)))
;; 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))))
(defmacro set-buffer-offset (value &environment env)
env
......@@ -132,8 +143,11 @@
(when (member 8 sizes) '(buffer-bbuf))
(when (member 16 sizes) '(buffer-woffset buffer-wbuf))
(when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
#+clx-overlapping-arrays
(macrolet ((%buffer-sizes () ',sizes))
,@body))))
,@body)
#-clx-overlapping-arrays
,@body)))
;;; This macro is just used internally in buffer
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -20,22 +20,6 @@
(in-package :xlib)
(export '(
with-display
with-event-queue
open-display
display-force-output
close-display
display-protocol-version
display-vendor
display-roots
display-motion-buffer-size
display-max-request-length
display-error-handler
display-after-function
display-invoke-after-function
display-finish-output))
;;
;; Resource id management
;;
......@@ -61,12 +45,11 @@
(defmacro allocate-resource-id (display object type)
;; Allocate a resource-id for OBJECT in DISPLAY
`(the resource-id
,(if (member (eval type) *clx-cached-types*)
`(let ((id (funcall (display-xid ,display) ,display)))
(save-id ,display id ,object)
id)
`(funcall (display-xid ,display) ,display))))
(if (member (eval type) *clx-cached-types*)
`(let ((id (funcall (display-xid ,display) ,display)))
(save-id ,display id ,object)
id)
`(funcall (display-xid ,display) ,display)))
(defmacro deallocate-resource-id (display id type)
;; Deallocate a resource-id for OBJECT in DISPLAY
......@@ -142,9 +125,7 @@
(declare (type xatom atom)
(type display display))
(declare (values (or null resource-id)))
(gethash (if (keywordp atom)
atom
(kintern atom))
(gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
(display-atom-cache display)))
(defun set-atom-id (atom display id)
......@@ -153,8 +134,7 @@
(type display display)
(type resource-id id))
(declare (values resource-id))
(let ((atom (if (keywordp atom) atom (kintern atom))))
(declare (type keyword atom))
(let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
(setf (gethash id (display-atom-id-map display)) atom)
(setf (gethash atom (display-atom-cache display)) id)
id))
......@@ -162,9 +142,7 @@
(defsetf atom-id set-atom-id)
(defun initialize-predefined-atoms (display)
(do ((i 1 (1+ i))
(end (length *predefined-atoms*)))
((>= i end))
(dotimes (i (length *predefined-atoms*))
(declare (type resource-id i))
(setf (atom-id (svref *predefined-atoms* i) display) i)))
......@@ -214,7 +192,7 @@
,@body)))
,(if (and (null inline) (macroexpand '(use-closures) env))
`(flet ((.with-event-queue-body. () ,@body))
#+ansi-common-lisp
#+clx-ansi-common-lisp
(declare (dynamic-extent #'.with-event-queue-body.))
(with-event-queue-function
,display ,timeout #'.with-event-queue-body.))
......@@ -230,7 +208,10 @@
(declare (type display display)
(type (or null number) timeout)
(type function function)
(downward-funarg function))
#+clx-ansi-common-lisp
(dynamic-extent function)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg function))
(with-event-queue (display :timeout timeout :inline t)
(funcall function)))
......@@ -258,7 +239,8 @@
;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
(let* ((stream (open-x-stream host display protocol))
(disp (apply #'make-buffer
#x2000 'make-display-internal
*output-buffer-size*
'make-display-internal
:host host
:display display
:output-stream stream
......@@ -358,6 +340,7 @@
(string-get vendor-length 0 :reply-buffer reply-buffer))
;; Initialize the pixmap formats
(dotimes (i num-formats) ;; loop gathering pixmap formats
(declare (ignorable i))
(buffer-input display buffer-bbuf 0 8)
(push (make-pixmap-format :depth (card8-get 0)
:bits-per-pixel (card8-get 1)
......@@ -368,12 +351,14 @@
(nreverse (display-pixmap-formats display)))
;; Initialize the screens
(dotimes (i num-roots)
(declare (ignorable i))
(buffer-input display buffer-bbuf 0 40)
(let* ((root (make-window :id (card32-get 0) :display display))
(let* ((root-id (card32-get 0))
(root (make-window :id root-id :display display))
(root-visual (card32-get 32))
(default-colormap-id (card32-get 4))
(default-colormap
(make-colormap :id (card32-get 4)
:display display))
(make-colormap :id default-colormap-id :display display))
(screen
(make-screen
:root root
......@@ -393,14 +378,17 @@
(num-depths (card8-get 39))
(depths nil))
;; Save root window for event reporting
(save-id display (window-id root) root)
(save-id display root-id root)
(save-id display default-colormap-id default-colormap)
;; Create the depth AList for a screen, (depth . visual-infos)
(dotimes (j num-depths)
(declare (ignorable j))
(buffer-input display buffer-bbuf 0 8)
(let ((depth (card8-get 0))
(num-visuals (card16-get 2))
(visuals nil)) ;; 4 bytes unused
(dotimes (k num-visuals)
(declare (ignorable k))
(buffer-input display buffer-bbuf 0 24)
(let* ((visual (card32-get 0))
(visual-info (make-visual-info
......
......@@ -183,9 +183,6 @@
(deftype array-index () `(integer 0 ,array-dimension-limit))
(deftype real (&optional (min '*) (max '*))
`(or (real ,min ,max) (rational ,min ,max)))
;; An association list.
(deftype alist (key-type-and-name datum-type-and-name) 'list)
......@@ -1960,7 +1957,7 @@
(boolean same-screen-p)
(int16 x y root-x root-y)
(card16 state)
(card32 time)
((or null card32) time)
;; for key-press and key-release, code is the keycode
;; for button-press and button-release, code is the button number
(card8 code))
......@@ -1972,7 +1969,7 @@
(boolean same-screen-p)
(int16 x y root-x root-y)
(card16 state)
(card32 time)
((or null card32) time)
(boolean hint-p))
(declare-event (:enter-notify :leave-notify)
......@@ -1982,7 +1979,7 @@
(boolean same-screen-p)
(int16 x y root-x root-y)
(card16 state)
(card32 time)
((or null card32) time)
((member :normal :grab :ungrab) mode)
((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind)
(boolean focus-p))
......@@ -2094,27 +2091,27 @@
(window (window event-window))
(keyword atom)
((member :new-value :deleted) state)
(card32 time))
((or null card32) time))
(declare-event :selection-clear
(card16 sequence)
(window (window event-window))
(keyword selection)
(card32 time))
((or null card32) time))
(declare-event :selection-request
(card16 sequence)
(window (window event-window) requestor)
(keyword selection target)
((or null keyword) property)
(card32 time))
((or null card32) time))
(declare-event :selection-notify
(card16 sequence)
(window (window event-window))
(keyword selection target)
((or null keyword) property)
(card32 time))
((or null card32) time))
(declare-event :colormap-notify
(card16 sequence)
......@@ -2176,11 +2173,10 @@
(values (list string))))
(defsetf wm-command (window) (command)
;; Uses PRIN1 to a string-stream with the following bindings:
;; (*print-length* nil) (*print-level* nil) (*print-radix* nil)
;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp))
;; each element of command is seperated with NULL characters.
;; This enables (mapcar #'read-from-string (wm-command window))
;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
;; equivalent), with elements of command separated by NULL characters. This
;; enables
;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
;; to recover a lisp command.
(declare (type window window)
(type (list stringable) command)))
......@@ -2276,8 +2272,8 @@
name icon-name resource-name resource-class command
hints normal-hints
;; the following are used for wm-normal-hints
user-specified-position-p
user-specified-size-p
user-specified-position-p user-specified-size-p
program-specified-position-p program-specified-size-p
min-width min-height max-width max-height
width-inc height-inc min-aspect max-aspect
base-width base-height win-gravity
......@@ -2290,7 +2286,8 @@
(type (or null list) command)
(type (or null wm-hints) hints)
(type (or null wm-size-hints) normal-hints)
(type (or null boolean) user-specified-position-p user-specified-size-p)
(type boolean user-specified-position-p user-specified-size-p)
(type boolean program-specified-position-p program-specified-size-p)
(type (or null card16) min-width min-height max-width max-height width-inc height-inc base-width base-height win-gravity)
(type (or null number) min-aspect max-aspect)
(type (or null (member :off :on)) input)
......@@ -2397,7 +2394,7 @@
;; when mask and modifiers aren't lists of keysyms]
;; The default is #'default-keysym-translate
;;
(declare (type (or string-char t) object)
(declare (type (or base-char t) object)
(type keysym keysym)
(type (or null mask16 list) ;; (list (or keysym state-mask-key))
modifiers)
......@@ -2415,7 +2412,7 @@
(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)
;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
(declare (type (or string-char t) object)
(declare (type (or base-char t) object)
(type keysym keysym)
(type (or null mask16 list) ;; (list (or keysym state-mask-key))
modifiers)
......@@ -2424,7 +2421,7 @@
(defun default-keysym-translate (display state object)
;; If object is a character, char-bits are set from state.
;; If object is a list, it is an alist with entries:
;; (string-char [modifiers] [mask-modifiers)
;; (base-char [modifiers] [mask-modifiers)
;; When MODIFIERS are specified, this character translation
;; will only take effect when the specified modifiers are pressed.
;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
......
#
# Makefile for CLX
# (X11 R4 release, Franz Allegro Common Lisp version)
# (X11 R4.4 release, Franz Allegro Common Lisp version)
#
# *************************************************************************
......@@ -37,69 +37,105 @@ SAFETY = 0
C_SRC = excldep.c socket.c
C_OBJS = excldep.o socket.o
L_OBJS = excldep.fasl defsystem.fasl depdefs.fasl clx.fasl dependent.fasl \
exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl display.fasl \
gcontext.fasl requests.fasl input.fasl fonts.fasl graphics.fasl \
text.fasl attributes.fasl translate.fasl keysyms.fasl manager.fasl \
image.fasl resource.fasl
L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \
dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \
display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \
graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \
manager.fasl image.fasl resource.fasl
L_NOMACROS_OBJS = excldep.fasl depdefs.fasl clx.fasl dependent.fasl \
buffer.fasl display.fasl gcontext.fasl \
L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \
dependent.fasl buffer.fasl display.fasl gcontext.fasl \
requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \
attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \
resource.fasl
L_SRC = defsystem.cl depdefs.cl clx.cl dependent.cl exclcmac.cl \
macros.cl bufmac.cl buffer.cl display.cl gcontext.cl \
requests.cl input.cl fonts.cl graphics.cl text.cl \
attributes.cl translate.cl keysyms.cl manager.cl image.cl \
resource.cl
L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \
dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \
display.cl gcontext.cl requests.cl input.cl fonts.cl \
graphics.cl text.cl attributes.cl translate.cl keysyms.cl \
manager.cl image.cl resource.cl
# default and aliases
all: no-clos
# all: partial-clos
compile-CLX-for-CLUE: compile-partial-clos-CLX
clue: partial-clos
all: $(C_OBJS) compile-CLX cat
#
# Three build rules are provided: no-clos, partial-clos, and full-clos.
# The first is no-clos, which results in a CLX whose datastructures are
# all defstructs. partial-clos results in xlib:window, xlib:pixmap, and
# xlib:drawable being CLOS instances, all others defstructs. full-clos
# makes all CLX complex datatypes into CLOS instances.
#
# (note that the :clos feature implies native CLOS *not* PCL).
#
clos: $(C_OBJS) compile-closified-CLX cat
no-clos: $(C_OBJS) compile-no-clos-CLX cat
CLX: $(C_OBJS) compile-CLX load-CLX
#
# This rule is used to compile CLX to be used with XCW version 2, or CLUE.
#
partial-clos: $(C_OBJS) compile-partial-clos-CLX cat
full-clos: $(C_OBJS) compile-full-clos-CLX cat
c: $(C_OBJS)
lisp: compile-CLX
c: $(C_OBJS)
compile-CLX: $(C_OBJS)
compile-no-clos-CLX: $(C_OBJS)
$(ECHO) " \
(set-case-mode :case-sensitive-lower) \
(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
(load \"defsystem\") \
#+allegro (compile-system :clx) \
#-allegro (compile-clx) \
#+allegro (compile-system :clx-debug)" \
| $(CL) $(CLOPTS) -batch
compile-partial-clos-CLX: $(C_OBJS)
$(ECHO) " \
(set-case-mode :case-sensitive-lower) \
(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
(compile-file-if-needed \"excldep\") \
(compile-file-if-needed \"defsystem\") \
(load \"defsystem\") \
#+allegro (compile-system :clx) \
#-allegro (xlib::compile-clx) \
#+allegro (compile-system :clx-debug)" \
| $(CL) $(CLOPTS) -batch
compile-closified-CLX: $(C_OBJS)
#+clos (set-case-mode :case-sensitive-lower) \
#-clos (setq excl::*print-nickname* t) \
(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
(unless (or (find-package 'clos) (find-package 'pcl)) \
(let ((spread (sys:gsgc-parameter :generation-spread))) \
(setf (sys:gsgc-parameter :generation-spread) 1) \
(require :pcl) \
(provide :pcl) \
(gc) (gc) \
(setf (sys:gsgc-parameter :generation-spread) spread))) \
#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
(load \"defsystem\") \
(load \"package\") \
(setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \
#+allegro (compile-system :clx) \
#-allegro (compile-clx \"\" \"\" :for-clue t) \
#+allegro (compile-system :clx-debug)" \
| $(CL) $(CLOPTS) -batch
compile-full-clos-CLX: $(C_OBJS)
$(ECHO) " \
(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
(setq excl::*print-nickname* t) \
(unless (or (find-package 'clos) (find-package 'pcl)) \
(let ((spread (sys:gsgc-parameter :generation-spread))) \
(setf (sys:gsgc-parameter :generation-spread) 1) \
(require :pcl) \
(provide :pcl) \
(gc) (gc) \
(setf (sys:gsgc-parameter :generation-spread) spread))) \
(compile-file-if-needed \"excldep\") \
(compile-file-if-needed \"defsystem\") \
(load \"defsystem\") \
#+allegro (compile-system :clx) \
#-allegro (xlib::compile-clx) \
#+allegro (compile-system :clx-debug)" \
| $(CL) $(CLOPTS) -batch
#+clos (set-case-mode :case-sensitive-lower) \
#-clos (setq excl::*print-nickname* t) \
(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
(unless (or (find-package 'clos) (find-package 'pcl)) \
(let ((spread (sys:gsgc-parameter :generation-spread))) \
(setf (sys:gsgc-parameter :generation-spread) 1) \
(require :pcl) \
(provide :pcl) \
(gc) (gc) \
(setf (sys:gsgc-parameter :generation-spread) spread))) \
#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
(load \"defsystem\") \
(load \"package\") \
(setq xlib::*def-clx-class-use-defclass* t) \
#+allegro (compile-system :clx) \
#-allegro (compile-clx \"\" \"\" :for-clue t) \
#+allegro (compile-system :clx-debug)" \
| $(CL) $(CLOPTS) -batch
cat:
......@@ -107,21 +143,20 @@ cat:
load-CLX:
$(ECHO) '(load "defsystem")' \
"(let (#+allegro (spread (sys:gsgc-parameter :generation-spread)))" \
" #+allegro (setf (sys:gsgc-parameter :generation-spread) 1)" \
" #+allegro (load-system :clx)" \
" #-allegro (xlib::load-clx)" \
" #+allegro (gc :tenure)" \
" #+allegro (setf (sys:gsgc-parameter :generation-spread) spread)" \
")" \
'#+allegro (gc t)' \
'(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \
'(exit)' | $(CL) $(CLOPTS)
$(ECHO) " \
(let ((spread (sys:gsgc-parameter :generation-spread))) \
(setf (sys:gsgc-parameter :generation-spread) 1) \
(load \"defsystem\") \
#+allegro (load-system :clx) \
#-allegro (load-clx) \
(gc :tenure) \
(setf (sys:gsgc-parameter :generation-spread) spread)) \
(gc t)" \
'(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \
"(exit)" | $(CL) $(CLOPTS)
clean:
$(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS)
$(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out
install:
......
This file contains instructions on how to make CLX work with Franz
Common Lisp. CLX should work on any machine that supports Allegro Common
Lisp version 3.0.1 or greater. It also works under ExCL version 2.0.10.
However it has been tested extensively with only Allegro CL versions 3.0
and 3.1.
However it has been tested extensively with only Allegro CL versions 3.0,
3.1, and 4.0.
There are three steps to compile and install CLX. The first is simply
moving files around. In this directory, execute (assuming you using csh):
......@@ -10,9 +10,6 @@ moving files around. In this directory, execute (assuming you using csh):
% foreach i (*.l */*.l)
? mv $i $i:r.cl
? end
% mkdir MIT
% mv defsystem.cl MIT
% mv excldefsys.cl defsystem.cl
% mv exclMakefile Makefile
The second is compiling the source files into fasl files. The fasl files
......
This diff is collapsed.
This diff is collapsed.
......@@ -18,14 +18,6 @@
(in-package :xlib)
(export '(
open-font
discard-font-info
close-font
list-font-names
list-fonts
font-path))
;; The char-info stuff is here instead of CLX because of uses of int16->card16.
; To allow efficient storage representations, the type char-info is not
......@@ -368,6 +360,7 @@
(card8-put 0 len)
(string-put 1 string :appending t :header-length 1)
(incf buffer-boffset (1+ len))))
(setf (buffer-boffset display) (lround buffer-boffset))))))
(setf (buffer-boffset display) (lround buffer-boffset)))))
paths)
(defsetf font-path set-font-path)
;;; -*- Package: XLIB; Log: clx.log -*-
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; GContext
......@@ -44,41 +44,6 @@
(in-package :xlib)
(export '(force-gcontext-changes
with-gcontext
create-gcontext
copy-gcontext-components
copy-gcontext
free-gcontext
gcontext-function
gcontext-plane-mask
gcontext-foreground
gcontext-background
gcontext-line-width
gcontext-line-style
gcontext-cap-style
gcontext-join-style
gcontext-fill-style
gcontext-fill-rule
gcontext-tile
gcontext-stipple
gcontext-ts-x
gcontext-ts-y
gcontext-font
gcontext-subwindow-mode
gcontext-exposures
gcontext-clip-x
gcontext-clip-y
gcontext-clip-mask
gcontext-dashes
gcontext-arc-mode
gcontext-dash-offset
gcontext-clip-ordering
define-gcontext-accessor
))
;; GContext state accessors
;; The state vector contains all card32s to speed server updating
......@@ -86,9 +51,6 @@
(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*))
;;; CMU Common Lisp's old compiler has a bug in compiling DEFCONSTANT's within
;;; MACROLET's.
#-CMU
(macrolet ((def-gc-internals (name &rest extras)
(let ((macros nil)
(indexes nil)
......@@ -124,44 +86,6 @@
(def-gc-internals ignore
(:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)))
#+CMU
(defmacro def-gc-internals (name &rest extras)
(let ((macros nil)
(indexes nil)
(masks nil)
(index 0))
(dolist (name *gcontext-components*)
(push `(defmacro ,(xintern 'gcontext-internal- name) (state)
`(svref ,state ,,index))
macros)
(setf (getf indexes name) index)
(push (ash 1 index) masks)
(incf index))
(dolist (extra extras)
(push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
`(svref ,state ,,index))
macros)
;; don't override already correct index entries
(unless (or (getf indexes (second extra)) (getf indexes (first extra)))
(setf (getf indexes (or (second extra) (first extra))) index))
(push (logior (ash 1 index)
(if (second extra)
(ash 1 (position (second extra) *gcontext-components*))
0))
masks)
(incf index))
`(within-definition (def-gc-internals ,name)
,@(nreverse macros)
(eval-when (eval compile load)
(defconstant *gcontext-data-length* ,index)
(defconstant *gcontext-indexes* ',indexes)
(defconstant *gcontext-masks*
',(coerce (nreverse masks) 'simple-vector))))))
#+CMU
(def-gc-internals ignore
(:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))
) ;; end EVAL-WHEN
(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*))
......@@ -617,16 +541,14 @@
(temp-var (gensym)))
(when value
(push `(,temp-var ,value) temp-vars)
(push #-CMU `(setf ,accessor ,temp-var)
#+CMU `(when ,temp-var (setf ,accessor ,temp-var))
setfs))))
(push `(when ,temp-var (setf ,accessor ,temp-var)) setfs))))
(if setfs
`(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
(copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
(declare (type gcontext ,gc)
(type (or null gcontext) ,temp-gc)
(type gcontext-state ,saved-state)
(type xgcmask ,temp-mask))
(type xgcmask ,temp-mask)
(type (or null resource-id) ,temp-gc))
(with-gcontext-bindings (,gc ,saved-state
,(append indexes extension-indexes)
,ts-index ,temp-mask ,temp-gc)
......@@ -833,7 +755,15 @@
(when dashes (setf (gcontext-dashes gcontext) dashes))
(setf (gcontext-internal-timestamp server-state) 1)
(setf (gcontext-internal-timestamp local-state) 1)
(setf (gcontext-internal-timestamp local-state)
;; SetClipRectangles or SetDashes request need to be sent?
(if (or (gcontext-internal-clip local-state)
(gcontext-internal-dash local-state))
;; Yes, mark local state "modified" to ensure
;; force-gcontext-changes will occur.
0
;; No, mark local state "unmodified"
1))