diff --git a/ChangeLog.n b/ChangeLog.n index 4fcbbdba9d3755c6422710e9fa38d4eebb4b9a62..149628e55c3d3f15eff27ef4a3f4a6111fd9b4df 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,27 @@ +2007-12-11 Andreas Fuchs <afuchs@franz.com> + + * clim/text-formatting.lisp: Add filling-stream-conditional-newline, + fix an off-by-1 bug for non-whitespace fill characters. + * misc/MyDrawingA.c: create clim drawing panes with an XIC. + * demo/japanese-graphics-editor.lisp: convert encoding to utf-8. + * aclpc/acl-widget.lisp: Fix the cursor-position code to report correct + numbers for the end of the buffer and past newlines. + * silica/classes.lisp, silica/text-style.lisp, tk/font.lisp, tk/graphics.lisp, + tk/resources.lisp, tk/widget.lisp, tk/xlib.lisp, tk/xm-defs.lisp, + tk/xm-font-list.lisp, tk/xm-funs.lisp, tk/xm-widgets.lisp, + tk/xt-defs.lisp, tk/xt-funs.lisp, tk-silica/xm-frames.lisp, + tk-silica/xm-gadgets.lisp, tk-silica/xm-silica.lisp, + tk-silica/xt-graphics.lisp, tk-silica/xt-silica.lisp, utils/lisp-utilities.lisp, + xlib/xlib-defs.lisp, xlib/xlib-funs.lisp: + Change the X/Motif backend to support international character input/output + (in most places): + * Use the locale-provided external format for string->foreign-octet conversion, + * Use XmImMbLookupString to lookup key on key press events, + * Use XmbStringDraw to display non-rotated multibyte text, + * Search the installed fonts for encodings CLIM doesn't know about and add them + to the default font set, and + * Set up the Xt locale correctly. + 2007-07-18 Kevin Layer <layer@gemini.franz.com> * tk-silica/xt-silica.lisp (restart-port): bug16740: fix badly @@ -6190,4 +6214,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile Lots of other stuff ******************************************************************************* -$Revision: 2.36 $ +$Revision: 2.37 $ diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp index 3748177961c06f1e11b7b09b6c4c891aa1e30476..2c2127e6638db0d1516b3851b9184f6e2ccca7d5 100644 --- a/aclpc/acl-widget.lisp +++ b/aclpc/acl-widget.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: acl-widget.lisp,v 2.14 2007/04/25 20:29:26 layer Exp $ +;; $Id: acl-widget.lisp,v 2.15 2007/12/11 17:20:20 layer Exp $ #|**************************************************************************** * * @@ -289,7 +289,13 @@ ;; the min height in a +text-field-view+ is zero. At some ;; point, lets try modifying +text-field-view+ and ;; +text-editor-view+ to supply better default sizes than zero. -(defvar *min-text-field-width* 75) +;; +;; 2007-09-03/afuchs: This used to be *min-text-field-width. The +;; minimum width was computed twice. So far, this didn't work too well +;; for text boxes in accepting-values panes that should be smaller +;; than 75 pixels. min-w seems to work better, so let's use that +;; instead, and use 75 as a default width. +(defvar *default-text-field-width* 75) (defvar *min-text-field-height* '(1 :line)) (defmethod compose-space ((pane mswin-text-edit) &key width height) @@ -313,14 +319,14 @@ ;; This is where accepting-values views factors in. (setq w (max (process-width-specification pane (space-requirement-width initial-space-requirement)) - *min-text-field-width*))) + min-w))) (ncolumns (setq w (process-width-specification pane `(,ncolumns :character)))) ((stringp value) (setq w (max (process-width-specification pane value) - *min-text-field-width*))) + min-w))) (t - (setq w *min-text-field-width*))) + (setq w *default-text-field-width*))) (when (member scroll-mode '(:horizontal :both t :dynamic)) ;; Allow for the vertical scrollbar (let ((wsty (win-scroll-thick :y))) @@ -443,24 +449,29 @@ (let ((mirror (sheet-direct-mirror pane))) (when mirror (let* ((val (slot-value pane 'value)) - (val-len (if val (length val) 0))) - ;; For endpos = -1, means the end. - (when (= endpos -1) - (setq endpos val-len)) - ;; Ensure the correct order. - (when (< endpos startpos) - (let ((temp endpos)) - (setf endpos startpos - startpos temp))) - ;; Otherwise, trim to fit. - (when (< val-len endpos) - (setq endpos val-len)) - (when (< startpos 0) - (setq startpos 0)) - (acl-clim::frame-send-message (pane-frame pane) - mirror - win:EM_SETSEL - startpos endpos))))) + (val-len (if val + (+ (length val) + (count #\newline val)) + 0))) + ;; For endpos = -1, means the end. + (when (= endpos -1) + (setq endpos val-len)) + ;; Ensure the correct order. + (when (< endpos startpos) + (let ((temp endpos)) + (setf endpos startpos + startpos temp))) + ;; Otherwise, trim to fit. + (when (< val-len endpos) + (setq endpos val-len)) + (when (< val-len startpos) + (setq startpos val-len)) + (when (< startpos 0) + (setq startpos 0)) + (acl-clim::frame-send-message (pane-frame pane) + mirror + win:EM_SETSEL + startpos endpos))))) ;;; Retreive the start and end position of the ;;; selection in a mswin-text-edit gadget. @@ -709,14 +720,14 @@ ;; This is where accepting-values views factors in. (setq w (max (process-width-specification pane (space-requirement-width initial-space-requirement)) - *min-text-field-width*))) + min-w))) (ncolumns (setq w (process-width-specification pane `(,ncolumns :character)))) ((stringp value) (setq w (max (process-width-specification pane value) - *min-text-field-width*))) + min-w))) (t - (setq w (process-width-specification pane `(20 :character))))) + (setq w *default-text-field-width*))) (setq w (max w min-w)) ;; HEIGHT @@ -812,8 +823,10 @@ ;; two characters (newline and return) for each ;; newline, so we need to correct the cursor. (let ((result 0)) - (loop for c across text - with actual = 0 + (loop with actual = 0 + for c = (if (< result (length text)) + (char text result) + #\Space) while (< actual windows-cursor) do (progn (incf actual @@ -821,7 +834,6 @@ (incf result))) result))) - (defmethod (setf text-field-cursor) (cursor (text-field mswin-text-edit)) (let* ((text (clim:gadget-value text-field)) ;; Add 1 for each newline before the cursor. diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp index c8a67486960861b4c8f966f62111b2a6d0a440c4..9641db4a12f872e93e97fc919bbda46537733e8a 100644 --- a/clim/text-formatting.lisp +++ b/clim/text-formatting.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: text-formatting.lisp,v 2.8 2007/04/17 21:45:51 layer Exp $ +;; $Id: text-formatting.lisp,v 2.9 2007/12/11 17:20:20 layer Exp $ (in-package :clim-internals) @@ -26,13 +26,14 @@ ;;; Filling output (defclass filling-stream (standard-encapsulating-stream) - (fill-width - break-characters - prefix - prefix-width - current-width - old-buffers - (buffer :initarg :buffer))) + (fill-width + break-characters + prefix + prefix-width + current-width + old-buffers + on-fresh-line + (buffer :initarg :buffer))) (defun flush-buffer-to-stream/filling (stream buffer &optional start end) (setf start (or start 0) @@ -55,6 +56,10 @@ (write-string (first buffer-entry) s)) (write-string (slot-value filling-stream 'buffer) s))) +(defun break-character-predicate (stream) + (lambda (c) + (member c (slot-value stream 'break-characters)))) + (defun filling-stream-flush-continuations (filling-stream force-p) "Returns a list of continuations that, when invoked in order, will flush a filling-stream's buffer until the last break @@ -71,84 +76,92 @@ the filling-stream's old-buffers list." (flush-buffer-to-stream/filling stream buffer start end))))) (labels ((delete-buffer-entry (buffer-entry) (setf (slot-value filling-stream 'old-buffers) - (delete buffer-entry (slot-value filling-stream 'old-buffers))))) + (delete buffer-entry (slot-value filling-stream 'old-buffers)))) + (buffer-flusher (buffer-entry &optional (length (length (first buffer-entry))) + (delete-p t)) + (destructuring-bind (buffer stream continuation) buffer-entry + (lambda () + (funcall continuation stream buffer 0 length) + (when delete-p + (delete-buffer-entry buffer-entry)))))) ;; from youngest buffer entry to the oldest (i.e. right to left) ;; search for break-characters; if found, flush & remove all ;; earlier buffers, then flush that buffer until occurrence. (loop for (buffer-entry . rest) on (cons current-buffer-entry (slot-value filling-stream 'old-buffers)) - for (buffer stream continuation) = buffer-entry + for (buffer) = buffer-entry for last-break-char-pos = (position-if #'(lambda (c) (member c break-characters)) buffer :from-end t) when (or last-break-char-pos force-p) do (return (values - (prog1 - (nreverse (cons ; flush the found buffer last - (lambda () - (funcall continuation - stream buffer - 0 - (if force-p (length buffer) last-break-char-pos)) - (when (or force-p (zerop (length buffer))) - (delete-buffer-entry buffer-entry))) - ;; but first, flush the buffers before it. - (mapcar - (lambda (buffer-entry) - (destructuring-bind (buffer stream continuation) - buffer-entry - (lambda () - (funcall continuation - stream buffer 0 (length buffer)) - (delete-buffer-entry buffer-entry)))) - rest)))) + (nreverse (cons ; flush the found buffer last + (buffer-flusher buffer-entry + (if force-p + (length buffer) + (1+ last-break-char-pos)) + (or force-p (zerop (length buffer)))) + ;; but first, flush the buffers before it. + (mapcar + (lambda (buffer-entry) + (buffer-flusher buffer-entry)) + rest))) last-break-char-pos)))))) (defmethod filling-stream-write-buffer ((filling-stream filling-stream) &optional force-p) - (with-slots (current-width) filling-stream + (with-slots (current-width on-fresh-line) filling-stream (let ((stream (slot-value filling-stream 'stream)) (buffer (slot-value filling-stream 'buffer)) - (old-buffers (slot-value filling-stream 'old-buffers)) (fill-width (slot-value filling-stream 'fill-width)) - (on-fresh-line nil)) - + (should-be-finished-now nil)) (labels ((break-line-now () (stream-terpri stream) (filling-stream-handle-line-break filling-stream) - (setq on-fresh-line t))) + (setf on-fresh-line t))) (loop - (when (and (null old-buffers) - (zerop (fill-pointer buffer))) ;Buffer empty and no delayed buffers. - (return-from filling-stream-write-buffer nil)) - (unless (or (> current-width fill-width) - force-p) ;Haven't reached the fill column - (return-from filling-stream-write-buffer nil)) - ;; We have a line that is larger than the fill column. it - ;; needs to be broken. - (multiple-value-bind (flush-continuations found-break-chars) - (filling-stream-flush-continuations filling-stream force-p) - ;; output the (possibly delayed) buffer contents until the break char. - (dolist (continuation flush-continuations) - (funcall continuation)) - - (cond ((and (not force-p) found-break-chars) - ;; Found a break char that's just before the max width - (break-line-now)) - (force-p - ;; flush was forced. We should have written - ;; everything now, so bail out. - (return-from filling-stream-write-buffer nil)) - ((not force-p) - ;; this line doesn't fit, and there are no break - ;; chars. write the line on a fresh line anyway, - ;; and open a fresh line after that. - (unless on-fresh-line - (break-line-now)) - (let ((force-continuations (filling-stream-flush-continuations filling-stream t))) - (dolist (continuation force-continuations) - (funcall continuation))) - (break-line-now))))))))) + (let ((old-buffers (slot-value filling-stream 'old-buffers))) + (when (and (null old-buffers) + (zerop (fill-pointer buffer))) ;Buffer empty and no delayed buffers. + (return-from filling-stream-write-buffer nil)) + (unless (or (> current-width fill-width) + force-p) ;Haven't reached the fill column + (return-from filling-stream-write-buffer nil)) + + (assert (not should-be-finished-now) + (should-be-finished-now) + "whoa, buffer is ~S, old-buffers ~S, fill-pointer at ~A" + buffer old-buffers (fill-pointer buffer)) + + ;; We have a line that is larger than the fill column. it + ;; needs to be broken. + (multiple-value-bind (flush-continuations found-break-chars) + (filling-stream-flush-continuations filling-stream + force-p) + ;; output the (possibly delayed) buffer contents until the break char. + (dolist (continuation flush-continuations) + (setf on-fresh-line nil) + (funcall continuation)) + + (cond ((and (not force-p) found-break-chars) + ;; Found a break char that's just before the max width + (break-line-now)) + (force-p + ;; flush was forced. We should have written + ;; everything now, so bail out. + (return-from filling-stream-write-buffer nil)) + ((not force-p) + ;; this line doesn't fit, and there are no break + ;; chars. write the line on a fresh line anyway, + ;; and open a fresh line after that. + (unless on-fresh-line + (break-line-now)) + (let ((force-continuations + (filling-stream-flush-continuations filling-stream + t))) + (dolist (continuation force-continuations) + (setf on-fresh-line nil) + (funcall continuation)))))))))))) ;; Write the prefix string and then set the current width (defmethod filling-stream-handle-line-break ((filling-stream filling-stream)) @@ -178,61 +191,67 @@ the filling-stream's old-buffers list." (defmethod stream-write-char ((filling-stream filling-stream) char) (with-slots (current-width) filling-stream - (let ((stream (slot-value filling-stream 'stream)) - (fill-width (slot-value filling-stream 'fill-width)) - (buffer (slot-value filling-stream 'buffer))) - (cond ((or (eql char #\Newline) - (eql char #\Return)) - (stream-terpri filling-stream)) - (t - (vector-push-extend char buffer) - (incf current-width (text-size stream char)) - ;; FILLING-STREAM-WRITE-BUFFER will only do something if we - ;; are beyond the fill-width, so optimize calls to it - (when (> current-width fill-width) - (filling-stream-write-buffer filling-stream))))))) + (let* ((stream (slot-value filling-stream 'stream)) + (fill-width (slot-value filling-stream 'fill-width)) + (text-size (text-size stream char)) + (break-chars (slot-value filling-stream 'break-characters)) + (buffer (slot-value filling-stream 'buffer))) + (cond ((or (eql char #\Newline) + (eql char #\Return)) + (stream-terpri filling-stream)) + ((and (> (+ current-width text-size) fill-width) + (member char break-chars)) + (stream-terpri filling-stream) + ) + (t + (vector-push-extend char buffer) + (incf current-width text-size) + ;; FILLING-STREAM-WRITE-BUFFER will only do something if we + ;; are beyond the fill-width, so optimize calls to it + (when (> current-width fill-width) + (filling-stream-write-buffer filling-stream))))))) (defmethod stream-write-string ((filling-stream filling-stream) string &optional (start 0) end) (with-slots (current-width) filling-stream - (when (null end) - (setq end (length string))) - (let ((stream (slot-value filling-stream 'stream)) - (fill-width (slot-value filling-stream 'fill-width)) - (buffer (slot-value filling-stream 'buffer)) - (break-characters (slot-value filling-stream 'break-characters))) - ;; The general scheme here is to find a break character, - ;; buffer the string up to the break character, then call - ;; STREAM-WRITE-CHAR on the break character to do the - ;; necessary bookkeeping - (loop - (let* ((break (position-if #'(lambda (char) - (or (eql char #\Newline) - (eql char #\Return) - (member char break-characters))) - string :start start :end end)) - (width (text-size stream string - :start start :end (or break end)))) - (when (or (null break) (> break 0)) - (let* ((ofp (fill-pointer buffer)) - (nfp (+ ofp (- (or break end) start)))) - (when (> nfp (array-dimension buffer 0)) - (adjust-array buffer (+ nfp nfp))) - (setf (fill-pointer buffer) nfp) - (replace buffer string - :start1 ofp - :start2 start :end2 break))) - (incf current-width width) - ;; We might need to flush the buffer before we insert - ;; the next break character - (when (> current-width fill-width) - (filling-stream-write-buffer filling-stream)) - (cond (break - (stream-write-char filling-stream (aref string break)) - (setq start (1+ break)) - (when (>= start end) - (return))) - (t (return)))))))) + (when (null end) + (setq end (length string))) + (let ((stream (slot-value filling-stream 'stream)) + (fill-width (slot-value filling-stream 'fill-width)) + (buffer (slot-value filling-stream 'buffer)) + (break-characters (slot-value filling-stream 'break-characters))) + ;; The general scheme here is to find a break character, + ;; buffer the string up to the break character, then call + ;; STREAM-WRITE-CHAR on the break character to do the + ;; necessary bookkeeping + (loop + (let* ((break (position-if #'(lambda (char) + (or (eql char #\Newline) + (eql char #\Return) + (member char break-characters))) + string :start start :end end)) + (width (text-size stream string + :start start :end (or break end)))) + (when (or (null break) (> break 0)) + (let* ((ofp (fill-pointer buffer)) + (nfp (+ ofp (- (or break end) start)))) + (when (> nfp (array-dimension buffer 0)) + (adjust-array buffer (+ nfp nfp))) + (setf (fill-pointer buffer) nfp) + (replace buffer string + :start1 ofp + :start2 start :end2 break))) + (incf current-width width) + ;; We might need to flush the buffer before we insert + ;; the next break character + (when (> current-width fill-width) + (filling-stream-write-buffer filling-stream)) + (cond (break + (stream-write-char filling-stream (aref string break)) + (setq start (1+ break)) + (when (>= start end) + (return))) + (t (return)))))))) (defmethod stream-force-output ((filling-stream filling-stream)) (filling-stream-write-buffer filling-stream t)) @@ -274,16 +293,39 @@ the filling-stream's old-buffers list." #'invoke-with-output-recording-options continuation record draw)) -(defmethod stream-close-text-output-record ((filling-stream filling-stream) - &optional wrapped) +(defmethod stream-close-text-output-record :around ((filling-stream filling-stream) + &optional wrapped) + (filling-stream-write-buffer filling-stream t) (save-buffer-and-continue filling-stream filling-stream #'stream-close-text-output-record wrapped)) +(defmethod invoke-with-new-output-record :around ((filling-stream filling-stream) + function record-type + constructor &rest initargs) + (declare (ignorable initargs constructor record-type function)) + (filling-stream-write-buffer filling-stream t) + (call-next-method)) + (defun make-filling-stream-buffer () (make-array 100 :element-type 'character :fill-pointer 0 :adjustable t)) +;;; Explicit newline hints on the filling stream +(defmethod filling-stream-conditional-newline (stream &key force &allow-other-keys) + (when force (terpri stream))) + +(defmethod filling-stream-conditional-newline ((stream filling-stream) + &key force (space-for "") + (text-face (text-style-face (medium-merged-text-style stream))) + (text-size (text-style-size (medium-merged-text-style stream))) + (text-family (text-style-family (medium-merged-text-style stream)))) + (when (or force + (> (+ (text-size stream space-for :text-style (make-text-style text-family text-face text-size)) + (slot-value stream 'current-width)) + (slot-value stream 'fill-width))) + (terpri stream))) + (defresource filling-stream (stream fill-width break-characters prefix prefix-width) :constructor (make-instance 'filling-stream @@ -301,7 +343,8 @@ the filling-stream's old-buffers list." (setf (fill-pointer (slot-value filling-stream 'buffer)) 0) (setf (slot-value filling-stream 'current-width) (stream-cursor-position stream)) - (setf (slot-value filling-stream 'old-buffers) nil))) + (setf (slot-value filling-stream 'old-buffers) nil) + (setf (slot-value filling-stream 'on-fresh-line) t))) (defun invoke-filling-output (stream continuation &key (fill-width '(80 :character)) diff --git a/demo/japanese-graphics-editor.lisp b/demo/japanese-graphics-editor.lisp index 2f01b6681f3a346e944fb7905911b7d24e44aa85..e435a62588e3a424a3419d807656ba2ca0acbf2f 100644 --- a/demo/japanese-graphics-editor.lisp +++ b/demo/japanese-graphics-editor.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: japanese-graphics-editor.lisp,v 2.7 2007/04/17 21:45:51 layer Exp $ +;; $Id: japanese-graphics-editor.lisp,v 2.8 2007/12/11 17:20:20 layer Exp $ (in-package :japanese-graphics-editor) @@ -29,7 +29,7 @@ ;;; with the correct external-format. (eval-when (compile) (when (streamp comp::*compile-file-stream*) - (setf (stream-external-format comp::*compile-file-stream*) :euc))) + (setf (stream-external-format comp::*compile-file-stream*) :utf8))) #-ics (eval-when (compile) @@ -278,11 +278,11 @@ (define-command-table graphics-editor-file-commands) (define-command-table graphics-editor-edit-commands - :menu (("���ä�" :command (com-deselect-object)) + :menu (("取り消し" :command (com-deselect-object)) ("divide1" :divider nil) - ("���ꥢ��" :command (com-clear)) + ("クリアー" :command (com-clear)) ("divide2" :divider nil) - ("��ɽ��" :command (com-redisplay)))) + ("再表示" :command (com-redisplay)))) (define-command-table graphics-editor-option-commands) @@ -299,9 +299,9 @@ graphics-editor-edit-commands graphics-editor-option-commands) :inherit-menu :keystrokes - :menu (("�ե�����" :menu graphics-editor-file-commands :mnemonic #\F :documentation "�ե�����") - ("�Խ�" :menu graphics-editor-edit-commands :mnemonic #\E ) - ("���ץ����" :menu graphics-editor-option-commands :mnemonic #\O)))) + :menu (("ファイル" :menu graphics-editor-file-commands :mnemonic #\F :documentation "ファイル") + ("編集" :menu graphics-editor-edit-commands :mnemonic #\E ) + ("オプション" :menu graphics-editor-option-commands :mnemonic #\O)))) (:pointer-documentation t) ;; Three panes: a display pane, and command menu, and a modeless ;; dialog containing the line style options @@ -339,13 +339,13 @@ (:fill display))))) (defmethod frame-menu-translator-documentation ((frame graphics-editor)) - "��˥塼") + "メニュー") (defmethod frame-pointer-button-documentation ((frame graphics-editor) button) (case button - (:left "��") - (:middle "��") - (:right "��"))) + (:left "左") + (:middle "中") + (:right "右"))) ;; Perhaps these need to be localized. At present this method is ;; identical to that on standard-application-frame. @@ -371,7 +371,7 @@ (define-presentation-method describe-presentation-type ((type line-thickness) stream plural-count) (declare (ignore plural-count)) - (write-string "����" stream)) + (write-string "太さ" stream)) (defun present-line-thickness (object stream &key acceptably) (declare (ignore acceptably)) @@ -394,7 +394,7 @@ (define-presentation-method describe-presentation-type ((type line-style-type) stream plural-count) (declare (ignore plural-count)) - (write-string "�饤����" stream)) + (write-string "ラインタイプ" stream)) (defun present-line-style (object stream &key acceptably) (declare (ignore acceptably)) @@ -423,7 +423,7 @@ (define-presentation-method describe-presentation-type ((type object-shape) stream plural-count) (declare (ignore plural-count)) - (write-string "��" stream)) + (write-string "形" stream)) (defun present-object-shape (object stream &key acceptably) (declare (ignore acceptably)) @@ -467,16 +467,16 @@ (dashes (line-style-dashes style))) (multiple-value-bind (thickness thickness-changed) (accept stream 'line-thickness thickness - "����" 'thickness) + "太さ" 'thickness) (declare (ignore ignore)) (multiple-value-bind (dashes dashes-changed) (accept stream 'line-style-type (if dashes :dashed :solid) - "�饤����" 'dashes) + "ラインタイプ" 'dashes) (declare (ignore ignore)) (setq dashes (eq dashes :dashed)) (multiple-value-bind (new-shape shape-changed) (accept stream 'object-shape shape - "��" 'shape) + "形" 'shape) (when (or thickness-changed dashes-changed shape-changed) (setq style (make-line-style :thickness thickness :dashes dashes)) @@ -498,7 +498,7 @@ (dolist (object (slot-value frame 'objects)) (draw-object object stream))) -(define-graphics-editor-command (com-create-box :name "�ܥå���������") +(define-graphics-editor-command (com-create-box :name "ボックスの成作") ((left 'integer) (top 'integer)) (com-deselect-object) @@ -507,7 +507,7 @@ (bottom top) (rectangle-drawn nil) (box nil) - (label (format nil "�ܥå��� ~D" (slot-value *application-frame* 'counter))) + (label (format nil "ボックス ~D" (slot-value *application-frame* 'counter))) (last-box (slot-value *application-frame* 'last-box)) (style (slot-value *application-frame* 'style)) (shape (slot-value *application-frame* 'shape)) @@ -574,7 +574,7 @@ (list x y)) ;; Select an object by clicking "select" (Mouse-Left) on it. -(define-graphics-editor-command (com-select-box :name "�ܥå���������") +(define-graphics-editor-command (com-select-box :name "ボックスの選択") ((object 'box :gesture :select)) (select-object *application-frame* object) (setf (slot-value *application-frame* 'style) (object-style object) @@ -583,14 +583,14 @@ ;; Deselect an object by clicking the Deselect menu button, or by ;; clicking over blank area without moving the mouse. (define-command (com-deselect-object :command-table graphics-editor-edit-commands - :menu ("���ä�" - :documentation "�����ܥå�����뤹�롣")) + :menu ("取り消し" + :documentation "選択したボックスをキャンセルする。")) () (when (frame-selected-object *application-frame*) (deselect-object *application-frame* (frame-selected-object *application-frame*)))) ;; Move an object by clicking Mouse-Middle on it and dragging the mouse. -(define-graphics-editor-command (com-move-object :name "�ܥå����ΰ�ư") +(define-graphics-editor-command (com-move-object :name "ボックスの移動") ((object 'box :gesture :describe)) (let ((stream (get-frame-pane *application-frame* 'display))) (with-bounding-rectangle* (left top right bottom) object @@ -624,7 +624,7 @@ (setf (box-arrow-in box2) nil))) ;; Add a menu item that deletes the selected object -(add-menu-item-to-command-table 'graphics-editor "���" +(add-menu-item-to-command-table 'graphics-editor "削除" :function 'delete-selected-object :keystroke '(#\d :control)) @@ -648,8 +648,8 @@ (define-command (com-clear :command-table graphics-editor-edit-commands :keystroke (#\\ :control) - :menu ("���ꥢ��" - :documentation "��������䡼�ˤ��롣")) + :menu ("クリアー" + :documentation "スクリーンをクリヤーにする。")) () (with-slots (objects selected-object last-box) *application-frame* (setq objects nil @@ -661,22 +661,22 @@ ;; it's only here for debugging. (define-command (com-redisplay :command-table graphics-editor-edit-commands :keystroke (:r :meta) - :menu ("��ɽ��" + :menu ("再表示" :documentation - "�ܥå�����⤦����ɽ������")) + "ボックスをもう一度表示する")) () (redisplay-frame-pane *application-frame* 'display :force-p t)) (define-command (com-quit :command-table graphics-editor-file-commands :keystroke (:x :meta) - :menu ("�Ĥ���" :documentation "�ץ�������λ���ޤ���")) () + :menu ("閉じる" :documentation "プログラムを終了します。")) () (frame-exit *application-frame*)) (define-command (com-change-layout :command-table graphics-editor-option-commands :keystroke (:l :meta) - :menu ("�쥤�����Ȥ�����" - :documentation "�쥤�����Ȥ�����")) + :menu ("レイアウトの選択" + :documentation "レイアウトの選択")) () (let ((layouts (frame-all-layouts *application-frame*))) (setf (frame-current-layout *application-frame*) @@ -686,7 +686,7 @@ -(define-demo "������Խ�" graphics-editor +(define-demo "グラフ編集" graphics-editor :left 100 :top 100 :width 800 :height 500) )) ;; ics-target-case diff --git a/misc/MyDrawingA.c b/misc/MyDrawingA.c index d7700cae8a8050b671fc27e835611b6a2d8f84ff..fd05f9542478773491f2e0561f3c1ce892bba25f 100644 --- a/misc/MyDrawingA.c +++ b/misc/MyDrawingA.c @@ -1,4 +1,4 @@ -/* -[Tue Apr 17 14:44:44 2007 by layer]- +/* -[Tue Dec 11 09:11:40 2007 by layer]- * * copyright (c) 1992-2002 Franz Inc, Berkeley, CA All rights reserved. * copyright (c) 2002-2007 Franz Inc, Oakland, CA - All rights reserved. @@ -17,7 +17,7 @@ * Commercial Software developed at private expense as specified in * DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. * - * $Header: /repo/cvs.copy/clim2/misc/MyDrawingA.c,v 2.6 2007/04/17 21:45:51 layer Exp $ + * $Header: /repo/cvs.copy/clim2/misc/MyDrawingA.c,v 2.7 2007/12/11 17:20:20 layer Exp $ */ #if defined(__alpha) @@ -151,7 +151,10 @@ XmCreateMyDrawingArea( { /****************/ - return( XtCreateWidget( name, xmMyDrawingAreaWidgetClass, p, args, n)) ; + Widget r = XtCreateWidget( name, xmMyDrawingAreaWidgetClass, p, args, n); + XmImRegister (r, 0); +/* XmImGetXIC (r, XmINHERIT_POLICY, NULL, 0); */ + return r; } #if defined(__alpha) diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp index 637c3eeebc6d76042a0a992dcee916f380ed1c34..308330455107a6b0e0c6be1d6bfaae4e13a34312 100644 --- a/postscript/postscript-medium.lisp +++ b/postscript/postscript-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $Id: postscript-medium.lisp,v 2.4 2003/12/15 18:35:14 layer Exp $ +;; $Id: postscript-medium.lisp,v 2.5 2007/12/11 17:20:20 layer Exp $ (in-package :postscript-clim) @@ -505,6 +505,7 @@ (error "Obsolete")) (excl::without-package-locks +;;; XXX: what the dis? Is this intentionally obfuscated? (defmacro with-postscript-glyph-for-character (&body body) `(macrolet ((port-glyph-for-character (port character style &optional our-font) `(multiple-value-bind (character-set index) diff --git a/silica/classes.lisp b/silica/classes.lisp index 002e441c5acda6b7fa3922bd366bb9a876305be3..ba9cca6b35cdf0b85a797502af9e67b93313897d 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: classes.lisp,v 2.9 2007/04/17 21:45:52 layer Exp $ +;; $Id: classes.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $ (in-package :silica) @@ -84,9 +84,9 @@ #-(or aclpc acl86win32) (defun mapping-table-initform () (excl:ics-target-case - (:+ics (let ((v (make-array 4))) + (:+ics (let ((v (make-array 4 :adjustable t))) (dotimes (i 4) - (setf (svref v i) + (setf (aref v i) (make-hash-table :test #'equal))) v)) (:-ics (make-hash-table :test #'equal)))) @@ -94,9 +94,9 @@ #-(or aclpc acl86win32) (defun mapping-cache-initform () (excl:ics-target-case - (:+ics (let ((v (make-array 4))) + (:+ics (let ((v (make-array 4 :adjustable t))) (dotimes (i 4) - (setf (svref v i) + (setf (aref v i) (cons nil nil))) v)) (:-ics (cons nil nil)))) diff --git a/silica/text-style.lisp b/silica/text-style.lisp index 8228caf7b98bbef84ca3ab7b6f7bc047b7429561..1ca43cdd9842e71fe197e369c366242ce45732c2 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: text-style.lisp,v 2.10 2007/04/17 21:45:52 layer Exp $ +;; $Id: text-style.lisp,v 2.11 2007/12/11 17:20:20 layer Exp $ (in-package :silica) @@ -151,27 +151,27 @@ ;;; if we want. (defun make-text-style (family face size &aux changed-p original-face) (unless (numberp face) - (setf original-face face - face (face->face-code face))) ;"Intern" the face code. + (setf original-face face + face (face->face-code face))) ;"Intern" the face code. (loop - (let* ((family-stuff (assoc family *text-style-intern-table*)) - (face-stuff (and family-stuff (assoc face (cdr family-stuff)))) - (size-stuff (and face-stuff (assoc size (cdr face-stuff))))) - (when size-stuff (return-from make-text-style (cdr size-stuff))) - (multiple-value-setq (family face size changed-p original-face) - (validate-text-style-components family face size original-face)) - (unless changed-p - (macrolet ((ensure-stuff (stuff thing from-stuff) - `(unless ,stuff - (setf ,stuff (cons ,thing nil)) - (with-lock-held (*text-style-lock* "Text style lock") - (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil))))))) - (ensure-stuff family-stuff family *text-style-intern-table*) - (ensure-stuff face-stuff face family-stuff) - (ensure-stuff size-stuff size face-stuff)) - (let* ((new-style (make-text-style-1 family face size nil))) - (setf (cdr size-stuff) new-style) - (return-from make-text-style new-style)))))) + (let* ((family-stuff (assoc family *text-style-intern-table*)) + (face-stuff (and family-stuff (assoc face (cdr family-stuff)))) + (size-stuff (and face-stuff (assoc size (cdr face-stuff))))) + (when size-stuff (return-from make-text-style (cdr size-stuff))) + (multiple-value-setq (family face size changed-p original-face) + (validate-text-style-components family face size original-face)) + (unless changed-p + (macrolet ((ensure-stuff (stuff thing from-stuff) + `(unless ,stuff + (setf ,stuff (cons ,thing nil)) + (with-lock-held (*text-style-lock* "Text style lock") + (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil))))))) + (ensure-stuff family-stuff family *text-style-intern-table*) + (ensure-stuff face-stuff face family-stuff) + (ensure-stuff size-stuff size face-stuff)) + (let* ((new-style (make-text-style-1 family face size nil))) + (setf (cdr size-stuff) new-style) + (return-from make-text-style new-style)))))) (defmethod text-style-index ((text-style standard-text-style)) (let ((index (slot-value text-style 'index))) @@ -628,56 +628,66 @@ (defmethod port-mapping-table ((port basic-port) character-set) (with-slots (mapping-table) port - #+allegro - (excl:ics-target-case - (:-ics character-set mapping-table) - (:+ics (svref mapping-table character-set))) - #-allegro - mapping-table)) + #+allegro + (excl:ics-target-case + (:-ics character-set mapping-table) + (:+ics (let ((old-length (length mapping-table))) + (when (>= character-set (length mapping-table)) + (setf mapping-table (adjust-array mapping-table (1+ character-set))) + (dotimes (i (- (length mapping-table) old-length)) + (setf (aref mapping-table (+ i old-length)) (make-hash-table :test #'equal)))) + (aref mapping-table character-set)))) + #-allegro + mapping-table)) (defmethod port-mapping-cache ((port basic-port) character-set) (with-slots (mapping-cache) port - #+allegro - (excl:ics-target-case - (:-ics character-set mapping-cache) - (:+ics (svref mapping-cache character-set))) - #-allegro - mapping-cache)) + #+allegro + (excl:ics-target-case + (:-ics character-set mapping-cache) + (:+ics (let ((old-length (length mapping-cache))) + (when (>= character-set (length mapping-cache)) + (setf mapping-cache (adjust-array mapping-cache (1+ character-set))) + (dotimes (i (- (length mapping-cache) old-length)) + (setf (aref mapping-cache (+ i old-length)) (cons nil nil)))) + (aref mapping-cache character-set)))) + #-allegro + mapping-cache)) (defmethod (setf text-style-mapping) (mapping (port basic-port) style - &optional (character-set *standard-character-set*) - window) + &optional (character-set *standard-character-set*) + window) (declare (ignore window)) (setq style (standardize-text-style port (parse-text-style style) character-set)) (when (listp mapping) (assert (eq (first mapping) :style) () - "Text style mappings must be atomic font names ~ + "Text style mappings must be atomic font names ~ or (:STYLE . (family face size))") (setf mapping (parse-text-style (cdr mapping)))) (with-slots (allow-loose-text-style-size-mapping) port - (let ((mapping-table (port-mapping-table port character-set)) - (mapping-cache (port-mapping-cache port character-set))) - (without-scheduling - (setf (car mapping-cache) nil - (cdr mapping-cache) nil)) - (if allow-loose-text-style-size-mapping - (multiple-value-bind (family face size) (text-style-components style) - (declare (ignore size)) - ;; NB: loose size mapping requires an EQUAL hash table! - (with-stack-list (key family face) - (let* ((fonts (gethash key mapping-table)) - (old (assoc style fonts))) - (cond (old - (setf (second old) mapping)) - (t - (push (list style mapping) fonts) - (setq fonts (sort fonts #'(lambda (e1 e2) - (< (text-style-size (first e1)) - (text-style-size (first e2)))))) - (setf (gethash (copy-list key) mapping-table) - fonts))) - mapping))) - (setf (gethash style mapping-table) mapping))))) + (let ((mapping-table (port-mapping-table port character-set)) + (mapping-cache (port-mapping-cache port character-set))) + (without-scheduling + (setf (car mapping-cache) nil + (cdr mapping-cache) nil)) + (if allow-loose-text-style-size-mapping ; ### <----!!! + (multiple-value-bind (family face size) (text-style-components style) + (declare (ignore size)) + ;; NB: loose size mapping requires an EQUAL hash table! + (with-stack-list (key family face) + (let* ((fonts (gethash key mapping-table)) + (old (assoc style fonts))) + (cond (old + (setf (second old) mapping)) + (t + (push (list style mapping) fonts) + (setq fonts (sort fonts #'(lambda (e1 e2) + (< (text-style-size (first e1)) + (text-style-size (first e2)))))) + (setf (gethash (copy-list key) mapping-table) + fonts))) + mapping))) + (setf (gethash style mapping-table) mapping))))) (defmethod (setf text-style-mapping) (mapping (port basic-port) (style device-font) &optional (character-set *standard-character-set*) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 57107ae7916f2a0d11df273fad2c64a52fcf9a66..d2f49411484ae254f7b04ec8eba7d39741170837 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-frames.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $ +;; $Id: xm-frames.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $ (in-package :xm-silica) @@ -366,7 +366,6 @@ ;;; mirror)) (defmethod realize-mirror :around ((port motif-port) (sheet motif-menu-bar)) - ;; This code fills the menu-bar. If top level items do not have ;; submenus then it creates one with a menu of its own @@ -409,7 +408,7 @@ port (if item-text-style (merge-text-styles item-text-style menu-text-style) - menu-text-style) + menu-text-style) *all-character-sets*) initargs))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index b6910ae2ddcc9c78f026dc5df0e7e6070f4b35d7..53865c7d58157e5385b08209f38769677226c287 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-gadgets.lisp,v 2.11 2007/04/17 21:45:54 layer Exp $ +;; $Id: xm-gadgets.lisp,v 2.12 2007/12/11 17:20:21 layer Exp $ (in-package :xm-silica) @@ -120,17 +120,17 @@ (when (typep label 'pattern) (with-sheet-medium (medium sheet) (setq label - (pixmap-from-pattern label medium :pixmap)))) + (pixmap-from-pattern label medium :pixmap)))) (setf (getf initargs :label-pixmap) label) ;;-- Perhaps we need to stipple this? (setf (getf initargs :label-insensitive-pixmap) label) (setf (getf initargs :label-type) :pixmap)))) (unless (getf initargs :alignment) (setf (getf initargs :alignment) - (ecase alignment - ((:left nil) :beginning) - (:center :center) - (:right :end)))) + (ecase alignment + ((:left nil) :beginning) + (:center :center) + (:right :end)))) (setf (getf initargs :recompute-size) nil)) initargs)) @@ -146,7 +146,7 @@ ((:left nil) :beginning) (:center :center) (:right :end)) - :label-string (or (gadget-label sheet) "")))) + :label-string (or (gadget-label sheet) "")))) ;;; Motif widgets that support the activate callback @@ -1178,6 +1178,7 @@ :resize-policy :none :scroll-bar-display-policy :static)) + ;;; (defclass motif-radio-box (motif-row-column-gadget-mixin diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 275c62863d59145f8ccf90cb31b0822e7d199881..ec8fb3ec0a3ef2ebe0caf7467d6d1befdf4e1ca0 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-silica.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $ +;; $Id: xm-silica.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $ (in-package :xm-silica) @@ -72,11 +72,12 @@ (and (typep (pane-frame sheet) 'clim-internals::menu-frame) '(:override-redirect t)))) - (call-next-method)) + (call-next-method)) (values class `(:keyboard-focus-policy ,(ecase (port-input-focus-selection port) (:click-to-select :explicit) (:sheet-under-pointer :pointer)) + :preedit-type "None" ,@initargs)))) (defmethod enable-xt-widget ((parent tk::xm-dialog-shell) (mirror t)) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index c9026cdf1b1d8c6bd0b7d96e921444772ad33993..3ff7c5917c33edd1990ad3c73ce8c648a8c2dd29 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-graphics.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $ +;; $Id: xt-graphics.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $ (in-package :tk-silica) @@ -1500,12 +1500,12 @@ string-or-char x y start end align-x align-y towards-x towards-y transform-glyphs) + (declare (ignorable transform-glyphs)) (let* ((port (port medium)) (sheet (medium-sheet medium)) (transform (sheet-device-transformation sheet)) (text-style (medium-merged-text-style medium)) (string (string string-or-char))) - ;;--rounding errors? (transform-positions transform x y) (when (and towards-x towards-y) @@ -1541,73 +1541,56 @@ (:baseline nil) (:top (when towards-y (incf towards-y baseline)) - (incf y baseline)))) - - (let ((y-factor 0) - (x-factor 1)) - (when (and towards-x towards-y) - (let ((xxx (- towards-x x)) - (yyy (- towards-y y))) - (cond ((zerop yyy) - (setq y-factor 0) - (setq x-factor (if (minusp xxx) -1 1))) - ((zerop xxx) - (setq x-factor 0) - (setq y-factor (if (minusp yyy) -1 1))) - (t - ;; this branch is rather expensive. - ;; avoid these calls if the calculation is trivial. jpm. - (let ((alpha (atan yyy xxx))) - (setq y-factor (sin alpha)) - (setq x-factor (cos alpha))))))) - - (flet ((process-element (codeset start end) - (let ((drawable (medium-drawable medium)) - (font (text-style-mapping port text-style codeset)) - (width (text-size sheet string :text-style text-style - :start start :end end))) - (when drawable - (fix-coordinates x y) - (discard-illegal-coordinates medium-draw-text* x y) - (let ((gc (adjust-ink - (decode-ink (medium-ink medium) medium) - medium - x - (- y (tk::font-ascent font))))) - (setf (tk::gcontext-font gc) font) - (if (and towards-x towards-y) - (if (tk::font-range font) - (port-draw-rotated-text port drawable gc x y string start end - font towards-x towards-y transform-glyphs) - (let ((*error-output* excl:*initial-terminal-io*)) - (warn "Cannot rotate 16-bit font ~A" font))) - (funcall - (excl:ics-target-case - (:+ics - ;; bug12286/spr26334 - ;; The old function, tk::draw-string16, - ;; does not properly handle "higher-numbered" - ;; ascii characters. - ;; The following is in analogy to - ;; the similar operation in - ;; convert-resource-out 'xm-string - (ecase codeset - ((0 2) 'tk::draw-string) - ((1 3) 'tk::draw-string16)) - ) - (:-ics 'tk::draw-string)) - drawable gc - x y - string start end)))) - (let ((dx (* width x-factor)) - (dy (* width y-factor))) - (incf x dx) - (incf y dy) - (when towards-x (incf towards-x dx)) - (when towards-y (incf towards-y dy)))))) - (declare (dynamic-extent #'process-element)) - (tk::partition-compound-string string #'process-element - :start start :end end))))) + (incf y baseline))) + + (let ((y-factor 0) + (x-factor 1)) + (when (and towards-x towards-y) + (let ((xxx (- towards-x x)) + (yyy (- towards-y y))) + (cond ((zerop yyy) + (setq y-factor 0) + (setq x-factor (if (minusp xxx) -1 1))) + ((zerop xxx) + (setq x-factor 0) + (setq y-factor (if (minusp yyy) -1 1))) + (t + ;; this branch is rather expensive. + ;; avoid these calls if the calculation is trivial. jpm. + (let ((alpha (atan yyy xxx))) + (setq y-factor (sin alpha)) + (setq x-factor (cos alpha))))))) + (let ((drawable (medium-drawable medium)) + (font (text-style-mapping port text-style *all-character-sets*))) + (when drawable + (fix-coordinates x y) + (discard-illegal-coordinates medium-draw-text* x y) + (let ((gc (adjust-ink + (decode-ink (medium-ink medium) medium) + medium + x + (- y height)))) + (if (and towards-x towards-y) + (excl:ics-target-case + (:+ics + (let ((*error-output* excl:*initial-terminal-io*)) + (warn "Cannot rotate 16-bit font ~A" font))) + (:-ics + (port-draw-rotated-text port drawable gc x y string start end + font towards-x towards-y transform-glyphs))) + (excl:ics-target-case + (:+ics + (tk::draw-multibyte-string drawable + (font-set-from-font-list port font) + gc x y string start end)) + (:-ics + (tk::draw-string drawable gc x y string start end)))))) + (let ((dx (* width x-factor)) + (dy (* width y-factor))) + (incf x dx) + (incf y dy) + (when towards-x (incf towards-x dx)) + (when towards-y (incf towards-y dy)))))))) (defmethod medium-text-bounding-box ((medium xt-medium) string x y start end align-x diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index dcd494fdb437643fc3922ef6962967b2d225422f..e8c957ec5994912fa6f96a9793e773c88b7fdef4 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-silica.lisp,v 2.11 2007/07/18 18:00:13 layer Exp $ +;; $Id: xt-silica.lisp,v 2.12 2007/12/11 17:20:21 layer Exp $ (in-package :xm-silica) @@ -159,6 +159,43 @@ '(:static-color :true-color :pseudo-color :direct-color)) t)) +;;; SPR30362: + +(defvar *default-fallback-font* "fixed") + +(defun list-fonts-by-registry (display) + (let* ((fonts (tk::list-font-names display "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")) + (encoding-hash (make-hash-table :test #'equal))) + (dolist (font fonts) + (let ((font* (disassemble-x-font-name font))) + (push font (gethash (last font* 2) encoding-hash)))) + encoding-hash)) + +(defun find-font-with-properties (fonts weight slant) + (or (find (list weight slant) fonts + :test #'equal + :key (lambda (font) + (let ((font* (disassemble-x-font-name font))) + (list (nth 3 font*) (nth 4 font*))))) + (first fonts))) + +(defun font-name-of-aliased-font (display fontname) + (excl:with-native-string (nfn fontname) + (let ((font (x11:xloadqueryfont display nfn))) + (unless (zerop font) + (unwind-protect + (loop for i from 0 below (x11:xfontstruct-n-properties font) + for fontprop = (+ ;; this is horrible: + (* i 2 #-64bit 4 #+64bit 8) + (x11:xfontstruct-properties font)) + when (eql x11:xa-font (x11:xfontprop-name fontprop)) + do (return (values (excl:native-to-string + (x11:xgetatomname display + (x11:xfontprop-card32 fontprop)))))) + (x11:xfreefont display font)))))) + +;;; END SPR30362 + (defparameter *xt-font-families* `( ;; ascii @@ -214,29 +251,77 @@ (screen-pixels-per-inch (* 25.4 (/ (x11::xdisplayheight display screen) (x11:xdisplayheightmm display screen))))) - (flet ((font->text-style (font family) - (flet ((parse-token (token) - (if token - (parse-integer token) - (return-from font->text-style nil)))) - (let* ((tokens (disassemble-x-font-name font)) - (italic (member (nth 4 tokens) '("i" "o") :test #'equalp)) - (bold (equalp (nth 3 tokens) "bold")) - (face (if italic - (if bold '(:bold :italic) :italic) - (if bold :bold :roman))) - (pixel-size (parse-token (nth 7 tokens))) - (point-size (parse-token (nth 8 tokens))) - (y-resolution (parse-token (nth 10 tokens))) - (average-width (parse-token (nth 12 tokens))) - (corrected-point-size (* (float point-size) - (/ y-resolution - screen-pixels-per-inch)))) - (unless (and (not *use-scalable-fonts*) - (or (eql pixel-size 0) - (eql point-size 0) - (eql average-width 0))) - (make-text-style family face (/ corrected-point-size 10))))))) + (labels ((font->text-style (font family) + (flet ((parse-token (token) + (if token + (parse-integer token) + (return-from font->text-style nil)))) + (let* ((tokens (disassemble-x-font-name font)) + (italic (member (nth 4 tokens) '("i" "o") :test #'equalp)) + (bold (equalp (nth 3 tokens) "bold")) + (face (if italic + (if bold '(:bold :italic) :italic) + (if bold :bold :roman))) + (pixel-size (parse-token (nth 7 tokens))) + (point-size (parse-token (nth 8 tokens))) + (y-resolution (parse-token (nth 10 tokens))) + (average-width (parse-token (nth 12 tokens))) + (corrected-point-size (* (float point-size) + (/ y-resolution + screen-pixels-per-inch)))) + (unless (and (not *use-scalable-fonts*) + (or (eql pixel-size 0) + (eql point-size 0) + (eql average-width 0))) + (make-text-style family face (/ corrected-point-size 10)))))) + (load-1-charset (character-set fallback families) + (let* ((matchesp nil) ;do any non-fallback fonts match? + (fallback-matches-p ;any fallback matches? + (not (null (tk::list-font-names display fallback)))) + (fallback-loadable-p ;fallback actually loadable? + (and fallback-matches-p + (excl:with-native-string (nfn fallback) + (let ((x (x11:xloadqueryfont display nfn))) + (if (not (zerop x)) + (progn + (x11:xfreefont display x) + t) + nil)))))) + (dolist (per-family families) + (destructuring-bind (family &rest patterns) per-family + (dolist (font-pattern patterns) + (dolist (xfont (tk::list-font-names display font-pattern)) + ;; this hack overcomes a bug with hp's scalable fonts + (unless (find #\* xfont) + (setf matchesp t) ;there was at least one match + (let ((text-style (font->text-style xfont family))) + ;; prefer first font satisfying this text style, so + ;; don't override if we've already defined one. + (when text-style + (unless (text-style-mapping-exists-p + port text-style character-set t) + (setf (text-style-mapping port text-style + character-set) + xfont))))))))) + ;; Set up the fallback if it looks like there is one, and + ;; complain if things look bad. Things look bad if there were + ;; matches but the fallback is not loadable. If there were + ;; no matches then don't complain even if there appears to be + ;; something wrong with the fallback, just silently don't load it + ;; (and thus define no mappings for the character set). + (cond + (fallback-loadable-p ;all is well + (setf (text-style-mapping port *undefined-text-style* + character-set) + fallback)) + ((and matchesp fallback-matches-p) + (warn "Fallback font ~A, for character set ~A, matches with XListFonts, +but is not loadable by XLoadQueryFont. Something may be wrong with the X font +setup." + fallback character-set)) + (matchesp + (warn "Fallback font ~A not loadable for character set ~A." + fallback character-set)))))) ;; Setup font mappings. This is made hairy by trying to deal ;; elegantly with possibly missing mappings and messed-up X font ;; setups. It seems to be the case that XListFonts can return @@ -249,55 +334,39 @@ ;; with it, but otherwise don't check. This should mean that if ;; this doesn't warn then things will basically run, as the ;; fallback exists for each character set, at least. - (dolist (per-charset *xt-font-families*) - (destructuring-bind (character-set fallback &rest families) per-charset - (let* ((matchesp nil) ;do any non-fallback fonts match? - (fallback-matches-p ;any fallback matches? - (not (null (tk::list-font-names display fallback)))) - (fallback-loadable-p ;fallback actually loadable? - (and fallback-matches-p - (excl:with-native-string (nfn fallback) - (let ((x (x11:xloadqueryfont display nfn))) - (if (not (zerop x)) - (progn - (x11:xfreefont display x) - t) - nil)))))) - (dolist (per-family families) - (destructuring-bind (family &rest patterns) per-family - (dolist (font-pattern patterns) - (dolist (xfont (tk::list-font-names display font-pattern)) - ;; this hack overcomes a bug with hp's scalable fonts - (unless (find #\* xfont) - (setf matchesp t) ;there was at least one match - (let ((text-style (font->text-style xfont family))) - ;; prefer first font satisfying this text style, so - ;; don't override if we've already defined one. - (when text-style - (unless (text-style-mapping-exists-p - port text-style character-set t) - (setf (text-style-mapping port text-style - character-set) - xfont))))))))) - ;; Set up the fallback if it looks like there is one, and - ;; complain if things look bad. Things look bad if there were - ;; matches but the fallback is not loadable. If there were - ;; no matches then don't complain even if there appears to be - ;; something wrong with the fallback, just silently don't load it - ;; (and thus define no mappings for the character set). - (cond - (fallback-loadable-p ;all is well - (setf (text-style-mapping port *undefined-text-style* - character-set) - fallback)) - ((and matchesp fallback-matches-p) - (warn "Fallback font ~A, for character set ~A, matches with XListFonts, -but is not loadable by XLoadQueryFont. Something may be wrong with the X font -setup." - fallback character-set)) - (matchesp - (warn "Fallback font ~A not loadable for character set ~A." - fallback character-set)))))))) + (let ((charset-number 0) + (done-registries ())) + (dolist (per-charset *xt-font-families*) + (destructuring-bind (character-set fallback &rest families) per-charset + (load-1-charset character-set fallback families) + (setf charset-number (max charset-number character-set)) + (dolist (family families) + (pushnew (last (disassemble-x-font-name (second family)) 2) done-registries + :test #'equal)))) + (format *debug-io* "done registries: ~A, last charset: ~A~%" done-registries charset-number) + ;; Now setup font mappings of fonts that the user has + ;; installed, but we don't know anything about (especially no + ;; convenient font aliases). + ;; Since we don't have any font alias names to rely on, we use + ;; the "fixed" alias to find out at least a sensible default + ;; weight and slant. + (let* ((default-fallback (disassemble-x-font-name (font-name-of-aliased-font display *default-fallback-font*))) + (weight (nth 3 default-fallback)) + (slant (nth 4 default-fallback))) + (loop for character-set from (1+ charset-number) + for encoding being the hash-keys of (list-fonts-by-registry display) using (hash-value fonts) + for fallback-font = (find-font-with-properties fonts weight slant) + for default-font-match-string = (format nil "-*-*-*-*-*-*-*-*-*-*-*-*-~A-~A" (first encoding) (second encoding)) + do (format *debug-io* "~®istering installed font ~A for enc:~A~%" character-set encoding) + do (unless (member encoding done-registries :test #'equal) + (vector-push-extend (excl:string-to-native + (format nil "~A-~A" (first encoding) (second encoding))) + tk::*font-list-tags*) + (load-1-charset character-set fallback-font + `((:fix ,default-font-match-string) + (:sans-serif ,default-font-match-string) + (:serif ,default-font-match-string)))))) + ))) (setup-stipples port display)) (defparameter *xt-logical-size-alist* @@ -405,6 +474,7 @@ setup." nil) (:expose ;; This gets called only for an XmBulletinBoard widget. + ;; -- erm, no, that's a lie. (sheet-mirror-exposed-callback widget nil event sheet) nil) (:key-press @@ -428,8 +498,10 @@ setup." (logior (state->modifiers (x11::xkeyevent-state event)) keysym-shift-mask))))) - (:key-release + #+nil ; INTERNATIONAL: we must ignore key release events + (:key-release (multiple-value-bind (character keysym) + ;; TODO/international: don't call XmbLookupString for keyrelease events! (lookup-character-and-keysym sheet widget event) (let ((keysym-shift-mask (if (typep keysym 'modifier-keysym) @@ -440,7 +512,7 @@ setup." ((:left-meta :right-meta) :meta) ((:left-super :right-super) :super) ((:left-hyper :right-hyper) :hyper))) - 0))) + 0))) (allocate-event 'key-release-event :sheet sheet :key-name keysym @@ -620,7 +692,7 @@ setup." (let ((port (port sheet)) (event-key (tk::event-type event))) (ecase event-key - ((:key-press :key-release) + (:key-press (distribute-event port (multiple-value-bind (character keysym) @@ -634,13 +706,10 @@ setup." ((:left-meta :right-meta) :meta) ((:left-super :right-super) :super) ((:left-hyper :right-hyper) :hyper))) - 0)) + 0)) (modifier-state - (if (eq event-key :key-press) - (logior (state->modifiers (x11::xkeyevent-state event)) - keysym-shift-mask) - (logandc2 (state->modifiers (x11::xkeyevent-state event)) - keysym-shift-mask))) + (logior (state->modifiers (x11::xkeyevent-state event)) + keysym-shift-mask)) ;;-- Canonicalize the only interesting key right here. ;;-- If we get a key labelled "Return", we canonicalize it ;;-- into #\Newline. @@ -653,13 +722,13 @@ setup." (make-modifier-state :shift)))) #\Newline) (t character)))) - (allocate-event (if (eq event-key :key-press) - 'key-press-event - 'key-release-event) - :sheet sheet - :key-name keysym - :character char - :modifier-state modifier-state))))) + (allocate-event 'key-press-event + :sheet sheet + :key-name keysym + :character char + :modifier-state modifier-state))))) + (:key-release nil ; INTERNATIONAL: don't do anything for key releases + ) (:button-press (let ((button (x-button->silica-button (x11::xbuttonevent-button event))) @@ -984,6 +1053,7 @@ setup." (with-slots (context) port (tk::process-one-event context mask reason))) +#+gah-this-is-broken (defmethod port-glyph-for-character ((port xt-port) character text-style &optional our-font) @@ -1020,6 +1090,38 @@ setup." (values index x-font escapement-x escapement-y origin-x origin-y bb-x bb-y)))) +(defun xrect-to-list (xr) + (list :x + (x11:xrectangle-x xr) + :y + (x11:xrectangle-y xr) + :width + ;; bounding box extents: + (x11:xrectangle-width xr) + :height + (x11:xrectangle-height xr))) + +(defmethod port-glyph-for-character ((port xt-port) character text-style &optional our-font) + (declare (ignore our-font)) ; We need the font set, not the font. + (multiple-value-bind (native-string length) (excl:string-to-native (string character)) + (unwind-protect + (tk::with-xrectangle-array (ink-return 1) + (tk::with-xrectangle-array (logical-return 1) + (let* ((fonts (text-style-mapping port text-style *all-character-sets*)) + (font-set (font-set-from-font-list port fonts))) + (x11:xmbtextextents font-set native-string + (1- length) ink-return + logical-return) + (values (char-code character) font-set + ;; escapement: + (x11:xrectangle-width logical-return) 0 + ;; origin: + 0 (abs (x11:xrectangle-y logical-return)) + ;; bounding box: + (x11:xrectangle-width logical-return) + (x11:xrectangle-height logical-return))))) + (excl:aclfree native-string)))) + (defvar *trying-fallback* nil) (defmethod find-named-font ((port xt-port) name character-set) @@ -1042,33 +1144,29 @@ setup." port *undefined-text-style* character-set))))))))) (excl:ics-target-case -(:+ics - -(defconstant +codesets+ 4) - -(defmethod text-style-mapping :around - ((port xt-port) text-style - &optional (character-set *standard-character-set*) window) - (declare (ignore window)) - (if character-set - (let ((mapping (call-next-method))) - (if (stringp mapping) - (setf (text-style-mapping port text-style character-set) - (find-named-font port mapping character-set)) - mapping)) - (let ((mappings nil)) - (dotimes (c +codesets+) - (let ((mapping (text-style-mapping port text-style c))) - (when mapping - (push (cons c mapping) mappings)))) - (reverse mappings)))) + (:+ics + + (defmethod text-style-mapping :around + ((port xt-port) text-style + &optional (character-set *standard-character-set*) window) + (declare (ignore window)) + (if character-set ; anything but *all-character-sets* + (let ((mapping (call-next-method))) + (if (stringp mapping) + (setf (text-style-mapping port text-style character-set) + (find-named-font port mapping character-set)) + mapping)) + (let ((mappings nil)) + (dotimes (c (length (slot-value port 'silica::mapping-table))) ; XXX: ugly. prettify. + (let ((mapping (text-style-mapping port text-style c))) + (when mapping + (push (cons c mapping) mappings)))) + (reverse mappings)))) (defmethod font-set-from-font-list ((port xt-port) font-list) - (let ((name "")) - (dolist (item font-list) - (setq name - (concatenate 'string - (tk::font-name (cdr item)) "," name))) + (let ((name (format nil "~{~A~^,~}" + (mapcar (lambda (font) (tk::font-name (cdr font))) + font-list)))) (with-slots (font-cache) port (setq font-list (or (gethash name font-cache) @@ -1382,48 +1480,46 @@ setup." ;;; (defun lookup-character-and-keysym (sheet mirror event) - (declare (ignore mirror) - (optimize (speed 3) (safety 0))) - (let ((port (port sheet))) - (multiple-value-bind (character keysym) - (tk::lookup-string event - (if port - (port-compose-status port) - 0)) - (setq character (and (= (length (the simple-string character)) 1) - (aref (the simple-string character) 0))) - ;; This gets stuff wrong because for example to type-< you have to - ;; use the shift key and so instead for m-< you aget m-sh-< - ;; Perhaps there is a way of checking to see whether shifting - ;; makes sense given the keyboard layout! - (when character - (let ((x (state->modifiers - (x11::xkeyevent-state event)))) - (setq character - (if (and (<= (char-int character) 26) - (not (member character - '(#\return - #\tab - #\page - #\backspace - #\linefeed - #\escape) - :test #'eq))) - (code-char - (+ (char-code character) - (1- (if (logtest x +shift-key+) - (char-int #\A) - (char-int #\a))))) - character)) - (setq character - (clim-make-char - character - (logior - (if (logtest x +control-key+) 1 0) - (if (logtest x +meta-key+) 2 0) - (if (logtest x +super-key+) 4 0) - (if (logtest x +hyper-key+) 8 0)))))) - (values character (xt-keysym->keysym keysym))))) + (declare #+nil (optimize (speed 3) (safety 0)) + (optimize (speed 0) (safety 3) (debug 3)) + (ignore sheet)) + (multiple-value-bind (character keysym) + (if (eql :key-press (tk::event-type event)) + (tk::lookup-multibyte-string event mirror)) + (setq character (and (= (length (the simple-string character)) 1) + (aref (the simple-string character) 0))) + ;; This gets stuff wrong because for example to type-< you have to + ;; use the shift key and so instead for m-< you aget m-sh-< + ;; Perhaps there is a way of checking to see whether shifting + ;; makes sense given the keyboard layout! + (when character + (let ((x (state->modifiers + (x11::xkeyevent-state event)))) + (setq character + (if (and (<= (char-int character) 26) + (not (member character + '(#\return + #\tab + #\page + #\backspace + #\linefeed + #\escape) + :test #'eq))) + (code-char + (+ (char-code character) + (1- (if (logtest x +shift-key+) + (char-int #\A) + (char-int #\a))))) + character)) + (setq character + (clim-make-char + character + (logior + (if (logtest x +control-key+) 1 0) + (if (logtest x +meta-key+) 2 0) + (if (logtest x +super-key+) 4 0) + (if (logtest x +hyper-key+) 8 0)))))) + (values character (xt-keysym->keysym keysym)))) (defun clim-make-char (character &optional (bits 0)) ;; Like cltl1:make-char but prevents the need to (require :cltl1) diff --git a/tk/font.lisp b/tk/font.lisp index 934a903d345bdf9de9862babf5579bb407ff336c..af40fbb1d6668cc7e77d935b1dec618094e39603 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: font.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $ +;; $Id: font.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $ (in-package :tk) @@ -184,6 +184,15 @@ (unless (zerop def-string) (excl:native-to-string def-string)))))) +(define-condition charsets-missing-from-fontset (warning) + ((charsets :initarg :charsets :accessor charsets-missing-from-fontset-charsets) + (created-for :initarg :created-for :accessor charsets-missing-from-fontset-created)) + (:report (lambda (stream c) + (format stream + "Missing charsets:~{ ~A,~} creating fontset for ~A" + (charsets-missing-from-fontset-charsets c) + (charsets-missing-from-fontset-created c))))) + (defmethod initialize-instance :after ((fs font-set) &key foreign-address display base-names) (unless foreign-address @@ -191,8 +200,9 @@ (create-font-set display base-names) (when missing (let ((*error-output* excl:*initial-terminal-io*)) - (warn "Missing charsets:~{ ~A,~} creating fontset for ~A" - missing base-names))) + (warn 'charsets-missing-from-fontset + :charsets missing + :created-for base-names))) (when (zerop x) (error "Cannot create fontset for ~S" base-names)) (setf (foreign-pointer-address fs) x) (register-address fs)))) diff --git a/tk/graphics.lisp b/tk/graphics.lisp index 55f28520f50aca4773fe3b808ad97df5733177f9..2d86c4578aabe8125069916d9ebdc723b78a0830 100644 --- a/tk/graphics.lisp +++ b/tk/graphics.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: graphics.lisp,v 2.7 2007/04/17 21:45:53 layer Exp $ +;; $Id: graphics.lisp,v 2.8 2007/12/11 17:20:20 layer Exp $ (in-package :tk) @@ -163,6 +163,20 @@ (+ start (clim-utils:string-to-foreign sequence)) (- end start))) +(defun draw-multibyte-string (drawable font-set gc x y string + &optional start end) + (setf start (or start 0) + end (or end (length string))) + (multiple-value-bind (native-string nbytes) + (excl:string-to-native string :start start :end end) + (x11:xmbdrawstring + (object-display drawable) + drawable + font-set + gc + x y + native-string (1- nbytes)) + (excl:aclfree native-string))) (defun draw-string (drawable gc x y string &optional (start 0) end) (unless start (setq start 0)) diff --git a/tk/resources.lisp b/tk/resources.lisp index 8cd9bac3e9c07be12e93a50c036516f17a8c4060..96817258dd5cac0f8d003356bc1526a9bf139920 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: resources.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $ +;; $Id: resources.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $ (in-package :tk) @@ -690,10 +690,7 @@ (defmethod convert-resource-in ((parent t) (type (eql 'string)) value) (unless (zerop value) - (excl:ics-target-case - (:+ics (let ((euc (excl:native-to-octets value))) - (excl:euc-to-string euc))) - (:-ics (values (excl:native-to-string value)))))) + (excl:native-to-string value))) (defmethod convert-resource-in ((parent t) (type (eql 'boolean)) value) (not (zerop value))) @@ -825,3 +822,14 @@ (make-instance 'font :display (widget-display parent) :foreign-address value)) + + +;;; Visual info + +(defmethod convert-resource-out (parent (type (eql 'visual)) value) + (declare (ignore parent)) + value) + +(defmethod convert-resource-out (parent (type (eql 'depth)) value) + (declare (ignore parent)) + value) diff --git a/tk/widget.lisp b/tk/widget.lisp index 85c6c6499d03c037028d40a9dfdc2b29dff2ffd3..16d77950163ed5daf21ed0bfef5fad38d0f38ee7 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: widget.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $ +;; $Id: widget.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $ (in-package :tk) @@ -360,6 +360,39 @@ (:+ics '("clim*xnlLanguage: japanese")))) "A list of resource specification strings") +(defparameter *external-formats-to-locale-charset-alist* + `((,(excl:find-external-format "UTF-8") . "UTF-8") + (,(excl:find-external-format "LATIN1") . "ISO-8859-1"))) + +(defun try-setting-x-locale (locale) + (format *debug-io* "Trying locale ~A~%" locale) + (setlocale lc-all locale) + (let ((supported (x-supports-locale))) + (unless (zerop supported) + (x-set-locale-modifiers "") + (format *debug-io* "X supports locale!~%") + locale))) + +(defun set-supported-x-locale () + (labels ((ef-name (ef) + (if (excl:composed-external-format-p ef) + (or (ef-name (excl:ef-composer-ef ef)) + (ef-name (excl:ef-composee-ef ef))) + (cdr (assoc ef *external-formats-to-locale-charset-alist*))))) + (let ((locale (excl:locale-name excl:*locale*)) + (encoding (ef-name (excl:locale-external-format excl:*locale*)))) + (or (if encoding + (try-setting-x-locale (format nil "~A.~A" locale encoding)) + (warn "Couldn't determine unix encoding of locale ~A's external format. Falling back to default encoding for locale." excl:*locale*)) + (try-setting-x-locale (format nil "~A" locale)) + ;; didn't find any locale. + (try-setting-x-locale "C"))))) + +(ff:defun-foreign-callable xt-current-locale-for-acl ((display (* :void)) (xnl (* :char)) (client-data (* :void))) + (declare (:convention :c) + (ignore display client-data xnl)) + (set-supported-x-locale)) + ;; note that this is different from xt-initialize which calls ;; XtToolkitInitialize. This is closer to XtAppInitialize @@ -372,11 +405,15 @@ (with-*-array (v (1+ n)) (dotimes (i n) (setf (*-array v i) - (clim-utils:string-to-foreign (nth i *fallback-resources*)))) + (clim-utils:string-to-foreign (nth i *fallback-resources*)))) (setf (*-array v n) 0) v)))) - #+ignore (excl:ics-target-case - (:+ics (xt_set_language_proc context 0 0))) + (excl:ics-target-case + (:+ics + (xt_set_language_proc 0 (register-foreign-callable + 'xt-current-locale-for-acl :reuse t) + 0) + (set-supported-x-locale))) (let* ((display (apply #'make-instance 'display :context context args)) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 1c7d6953ee003e02f683154fdf4514e5e2bd8e51..60a8dbe56811b91ee6dec7f0629e29e48987453e 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xlib.lisp,v 2.10 2007/04/17 21:45:53 layer Exp $ +;; $Id: xlib.lisp,v 2.11 2007/12/11 17:20:20 layer Exp $ (in-package :tk) @@ -331,17 +331,17 @@ (define-window-accessor colormap ()) -(defun create-colormap (display &optional (screen (display-screen-number display))) +(defun create-colormap (display &key (screen (display-screen-number display))) (intern-object-xid - (x11:xcreatecolormap - display - (x11:xrootwindow display screen) - (x11:xdefaultvisual display screen) - x11:allocnone) + (x11:xcreatecolormap display + (x11:xrootwindow display screen) + (x11:xdefaultvisual display screen) + x11:allocnone) 'colormap display :display display)) + (defun default-colormap (display &optional (screen (display-screen-number display))) (intern-object-xid (x11:xdefaultcolormap display screen) @@ -678,27 +678,6 @@ (ash 1 x) (error "cannot encode event-mask ~S" mask)))))) - -(defvar *lookup-string-buffers* nil) - -(defun lookup-string (event &optional (compose-status 0)) - (declare (optimize (speed 3) (safety 0))) - (let ((buffer (or (excl:without-interrupts (pop *lookup-string-buffers*)) - (excl::malloc 256)))) - (declare (type (unsigned-byte 8) buffer)) - ;; we assume the Xid type is the same as a pointer - (with-ref-par ((keysym 0 :unsigned-long)) - (let* ((nchars (x11:xlookupstring event buffer 256 &keysym compose-status)) - (result (make-string nchars))) - (declare (fixnum nchars) - (simple-string result)) - (dotimes (i nchars) - (declare (fixnum i)) - (setf (schar result i) - (code-char (sys:memref-int buffer 0 i :unsigned-byte)))) - (excl:without-interrupts (push buffer *lookup-string-buffers*)) - (values result keysym))))) - ;; image support (defclass image (display-object) diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp index e38a68df462ce99e42d1f0b4a0f5bec49bb9951c..fc791e31820b5cd900f327156410b6e025a6bc6c 100644 --- a/tk/xm-defs.lisp +++ b/tk/xm-defs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-defs.lisp,v 2.10 2007/04/17 21:45:53 layer Exp $ +;; $Id: xm-defs.lisp,v 2.11 2007/12/11 17:20:20 layer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -82,3 +82,10 @@ (def-c-type (xm-selected-position-array :no-defuns :no-constructor) 1 :int) (def-c-type (xm-string-table :no-defuns :no-constructor) 1 * :char) + +;;; string constants from Xm.h +(x11::def-exported-constant XmRColormap "Colormap") +(x11::def-exported-constant XmRVisual "Visual") +(x11::def-exported-constant XmRInt "Int") + +(x11::def-exported-constant XmMULTIBYTE_TEXT 1) diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp index 3deecf669ce4c11eaff95d9e8b973310f8146814..80004f18782ca08f11a720c148e5bdd64812713e 100644 --- a/tk/xm-font-list.lisp +++ b/tk/xm-font-list.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-font-list.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $ +;; $Id: xm-font-list.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $ (in-package :tk) @@ -60,49 +60,50 @@ (excl:ics-target-case (:+ics (defvar *font-list-tags* - (vector + (make-array 4 :adjustable t :fill-pointer t + :initial-contents + (list + ;; bug13059/spr27144 - we want these strings to + ;; survive a dumplisp + (excl:string-to-native "ascii") + (excl:string-to-native "kanji") + (excl:string-to-native "katakana") + (excl:string-to-native "gaiji")) - ;; bug13059/spr27144 - we want these strings to survive a dumplisp - - (excl:string-to-native "ascii") - (excl:string-to-native "kanji") - (excl:string-to-native "katakana") - (excl:string-to-native "gaiji") - - )))) + )))) (defun export-font-list (value) (when (atom value) (setq value (list value))) - (flet ((create-font-list-entry (font) - (note-malloced-object - (excl:ics-target-case - (:+ics - (let ((tag "")) - (when (consp font) - (setq tag (svref *font-list-tags* (car font)) - font (cdr font))) - (xm_font_list_entry_create tag - (etypecase font - (font xm-font-is-font) - (font-set xm-font-is-fontset)) - font))) - (:-ics - ;; perhaps this should be xm-font-list-default-tag - (xm_font_list_entry_create "" - xm-font-is-font - font)))))) - (let ((font-list - (xm_font_list_append_entry - 0 ; old entry - (create-font-list-entry (car value))))) - (dolist (font (cdr value)) - (setq font-list - (xm_font_list_append_entry font-list - (create-font-list-entry font)))) - (note-malloced-object font-list - #'free-font-list)))) + (flet ((create-font-list-entry (font) + (note-malloced-object + (excl:ics-target-case + (:+ics + (let ((tag "")) + (when (consp font) + (setq tag (aref *font-list-tags* (car font)) + font (cdr font))) + (xm_font_list_entry_create tag + (etypecase font + (font xm-font-is-font) + (font-set xm-font-is-fontset)) + font))) + (:-ics + ;; perhaps this should be xm-font-list-default-tag + (xm_font_list_entry_create "" + xm-font-is-font + font)))))) + (let ((font-list + (xm_font_list_append_entry + 0 ; old entry + (create-font-list-entry (car value))))) + (dolist (font (cdr value)) + (setq font-list + (xm_font_list_append_entry font-list + (create-font-list-entry font)))) + (note-malloced-object font-list + #'free-font-list)))) #+:dec3100 (defmethod convert-resource-out ((parent t) (type (eql 'xm-font-list)) value) diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp index dc07e7526ce85c231a613b6382cc9c0349ba533f..adede18305ee0924140476a8417d4ac674012deb 100644 --- a/tk/xm-funs.lisp +++ b/tk/xm-funs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-funs.lisp,v 2.7 2007/04/17 21:45:53 layer Exp $ +;; $Id: xm-funs.lisp,v 2.8 2007/12/11 17:20:20 layer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -24,6 +24,11 @@ (in-package :tk) +(def-foreign-call (xm_string_create_localized "XmStringCreateLocalized") + ((text :foreign-address)) + :returning :foreign-address + :call-direct t) + (def-foreign-call (xm_string_create_l_to_r "XmStringCreateLtoR") ((x :foreign-address) (y :foreign-address)) :returning :foreign-address @@ -94,6 +99,17 @@ :call-direct t :arg-checking nil) +(def-foreign-call (xm_im_mb_lookup_string "XmImMbLookupString") + ((widget :foreign-address) + (event :foreign-address) + (buffer :foreign-address) + (bytes-in-buffer :int fixnum) + (keysym :foreign-address) + (status-return :foreign-address)) + :returning :int + :call-direct t + :arg-checking nil) + (def-foreign-call (xm_add_protocol_callback "XmAddProtocolCallback") ((v :foreign-address) w x (y :foreign-address) (z :foreign-address)) :returning :void diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index a66177e800b3337bbf498a8da769eae8319e237b..c7061ef27278ecc5eeae3c62f93352a653e644f7 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xm-widgets.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $ +;; $Id: xm-widgets.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $ (in-package :tk) @@ -62,6 +62,12 @@ (excl:string-to-native "keyboardFocusPolicy"))) +(tk::add-resource-to-class (find-class 'vendor-shell) + (make-instance 'resource + :name :preedit-type + :type 'string + :original-name (excl:string-to-native + "preeditType"))) (tk::add-resource-to-class (find-class 'xm-cascade-button-gadget) (make-instance 'resource @@ -126,64 +132,68 @@ (excl:ics-target-case (:+ics + + (defvar *empty-compound-string* nil) + + (eval-when (compile) (declaim (special *font-list-tags*))) + (defun partition-compound-string (s f &key (start 0) (end (length s))) (unless (eql (length s) 0) (let ((c 0) - (index start)) - (loop - (setq c (clim-utils:char-character-set-and-index (char s index))) - (let* ((break (position-if-not - #'(lambda (x) - (eq (clim-utils:char-character-set-and-index x) c)) - s :start index :end end))) - (funcall f c index (or break end)) - (if break - (setq index break) - (return-from partition-compound-string)))))))) - - (:-ics - (defun partition-compound-string (s f &key (start 0) (end (length s))) - ;;(declare (ignore s)) - (funcall f nil start end)))) - - -(excl:ics-target-case - (:+ics - - (defvar *empty-compound-string* nil) + (index start)) + (loop + (setq c (clim-utils:char-character-set-and-index (char s index))) + (let* ((break (position-if-not + #'(lambda (x) + (eq (clim-utils:char-character-set-and-index x) c)) + s :start index :end end))) + (funcall f c index (or break end)) + (if break + (setq index break) + (return-from partition-compound-string))))))) - (eval-when (compile) (declaim (special *font-list-tags*))) - (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value) (let ((result nil)) (flet ((extract-element (codeset start end) - (let* ((substring (subseq value start end)) - (element (xm_string_create_l_to_r - (ecase codeset - ((0 2) (lisp-string-to-string8 substring)) - ((1 3) (lisp-string-to-string16 substring))) - (svref *font-list-tags* codeset)))) - (tk::add-widget-cleanup-function parent - #'destroy-generated-xm-string - element) - (let ((temp (if result - (xm_string_concat result element) - (xm_string_copy element)))) - (tk::add-widget-cleanup-function parent - #'destroy-generated-xm-string - temp) - (setq result temp))))) - (declare (dynamic-extent #'extract)) - (partition-compound-string value #'extract-element) - (or result - *empty-compound-string* - (setq *empty-compound-string* - (xm_string_create_l_to_r (clim-utils:string-to-foreign "") - (clim-utils:string-to-foreign - xm-font-list-default-tag)))))) - )) + (let* ((substring (subseq value start end)) + (element (xm_string_create_l_to_r + (ecase codeset + ((0 2) (lisp-string-to-string8 substring)) + ((1 3) (lisp-string-to-string16 substring))) + (aref *font-list-tags* codeset)))) + (tk::add-widget-cleanup-function parent + #'destroy-generated-xm-string + element) + (let ((temp (if result + (xm_string_concat result element) + (xm_string_copy element)))) + (tk::add-widget-cleanup-function parent + #'destroy-generated-xm-string + temp) + (setq result temp))))) + (declare (dynamic-extent #'extract)) + (partition-compound-string value #'extract-element) + (or result + *empty-compound-string* + (setq *empty-compound-string* + (xm_string_create_l_to_r (clim-utils:string-to-foreign "") + (clim-utils:string-to-foreign + xm-font-list-default-tag)))))) + ;; this would be nice instead, but isn't happening anytime soon (spr30362): + #+xm-string-supports-utf-8 + (let ((native-string (clim-utils:string-to-foreign value))) + (let ((xm-string (xm_string_create_localized native-string))) + (tk::add-widget-cleanup-function parent #'destroy-generated-xm-string + xm-string) + xm-string) + ))) (:-ics + + (defun partition-compound-string (s f &key (start 0) (end (length s))) + ;;(declare (ignore s)) + (funcall f nil start end)) + (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value) (let ((s1 (clim-utils:string-to-foreign value)) (s2 (clim-utils:string-to-foreign ""))) @@ -200,8 +210,7 @@ #'destroy-generated-xm-string temp) temp)) - )) - ) + ))) (defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value) (etypecase value @@ -306,3 +315,44 @@ (error 'foo) value) +(defvar *lookup-string-buffers* nil) + +(defvar *lookup-string-buffer-size* 256) + +(defmacro with-lookup-string-buffer ((var) &body body) + `(let ((,var (or (excl:without-interrupts (pop *lookup-string-buffers*)) + (excl::malloc *lookup-string-buffer-size*)))) + (declare (type (unsigned-byte 8) buffer)) ; HUH??? an 8-bit word?? + (multiple-value-prog1 + (progn ,@body) + (excl:without-interrupts (push buffer *lookup-string-buffers*))))) + +(defun lookup-multibyte-string (event widget) + (declare (optimize (speed 0) (safety 3) (debug 3))) + (with-lookup-string-buffer (buffer) + (with-ref-par ((keysym 0 :unsigned-long) + (status 0 :int)) + (let* ((nbytes (xm_im_mb_lookup_string widget event buffer + *lookup-string-buffer-size* + &keysym &status))) + (declare (fixnum nbytes)) + (format *debug-io* "Done looking up mb string: nc=~A/status=~A/event-t=~A~%" + nbytes status (event-type event)) + (force-output *debug-io*) + (cond + ((= status x11::XBufferOverflow) + (warn "Too small buffer looking up the key event at size ~A." + *lookup-string-buffer-size*) + (let ((*lookup-string-buffer-size* nbytes)) + (lookup-multibyte-string event widget))) + ((= status x11::XLookupNone) + (values nil nil)) + (t + (format *debug-io* "buffer=~A~%" + (excl:native-to-octets buffer :length nbytes)) + (let ((keysymp (or (= status x11::XLookupKeyBoth) + (= status x11::XLookupKeySym))) + (charsp (or (= status x11::XLookupKeyBoth) + (= status x11::XLookupChars)))) + (values (and charsp (excl:native-to-string buffer :length nbytes)) + (and keysymp keysym))))))))) diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp index ca55fc02e808cf9b5af286bd4d8fe35f518c644f..e98769761fc23dab6cd63e8106a24e2acb276435 100644 --- a/tk/xt-defs.lisp +++ b/tk/xt-defs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-defs.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $ +;; $Id: xt-defs.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -147,3 +147,5 @@ (def-c-type (pointer-array :no-defuns :no-constructor) 1 * char) +(x11::def-exported-constant lc-ctype 0) +(x11::def-exported-constant lc-all 6) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index 9462bfc747e2719336cbe0e4032746b31f312869..a819809c7aad0a7cb30fe29ae7c604824e3d71ea 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xt-funs.lisp,v 2.10 2007/04/17 21:45:53 layer Exp $ +;; $Id: xt-funs.lisp,v 2.11 2007/12/11 17:20:21 layer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -396,6 +396,18 @@ :call-direct t :arg-checking nil) +(def-foreign-call (x-supports-locale "XSupportsLocale") + () + :returning (:int fixnum) + :strings-convert nil + :arg-checking nil) + +(def-foreign-call (x-set-locale-modifiers "XSetLocaleModifiers") + ((x :foreign-address)) + :call-direct t + :returning :foreign-address + :arg-checking nil) + #+debug (progn diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index f6b49004b542e37838c6b57c3e19b172e17894c1..3d8307ba92aafb8bbbc45096eab268f55349da01 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -1,3 +1,10 @@ +#+(version= 8 1) +(sys:defpatch #+mswindows "climnt" #-mswindows "climxm" + 1 + "v1: full international font support" + :type :clim + :post-loadable t) + ;; copyright (c) 1985,1986 Franz Inc, Alameda, Ca. ;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA - All rights reserved. ;; copyright (c) 2002-2007 Franz Inc, Oakland, CA - All rights reserved. @@ -16,7 +23,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: excl-verification.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $ +;; $Id: excl-verification.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $ (in-package :sys) diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index 165f5987e33846f5eee3e9ad84740ff8d31e5300..385fbb80b36ac7badf96c617f332258492edd33c 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: lisp-utilities.lisp,v 2.9 2007/04/17 21:45:54 layer Exp $ +;; $Id: lisp-utilities.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $ (in-package :clim-utils) @@ -1699,23 +1699,35 @@ (setf (sys:memref-int pointer i 0 :unsigned-natural) 0))) pointer)) -;; Adapted from FF:STRING-TO-CHAR*. -;;; We aren't using FF:STRING-TO-CHAR* because it uses excl:aclmalloc. +;;; We aren't using excl:string-to-native by default because it uses +;;; excl:aclmalloc. +;; This now uses the slightly slower (locale-correct) way of +;; converting to octets first, then copying to foreign space. (defun string-to-foreign (string &optional address) "Convert a Lisp string to a C string, by copying." (declare (optimize (speed 3)) - (type string string) - (type integer address)) + (type string string) + (type integer address)) (unless (stringp string) (excl::.type-error string 'string)) - (let* ((length (length string))) - (declare (optimize (safety 0)) - (type fixnum length)) - (unless address - (setq address (_malloc (1+ length)))) - (dotimes (i length) - (declare (fixnum i)) - (setf (sys:memref-int address 0 i :unsigned-byte) - (char-code (char string i)))) - (setf (sys:memref-int address 0 length :unsigned-byte) 0) - address)) + (if address + (excl:string-to-native string :address address) + (let* ((octets (excl:string-to-octets string :null-terminate t)) + (length (length octets))) + (declare (optimize (safety 0)) + (type fixnum length)) + (setf address (_malloc length)) + (dotimes (i length) + (declare (fixnum i)) + (setf (sys:memref-int address 0 i :unsigned-byte) + (aref octets i))) + #+clim-utils::extra-careful(let ((re-char-ed (excl:octets-to-string octets))) + (assert (equal re-char-ed string) + (re-char-ed string) + "string isn't equal to re-chared octets~%~S~%~S!" string re-char-ed)))) + + #+clim-utils::extra-careful(let ((re-lisped (excl:native-to-string address))) + (assert (equal re-lisped string) + (re-lisped string) + "string isn't equal to re-chared foreign mem ~%~S~%~S!" string re-lisped)) + address) diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp index 0163323c9962e081d51c80285dc3a75e1d77aefd..ac563ce5674bea226cc28cda979bbf338b69be7e 100644 --- a/xlib/xlib-defs.lisp +++ b/xlib/xlib-defs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xlib-defs.lisp,v 2.9 2007/04/17 21:45:54 layer Exp $ +;; $Id: xlib-defs.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $ ;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. ;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design @@ -1433,6 +1433,23 @@ typedef union { Display *display; (def-exported-foreign-synonym-type xim int) (def-exported-foreign-synonym-type xic int) +(defconstant XNInputStyle "inputStyle") +(defconstant XNClientWindow "clientWindow") +(defconstant XNFocusWindow "focusWindow") +(defconstant XNPreeditState "preeditState") +(defconstant XIMPreeditNothing #x8) +(defconstant XIMPreeditPosition #x4) +(defconstant XIMStatusNothing #x400) +(defconstant XIMStatusNone #x800) + +(defconstant XIMPreeditEnable #x1) + +(defconstant XBufferOverflow -1) +(defconstant XLookupNone 1) +(defconstant XLookupChars 2) +(defconstant XLookupKeySym 3) +(defconstant XLookupKeyBoth 4) + (defconstant XrmoptionNoArg 0) (defconstant XrmoptionIsArg 1) diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index 80e64f7f7ccf267191133a0e1575a908894ff65a..0e1ae6b377f21aa0c60a91e7503b400b24a01915 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -16,7 +16,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Id: xlib-funs.lisp,v 2.9 2007/06/06 17:15:06 layer Exp $ +;; $Id: xlib-funs.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $ ;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. ;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design @@ -1779,6 +1779,16 @@ (string (:pointer char)) (length fixnum-int)) +(def-exported-foreign-function (xmbdrawstring (:name "XmbDrawString")) + (dpy (:pointer display)) + (d fixnum-drawable) + (font-set xfontset) + (gc gc) + (x fixnum-int) + (y fixnum-int) + (string (:pointer char)) + (length fixnum-int)) + (def-exported-foreign-function (xdrawstring16 (:name "XDrawString16")) (dpy (:pointer display)) (d fixnum-drawable) @@ -2010,9 +2020,14 @@ (window window) (context xcontext)) +(def-exported-foreign-function (xfilterevent (:return-type fixnum-int) + (:name "XFilterEvent")) + (event (:pointer xevent)) + (window window)) + (def-exported-foreign-function (xlookupstring (:return-type fixnum-int) (:name "XLookupString")) - (event-struct (:pointer xkeyevent)) + (event-struct (:pointer xkeyevent)) (buffer-return (:pointer char)) (bytes-buffer int) (keysym-return (:pointer keysym)) @@ -2066,3 +2081,9 @@ (:name "_XGetBitsPerPixel")) (dpy (:pointer display)) (depth int)) + +(def-exported-foreign-function (xmbtextescapement (:return-type int) + (:name "XmbTextEscapement")) + (font-set xfontset) + (string (:pointer char)) + (num-bytes int))