diff -ur mcclim-0.9.1.orig/Backends/CLX/medium.lisp mcclim-0.9.1/Backends/CLX/medium.lisp --- mcclim-0.9.1.orig/Backends/CLX/medium.lisp 2005-02-17 22:23:29.000000000 +0100 +++ mcclim-0.9.1/Backends/CLX/medium.lisp 2005-06-19 21:40:03.000000000 +0200 @@ -38,7 +38,7 @@ :initform nil) (picture :initform nil) - #+unicode + #+(or unicode sb-unicode) (fontset :initform nil :accessor medium-fontset) @@ -54,7 +54,7 @@ ;;; secondary methods for changing text styles and line styles -#-unicode +#-(or unicode sb-unicode) (defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) (with-slots (gc) medium (when gc @@ -63,7 +63,7 @@ (setf (xlib:gcontext-font gc) (text-style-to-X-font (port medium) (medium-text-style medium)))))))) -#+unicode +#+(or unicode sb-unicode) (defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) (with-slots (fontset) medium (let ((old-text-style (medium-text-style medium))) @@ -164,9 +164,9 @@ (xlib:gcontext-dashes gc) (if (eq dashes t) 3 dashes))))) (setf (xlib:gcontext-function gc) boole-1) - #-unicode + #-(or unicode sb-unicode) (setf (xlib:gcontext-font gc) (text-style-to-X-font port (medium-text-style medium))) - #+unicode + #+(or unicode sb-unicode) (setf (medium-fontset medium) (text-style-to-X-fontset port (medium-text-style medium))) (setf (xlib:gcontext-foreground gc) (X-pixel port ink) (xlib:gcontext-background gc) (X-pixel port (medium-background medium))) @@ -343,7 +343,7 @@ (let* ((line-style (medium-line-style ,medium)) (ink (medium-ink ,medium)) (gc (medium-gcontext ,medium ink)) - #+unicode + #+(or unicode sb-unicode) (*fontset* (or (medium-fontset ,medium) (setf (medium-fontset ,medium) (text-style-to-X-fontset (port ,medium) *default-text-style*))))) @@ -626,48 +626,48 @@ ;;; ;;; Methods for text styles -#-unicode +#-(or unicode sb-unicode) (defmethod text-style-ascent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (xlib:font-ascent font))) -#+unicode +#+(or unicode sb-unicode) (defmethod text-style-ascent (text-style (medium clx-medium)) (let ((fontset (text-style-to-X-fontset (port medium) text-style))) (fontset-ascent fontset))) -#-unicode +#-(or unicode sb-unicode) (defmethod text-style-descent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (xlib:font-descent font))) -#+unicode +#+(or unicode sb-unicode) (defmethod text-style-descent (text-style (medium clx-medium)) (let ((fontset (text-style-to-X-fontset (port medium) text-style))) (fontset-descent fontset))) -#-unicode +#-(or unicode sb-unicode) (defmethod text-style-height (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (+ (xlib:font-ascent font) (xlib:font-descent font)))) -#+unicode +#+(or unicode sb-unicode) (defmethod text-style-height (text-style (medium clx-medium)) (let ((fontset (text-style-to-X-fontset (port medium) text-style))) (fontset-height fontset))) -#-unicode +#-(or unicode sb-unicode) (defmethod text-style-character-width (text-style (medium clx-medium) char) (xlib:char-width (text-style-to-X-font (port medium) text-style) (char-code char))) -#+unicode +#+(or unicode sb-unicode) (defmethod text-style-character-width (text-style (medium clx-medium) char) (fontset-point-width (char-code char) (text-style-to-X-fontset (port medium) text-style))) (defmethod text-style-width (text-style (medium clx-medium)) (text-style-character-width text-style medium #\m)) -#-unicode +#-(or unicode sb-unicode) (defun translate (src src-start src-end afont dst dst-start) ;; This is for replacing the clx-translate-default-function ;; who does'nt know about accentated characters because @@ -712,7 +712,7 @@ ; It's just a proof of concept, I'll try not to commit it :] ; If it does get committed, it shouldn't affect anyone much... -#+unicode +#+(or unicode sb-unicode) (defun translate (source source-start source-end initial-font destination destination-start) ; do the first character especially (let* ((code (char-code (char source source-start))) @@ -745,11 +745,11 @@ #+unicode (in-package :external-format) -#+unicode +#+(or unicode sb-unicode) (defun ascii-code-to-font-index (code) (values code (<= #x00 code #x7f))) -#+unicode +#+(or unicode sb-unicode) (defun ksc5601-code-to-font-index (wc) (labels ((illegal-sequence () (error "ksc5601-wctomb")) @@ -786,10 +786,10 @@ c) (illegal-sequence)))))) -#+unicode +#+(or unicode sb-unicode) (in-package :clim-clx) -#-unicode +#-(or unicode sb-unicode) (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) (setf string (make-string 1 :initial-element string))) @@ -827,7 +827,7 @@ direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) -#+unicode +#+(or unicode sb-unicode) (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) (setf string (make-string 1 :initial-element string))) @@ -868,7 +868,7 @@ direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) -#-unicode +#-(or unicode sb-unicode) (defmethod medium-draw-text* ((medium clx-medium) string x y start end align-x align-y @@ -898,11 +898,12 @@ (when (and (<= #x-8000 x #x7FFF) (<= #x-8000 y #x7FFF)) (multiple-value-bind (halt width) + (break "debug: ~A ~A ~A ~A ~A" x y string start end) (xlib:draw-glyphs mirror gc x y string :start start :end end :translate #'translate))))))) -#+unicode +#+(or unicode sb-unicode) (defmethod medium-draw-text* ((medium clx-medium) string x y start end align-x align-y diff -ur mcclim-0.9.1.orig/Backends/CLX/port.lisp mcclim-0.9.1/Backends/CLX/port.lisp --- mcclim-0.9.1.orig/Backends/CLX/port.lisp 2005-02-28 00:07:41.000000000 +0100 +++ mcclim-0.9.1/Backends/CLX/port.lisp 2005-06-19 21:38:30.000000000 +0200 @@ -918,7 +918,7 @@ (defvar *fontset* nil) -#-unicode +#-(or unicode sb-unicode) (defmethod text-style-mapping ((port clx-port) text-style &optional character-set) (declare (ignore character-set)) @@ -953,7 +953,34 @@ (open-font (clx-port-display port) font-name))) font-name)))))) -#+unicode +#+sb-unicode +(defun build-unicode-font-name (text-style) + (multiple-value-bind (family face size language) + (text-style-components text-style) + (destructuring-bind (family-name face-table) + (if (stringp family) + (list family *clx-text-faces*) + (or (getf *clx-text-family+face-map* family) + (getf *clx-text-family+face-map* :fix))) + (let* ((face-name (if (stringp face) + face + (or (getf face-table + (if (listp face) + (intern (format nil "~A-~A" + (symbol-name (first face)) + (symbol-name (second face))) + :keyword) + face)) + (getf *clx-text-faces* :roman)))) + (size-number (if (numberp size) + (round size) + (or (getf *clx-text-sizes* size) + (getf *clx-text-sizes* :normal)))) + (font-name (format nil "-~A-~A-*-*-~D-*-*-*-*-*-iso10646-*" + family-name face-name size-number))) + font-name)))) + +#+(or unicode sb-unicode) (defun build-english-font-name (text-style) (multiple-value-bind (family face size language) (text-style-components text-style) @@ -980,7 +1007,7 @@ family-name face-name size-number))) font-name)))) -#+unicode +#+(or unicode sb-unicode) (defun build-korean-font-name (text-style) (multiple-value-bind (family face size language) (text-style-components text-style) @@ -1011,7 +1038,7 @@ (format nil "-~A-*-*-~D-*-*-*-*-*-ksx1001.1997-*" font size-number)))) ; this needs much refactoring... FIXME -#+unicode +#+(or unicode sb-unicode) (defmethod text-style-mapping ((port clx-port) text-style &optional character-set) (declare (ignore character-set)) @@ -1021,7 +1048,12 @@ (multiple-value-bind (family face size language) (text-style-components text-style) (let* ((display (clx-port-display port)) - (fontset (case language + (fontset #-unicode + (let* ((font-name (build-unicode-font-name text-style)) + (font (xlib:open-font display font-name))) + (make-fontset font-name (0 #xFFFF font #'identity))) + #+unicode + (case language ((nil :english) (let* ((font-name (build-english-font-name text-style)) (font (xlib:open-font display font-name))) @@ -1051,34 +1083,34 @@ (cons font-name (open-font (clx-port-display port) font-name))) font-name) -#-unicode +#-(or unicode sb-unicode) (defun text-style-to-X-font (port text-style) (let ((text-style (parse-text-style text-style))) (text-style-mapping port text-style) (cdr (gethash text-style (port-text-style-mappings port))))) -#+unicode +#+(or unicode sb-unicode) (defun text-style-to-X-fontset (port text-style) (let ((text-style (parse-text-style text-style))) (text-style-mapping port text-style) (cdr (gethash text-style (port-text-style-mappings port))))) -#-unicode +#-(or unicode sb-unicode) (defmethod port-character-width ((port clx-port) text-style char) (let* ((font (text-style-to-X-font port text-style)) (width (xlib:char-width font (char-code char)))) width)) -#+unicode +#+(or unicode sb-unicode) (defmethod port-character-width ((port clx-port) text-style char) (fontset-point-width (char-code char) (text-style-to-X-fontset port text-style))) -#-unicode +#-(or unicode sb-unicode) (defmethod port-string-width ((port clx-port) text-style string &key (start 0) end) (xlib:text-width (text-style-to-X-font port text-style) string :start start :end end)) -#+unicode ; this requires a translator and so on. +#+(or unicode sb-unicode) ; this requires a translator and so on. (defmethod port-string-width ((port clx-port) text-style string &key (start 0) end) (let ((*fontset* (text-style-to-X-fontset port text-style))) (xlib:text-width nil string :start start :end end :translator #'translate)))