- closure-cvs@common-lisp.net - mailman3.common-lisp.net

[closure-cvs] CVS update: cxml/dom/dom-impl.lisp
by dlichteblau＠common-lisp.net 25 Mar '05

25 Mar '05

Update of /project/cxml/cvsroot/cxml/dom In directory common-lisp.net:/tmp/cvs-serv9430/dom Modified Files: dom-impl.lisp Log Message: - Moved utility functions from the "runes" package to the "cxml" package to avoid name conflicts with functions from "glisp" of the same name. - Renamed defsubst to definline for the same reason. (This is a commit to the cxml repository, not the main closure repository. If you don't want cxml commit messages on the closure list, please complain to me and I'll change it.) Date: Fri Mar 25 19:16:42 2005 Author: dlichteblau Index: cxml/dom/dom-impl.lisp diff -u cxml/dom/dom-impl.lisp:1.1.1.13 cxml/dom/dom-impl.lisp:1.2 --- cxml/dom/dom-impl.lisp:1.1.1.13 Sun Mar 13 19:02:51 2005 +++ cxml/dom/dom-impl.lisp Fri Mar 25 19:16:30 2005 @@ -698,7 +698,7 @@ (with-slots (children owner) node ;; remove children, add new TEXT-NODE child ;; (alas, we must not reuse an old TEXT-NODE) - (while (plusp (length children)) + (cxml::while (plusp (length children)) (dom:remove-child node (dom:last-child node))) (dom:append-child node (dom:create-text-node owner rod)))) new-value) @@ -819,7 +819,7 @@ (i 0) (previous nil)) ;; careful here, we're modifying the array we are iterating over - (while (< i (length children)) + (cxml::while (< i (length children)) (let ((child (elt children i))) (cond ((not (eq (dom:node-type child) :text))

1 0

[closure-cvs] CVS update: cxml/cxml.asd
by dlichteblau＠common-lisp.net 25 Mar '05

25 Mar '05

Update of /project/cxml/cvsroot/cxml In directory common-lisp.net:/tmp/cvs-serv9430 Modified Files: cxml.asd Log Message: - Moved utility functions from the "runes" package to the "cxml" package to avoid name conflicts with functions from "glisp" of the same name. - Renamed defsubst to definline for the same reason. (This is a commit to the cxml repository, not the main closure repository. If you don't want cxml commit messages on the closure list, please complain to me and I'll change it.) Date: Fri Mar 25 19:16:29 2005 Author: dlichteblau Index: cxml/cxml.asd diff -u cxml/cxml.asd:1.1.1.32 cxml/cxml.asd:1.2 --- cxml/cxml.asd:1.1.1.32 Sun Mar 13 19:02:58 2005 +++ cxml/cxml.asd Fri Mar 25 19:16:29 2005 @@ -61,7 +61,6 @@ #+rune-is-character "characters" :depends-on ("package" dependent)) (:file "syntax" :depends-on ("package" dependent runes)) - (:file "util" :depends-on ("package" dependent)) (:file "encodings" :depends-on ("package")) (:file "encodings-data" :depends-on ("package" "encodings")) (:file "xstream" @@ -74,11 +73,12 @@ (make-pathname :name nil :type nil :defaults *load-truename*)) :components ((:file "package") + (:file "util" :depends-on ("package")) (:file "sax-handler") (:file "characters" :depends-on ("package")) (:file "xml-name-rune-p" :depends-on ("package")) (:file "split-sequence" :depends-on ("package")) - (:file "xml-parse" :depends-on ("package" "sax-handler" "split-sequence" "xml-name-rune-p" "characters")) + (:file "xml-parse" :depends-on ("package" "util" "sax-handler" "split-sequence" "xml-name-rune-p" "characters")) (:file "characters" :depends-on ("package")) (:file "unparse" :depends-on ("xml-parse")) (:file "xmls-compat" :depends-on ("xml-parse"))

1 0

[closure-cvs] CVS update: closure/src/renderer/clim-draw.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv25449/src/renderer Modified Files: clim-draw.lisp Log Message: - Fix for CLX VALUE-ERRORs when drawing dashed lines with a dash distance of zero, in CLIM-DRAW-BORDER Date: Sun Mar 13 22:39:19 2005 Author: emarsden Index: closure/src/renderer/clim-draw.lisp diff -u closure/src/renderer/clim-draw.lisp:1.2 closure/src/renderer/clim-draw.lisp:1.3 --- closure/src/renderer/clim-draw.lisp:1.2 Sun Mar 13 19:03:24 2005 +++ closure/src/renderer/clim-draw.lisp Sun Mar 13 22:39:19 2005 @@ -4,7 +4,7 @@ ;;; Created: 2003-03-08 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-draw.lisp,v 1.2 2005/03/13 18:03:24 gbaumann Exp $ +;;; $Id: clim-draw.lisp,v 1.3 2005/03/13 21:39:19 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -66,6 +66,7 @@ (list x1 y1 x2 y2 x3 y3 x4 y4) :filled t :ink ink)) ((:dotted) + (let ((sw (max w 1))) (clim:draw-line* medium (/ (+ x1 x2) 2) (/ (+ y1 y2) 2) @@ -74,11 +75,10 @@ :ink ink :line-thickness w :line-cap-shape :round - :line-dashes (vector w (* 3 w)))) + :line-dashes (vector sw (* 3 sw))))) ((:dashed) - ;; this triggers an CLX value-error - #+NIL - (clim:draw-line* medium + (let ((sw (max 1 w))) + (clim:draw-line* medium (/ (+ x1 x2) 2) (/ (+ y1 y2) 2) (/ (+ x3 x4) 2) @@ -86,7 +86,7 @@ :ink ink :line-thickness w :line-cap-shape :square - :line-dashes (vector (* 3 w) (* 3 w)))) + :line-dashes (vector (* 3 sw) (* 3 sw))))) ((:double) (clim:draw-polygon* medium (list x1 y1

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv24362/src/gui Modified Files: clim-gui.lisp Log Message: - Implement PageUp and PageDown support in the CLIM GUI. - Add a Redraw command (with Ctrl-R accelerator) Date: Sun Mar 13 22:17:28 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.15 closure/src/gui/clim-gui.lisp:1.16 --- closure/src/gui/clim-gui.lisp:1.15 Sun Mar 13 22:15:06 2005 +++ closure/src/gui/clim-gui.lisp Sun Mar 13 22:17:28 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.15 2005/03/13 21:15:06 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.16 2005/03/13 21:17:28 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.16 2005/03/13 21:17:28 emarsden +;; - Implement PageUp and PageDown support in the CLIM GUI. +;; - Add a Redraw command (with Ctrl-R accelerator) +;; ;; Revision 1.15 2005/03/13 21:15:06 emarsden ;; Add zoom support to the renderer, accessible via the commands com-zoom-in, ;; com-zoom-out and com-zoom-100%. @@ -640,4 +644,26 @@ (write-status "Zooming out...") (setq closure::*zoom-factor* (* closure::*zoom-factor* 0.8)) (send-closure-command 'com-reflow)) + +(define-closure-command (com-page-up :name t + :keystroke :prior) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)) + (current-y (gadget-value scrollbar)) + (window-height (bounding-rectangle-height (pane-viewport-region pane)))) + (scroll-extent pane 0 (max (gadget-min-value scrollbar) (- current-y (* 0.9 window-height)))))) + +(define-closure-command (com-page-down :name t + :keystroke :next) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)) + (current-y (gadget-value scrollbar)) + (window-height (bounding-rectangle-height (pane-viewport-region pane)))) + (scroll-extent pane 0 + (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height)))))) + +(define-closure-command (com-redraw :name t :keystroke (#\r :control)) () + (let* ((*medium* (find-pane-named *frame* 'canvas)) ) + (handle-repaint *medium* (sheet-region (pane-viewport *medium*)))) + (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))

1 0

[closure-cvs] CVS update: closure/src/renderer/clim-device.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv23543/src/renderer Modified Files: clim-device.lisp Log Message: Add zoom support to the renderer, accessible via the commands com-zoom-in, com-zoom-out and com-zoom-100%. Date: Sun Mar 13 22:15:09 2005 Author: emarsden Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.8 closure/src/renderer/clim-device.lisp:1.9 --- closure/src/renderer/clim-device.lisp:1.8 Sun Mar 13 20:24:16 2005 +++ closure/src/renderer/clim-device.lisp Sun Mar 13 22:15:09 2005 @@ -31,8 +31,7 @@ (defclass clim-device () ((medium :accessor clim-device-medium :initarg :medium) (font-database :initform nil) - (zoom-factor :initform 1.2 :initarg :zoom-factor) - )) + (zoom-factor :initform closure::*zoom-factor* :initarg :zoom-factor))) (defmethod device-dpi ((device clim-device)) (with-slots (zoom-factor) device

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv23543/src/gui Modified Files: clim-gui.lisp Log Message: Add zoom support to the renderer, accessible via the commands com-zoom-in, com-zoom-out and com-zoom-100%. Date: Sun Mar 13 22:15:07 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.14 closure/src/gui/clim-gui.lisp:1.15 --- closure/src/gui/clim-gui.lisp:1.14 Sun Mar 13 21:58:31 2005 +++ closure/src/gui/clim-gui.lisp Sun Mar 13 22:15:06 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.14 2005/03/13 20:58:31 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.15 2005/03/13 21:15:06 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.15 2005/03/13 21:15:06 emarsden +;; Add zoom support to the renderer, accessible via the commands com-zoom-in, +;; com-zoom-out and com-zoom-100%. +;; ;; Revision 1.14 2005/03/13 20:58:31 emarsden ;; - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t ;; so that commands are available from listener pane @@ -83,6 +87,7 @@ (defvar closure:*home-page* "http://www.stud.uni-karlsruhe.de/~unk6/closure/user.html") (defvar closure:*user-wants-images-p* t) +(defvar closure::*zoom-factor* 1.0) (defvar *closure-process* nil) @@ -619,4 +624,20 @@ (clim:window-clear (clim:frame-query-io clim:*application-frame*))) ;;;; ---------------------------------------------------------------------------------------------------- + + +(define-closure-command (com-zoom-100% :name t) () + (setq closure::*zoom-factor* 1.0) + (send-closure-command 'com-reflow)) + +;; FIXME the :shift here is a McCLIM bug +(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control :shift)) () + (write-status "Zooming in...") + (setq closure::*zoom-factor* (* closure::*zoom-factor* 1.2)) + (send-closure-command 'com-reflow)) + +(define-closure-command (com-zoom-out :name t :keystroke (#\- :control :shift)) () + (write-status "Zooming out...") + (setq closure::*zoom-factor* (* closure::*zoom-factor* 0.8)) + (send-closure-command 'com-reflow))

1 0

[closure-cvs] CVS update: closure/src/html/html-style.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/html In directory common-lisp.net:/tmp/cvs-serv23140/src/html Modified Files: html-style.lisp Log Message: - Fix use of *STYLE-SHEET-CACHE*/LOCK. Was causing recursive lock attempts that were detected by SBCL's mutexes. Date: Sun Mar 13 22:01:59 2005 Author: emarsden Index: closure/src/html/html-style.lisp diff -u closure/src/html/html-style.lisp:1.3 closure/src/html/html-style.lisp:1.4 --- closure/src/html/html-style.lisp:1.3 Sun Mar 13 19:01:54 2005 +++ closure/src/html/html-style.lisp Sun Mar 13 22:01:59 2005 @@ -389,22 +389,24 @@ (defun maybe-parse-style-sheet-from-url (url &key (name "anonymous") (supersheet nil) (media-type :all)) - (mp/with-lock (*style-sheet-cache*/lock) - (multiple-value-bind (looked presentp) (gethash url *style-sheet-cache*) - (cond (presentp - (format T "~&;; Serving style sheet ~S [at ~S] from cache.~%" - name url) - looked) - (t - (format T "~&;; fetching and parsing style sheet ~S [at ~S].~%" - name url) - (let ((res (maybe-parse-style-sheet-from-url-aux - url - :name name - :supersheet supersheet - :media-type media-type))) - (setf (gethash url *style-sheet-cache*) res) - res)))))) + (multiple-value-bind (looked presentp) + (mp/with-lock (*style-sheet-cache*/lock) + (gethash url *style-sheet-cache*)) + (cond (presentp + (format *debug-io* "~&;; Serving style sheet ~S [at ~S] from cache.~%" + name url) + looked) + (t + (format *debug-io* "~&;; fetching and parsing style sheet ~S [at ~S].~%" + name url) + (let ((res (maybe-parse-style-sheet-from-url-aux + url + :name name + :supersheet supersheet + :media-type media-type))) + (mp/with-lock (*style-sheet-cache*/lock) + (setf (gethash url *style-sheet-cache*) res)) + res))))) (defun maybe-parse-style-sheet-from-url-aux (url &key (name "anonymous") (supersheet nil)

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv22604/src/gui Modified Files: clim-gui.lisp Log Message: - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t so that commands are available from listener pane Date: Sun Mar 13 21:58:31 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.13 closure/src/gui/clim-gui.lisp:1.14 --- closure/src/gui/clim-gui.lisp:1.13 Sun Mar 13 20:24:14 2005 +++ closure/src/gui/clim-gui.lisp Sun Mar 13 21:58:31 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.13 2005/03/13 19:24:14 gbaumann Exp $ +;;; $Id: clim-gui.lisp,v 1.14 2005/03/13 20:58:31 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.14 2005/03/13 20:58:31 emarsden +;; - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t +;; so that commands are available from listener pane +;; ;; Revision 1.13 2005/03/13 19:24:14 gbaumann ;; make it at least compile and show a window with CMUCL 19a and cvs mcclim. ;; @@ -85,7 +89,7 @@ (defclass closure-pane (application-pane) ()) -;;; Curde History +;;; Crude History (defvar *back-history* nil) (defvar *forw-history* nil) @@ -259,10 +263,10 @@ ;;;; Commands ;;;; -(define-closure-command com-show-listener () +(define-closure-command (com-show-listener :name t) () (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) t)) -(define-closure-command com-hide-listener () +(define-closure-command (com-hide-listener :name t) () (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) nil)) (define-closure-command (com-visit-url :name t) ((url 'url)) ;;; :gesture :select)) @@ -277,10 +281,10 @@ (let ((*standard-output* *trace-output*)) (foo url))) -(define-closure-command com-reflow () +(define-closure-command (com-reflow :name t) () (reflow)) -(define-closure-command com-back () +(define-closure-command (com-back :name t) () (let ((*standard-output* *query-io*)) (cond ((null (cdr *back-history*)) (format t "There is nowhere you can go back to.~%")) @@ -289,7 +293,7 @@ (format t "Going back to ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command com-forward () +(define-closure-command (com-forward :name t) () (let ((*standard-output* *query-io*)) (cond ((null *forw-history*) (format t "There is nowhere you can go forward to.~%")) @@ -298,7 +302,7 @@ (format t "Going forward to ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command com-reload () +(define-closure-command (com-reload :name t) () (let ((*standard-output* *query-io*)) (cond ((null *back-history*) (format t "There is nothing to reload.~%")) @@ -306,15 +310,15 @@ (format t "Reloading ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command com-images-off () +(define-closure-command (com-images-off :name t) () (setf closure:*user-wants-images-p* nil) (format *query-io* "Images are now off.~%")) -(define-closure-command com-images-on () +(define-closure-command (com-images-on :name t) () (setf closure:*user-wants-images-p* t) (format *query-io* "Images are now on. You may want to reload.~%")) -(define-closure-command com-quit () +(define-closure-command (com-quit :name t) () (throw 'closure-quit nil)) (defun make-google-search-url (string) @@ -325,15 +329,15 @@ (cons "q" string))) (url:parse-url "http://www.google.com/search"))) -(define-closure-command com-reverse-search-google ((url 'url)) +(define-closure-command (com-reverse-search-google :name t) ((url 'url)) (let ((*standard-output* *trace-output*)) (com-visit-url (make-google-search-url (format nil "link:~A" url))))) -(define-closure-command com-search-google ((what 'string)) +(define-closure-command (com-search-google :name t) ((what 'string)) (com-visit-url (make-google-search-url what))) -(define-closure-command com-home () +(define-closure-command (com-home :name t) () (com-visit-url closure:*home-page*)) (define-presentation-translator fofo

1 0

[closure-cvs] CVS update: closure/closure.asd
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure In directory common-lisp.net:/tmp/cvs-serv22568 Modified Files: closure.asd Log Message: Remove dependency on the clx system. Date: Sun Mar 13 21:54:52 2005 Author: emarsden Index: closure/closure.asd diff -u closure/closure.asd:1.3 closure/closure.asd:1.4 --- closure/closure.asd:1.3 Fri Jul 4 21:44:21 2003 +++ closure/closure.asd Sun Mar 13 21:54:52 2005 @@ -84,8 +84,7 @@ (asdf:defsystem closure - :depends-on (:clx - :clim + :depends-on (:clim :clim-clx :glisp) :default-component-class closure-source-file

1 0

[closure-cvs] CVS update: closure/src/patch.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

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)))))

1 0