Update of /project/closure/cvsroot/closure/src In directory common-lisp.net:/tmp/cvs-serv22536
Modified Files: patch.lisp Log Message: - Remove obsolete stuff in patch.lisp (this should get rid of the MATCH-ERROR upon startup) - Add a patch to clim-clx that allows SBCL to display non-ASCII characters via CLX
Date: Sun Mar 13 21:53:57 2005 Author: emarsden
Index: closure/src/patch.lisp diff -u closure/src/patch.lisp:1.6 closure/src/patch.lisp:1.7 --- closure/src/patch.lisp:1.6 Sun Mar 13 19:00:56 2005 +++ closure/src/patch.lisp Sun Mar 13 21:53:57 2005 @@ -2,126 +2,23 @@ ;;;; Last minute patches ;;;;
- -;;;; ---------------------------------------------------------------------------------------------------- - +;; from http://paste.lisp.org/display/6063, to allow SBCL to display +;; non-ASCII characters via CLX (in-package :clim-clx)
-(defclass clx-medium (basic-medium) - ()) - -;; "So einfach und doch so schnell ..." - -;; Only problem: clipping ;( we want to cache regions to gcontexts and -;; setup clipping by copying. - -;; Further: split into line gcontexts and text-gcontext or cope with -;; don't care. A rete network might be now bad idea - -(defmethod (setf medium-text-style) :before (text-style (medium clx-medium))) -(defmethod (setf medium-line-style) :before (line-style (medium clx-medium))) -(defmethod (setf medium-clipping-region) :after (region (medium clx-medium))) - -(eval-when (compile eval load) - (fmakunbound 'medium-gcontext)) - -(defvar *gc-hash* (make-hash-table :test #'equal)) - -(defun medium-gcontext (medium ink) - (with-slots (climi::foreground climi::background line-style text-style climi::clipping-region) medium - (let ((foreground climi::foreground) - (background climi::background) - (clipping-region climi::clipping-region)) - (let* ((key (list foreground background line-style text-style ink :clipping-region)) - (gc - (or (gethash key *gc-hash*) - (setf (gethash key *gc-hash*) - (funcall 'make-medium-gcontext* - medium foreground background - line-style text-style ink - clipping-region))))) - (cond ((region-equal clipping-region +nowhere+) - ) - ((region-equal clipping-region +everywhere+) - (setf (xlib:gcontext-clip-mask gc :unsorted) :none)) - (t - (let ((rect-seq (clipping-region->rect-seq clipping-region))) - (when rect-seq - #+nil - ;; ok, what McCLIM is generating is not :yx-banded... (currently at least) - (setf (xlib:gcontext-clip-mask gc :yx-banded) rect-seq) - #-nil - ;; the region code doesn't support yx-banding... - ;; or does it? what does y-banding mean in this implementation? - ;; well, apparantly it doesn't mean what y-sorted means - ;; to clx :] we stick with :unsorted until that can be sorted out - (setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq))))) - gc)))) - -(defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region) - (let* ((drawable (sheet-mirror (medium-sheet medium))) - (port (port medium))) - (let ((gc (xlib:create-gcontext :drawable drawable))) - (setf (xlib:gcontext-font gc) (text-style-to-X-font port text-style) - (xlib:gcontext-foreground gc) (X-pixel port ink) - ) - gc))) - -(defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink (eql +flipping-ink+)) clipping-region) - (let* ((gc (make-medium-gcontext* medium foreground background line-style text-style +black+ clipping-region)) - (port (port medium)) - (flipper (logxor (X-pixel port (medium-foreground medium)) - (X-pixel port (medium-background medium))))) - ;; Now, (logxor flipper foreground) => background - ;; (logxor flipper background) => foreground - (setf (xlib:gcontext-function gc) boole-xor) - (setf (xlib:gcontext-foreground gc) flipper) - (setf (xlib:gcontext-background gc) flipper) - gc)) - -(defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink (eql +foreground-ink+)) clipping-region) - (make-medium-gcontext* medium foreground background line-style text-style foreground clipping-region)) - -(defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink (eql +background-ink+)) clipping-region) - (make-medium-gcontext* medium foreground background line-style text-style background clipping-region)) - -;;;;; - -(defmethod initialize-clx ((port clx-port)) - (let ((options (cdr (port-server-path port)))) - (setf (clx-port-display port) - #-sbcl - (xlib:open-display (getf options :host "") :display (getf options :display-id 0)) - #+sbcl - (xlib:open-default-display)) - (progn - #+NIL - (setf (xlib:display-error-handler (clx-port-display port)) - #'clx-error-handler) - ) - - (setf (clx-port-screen port) (nth (getf options :screen-id 0) - (xlib:display-roots (clx-port-display port)))) - (setf (clx-port-window port) (xlib:screen-root (clx-port-screen port))) - - (make-graft port) - (when clim-sys:*multiprocessing-p* - (setf (port-event-process port) - (clim-sys:make-process - (lambda () - (loop - (with-simple-restart - (restart-event-loop - "Restart CLIM's event loop.") - (loop - (process-next-event port))))) - :name (format nil "~S's event process." port)))) )) - - -;;;; ---------------------------------------------------------------------------------------------------- - -(in-package :climi) - -(defmethod clim:sheet-native-transformation ((sheet null)) clim:+identity-transformation+) -(defmethod clim:medium-sheet ((sheet sheet)) sheet) - +(defun translate (src src-start src-end afont dst dst-start) + (let ((min-char-index (xlib:font-min-char afont)) + (max-char-index (xlib:font-max-char afont))) + (if (stringp src) + (loop for i from src-start below src-end + for j from dst-start + for index = (char-code (aref src i)) + while (<= min-char-index index max-char-index) + do (setf (aref dst j) index) + finally (return i)) + (loop for i from src-start below src-end + for j from dst-start + for index = (if (characterp (aref src i)) (char-code (aref src i)) (aref src i)) + while (<= min-char-index index max-char-index) + do (setf (aref dst j) index) + finally (return i)))))