Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp:/tmp/cvs-serv5587/Backends/CLX
Modified Files: medium.lisp port.lisp Log Message: Remove the blocks marked #+unicode, and remove #-unicode tags.
As clisp includes :unicode on their *features* list, it doesn't make much sense anymore to keep code around that worked only with an experimental branch of cmucl, long ago.
--- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2005/11/28 13:01:59 1.70 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/01/22 21:17:07 1.71 @@ -36,8 +36,6 @@ (defclass clx-medium (basic-medium) ((gc :initform nil) (picture :initform nil) - #+unicode - (fontset :initform nil :accessor medium-fontset) (buffer :initform nil :accessor medium-buffer)))
#+CLX-EXT-RENDER @@ -50,7 +48,6 @@ ;;; secondary methods for changing text styles and line styles
-#-unicode (defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) (with-slots (gc) medium (when gc @@ -59,13 +56,6 @@ (setf (xlib:gcontext-font gc) (text-style-to-X-font (port medium) (medium-text-style medium))))))))
-#+unicode -(defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) - (with-slots (fontset) medium - (let ((old-text-style (medium-text-style medium))) - (unless (eq text-style old-text-style) - (setf fontset (text-style-to-X-fontset (port medium) (medium-text-style medium))))))) - ;;; Translate from CLIM styles to CLX styles. (defconstant +cap-shape-map+ '((:butt . :butt) (:square . :projecting) @@ -160,10 +150,7 @@ (xlib:gcontext-dashes gc) (if (eq dashes t) 3 dashes))))) (setf (xlib:gcontext-function gc) boole-1) - #-unicode (setf (xlib:gcontext-font gc) (text-style-to-X-font port (medium-text-style medium))) - #+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))) ;; Here is a bug with regard to clipping ... ;-( --GB ) @@ -338,11 +325,7 @@ (when mirror (let* ((line-style (medium-line-style ,medium)) (ink (medium-ink ,medium)) - (gc (medium-gcontext ,medium ink)) - #+unicode - (*fontset* (or (medium-fontset ,medium) - (setf (medium-fontset ,medium) - (text-style-to-X-fontset (port ,medium) *default-text-style*))))) + (gc (medium-gcontext ,medium ink))) line-style ink (unwind-protect (progn ,@body) @@ -624,48 +607,24 @@ ;;; ;;; Methods for text styles
-#-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 -(defmethod text-style-ascent (text-style (medium clx-medium)) - (let ((fontset (text-style-to-X-fontset (port medium) text-style))) - (fontset-ascent fontset))) - -#-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 -(defmethod text-style-descent (text-style (medium clx-medium)) - (let ((fontset (text-style-to-X-fontset (port medium) text-style))) - (fontset-descent fontset))) - -#-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 -(defmethod text-style-height (text-style (medium clx-medium)) - (let ((fontset (text-style-to-X-fontset (port medium) text-style))) - (fontset-height fontset))) - -#-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 -(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 (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 @@ -706,88 +665,6 @@ (return i) (setf (aref dst j) elt))))))
-; Yes, the following is a nasty hack. -; 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 -(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))) - (result (fontset-point code))) - (if result - (destructuring-bind ((range-start . range-stop) font translator) result - (if (not (eq font initial-font)) - ; may need to change fonts immediately: - (values source-start font) - ; otherwise, lets finish the job... - (multiple-value-bind (result success) (funcall translator code) - (setf (elt destination destination-start) result) - (do ((src (+ source-start 1) (+ src 1)) - (dst (+ destination-start 1) (+ dst 1))) - ((>= src source-end) - ; we finished - (values src nil)) - (let* ((code (char-code (char source src)))) - (if (<= range-start code range-stop) - (multiple-value-bind (result success) (funcall translator code) - (setf (elt destination dst) result)) - ; wasn't in the range... need to switch - (let ((new (fontset-point code))) - (if new - (destructuring-bind ((range-start . range-stop) font translator) new - (return (values src font))) - (return (values src nil)))))))))) - (values source-start nil)))) - -#+unicode -(in-package :external-format) - -#+unicode -(defun ascii-code-to-font-index (code) - (values code (<= #x00 code #x7f))) - -#+unicode -(defun ksc5601-code-to-font-index (wc) - (labels ((illegal-sequence () - (error "ksc5601-wctomb")) - (summary-of (array index) - (values (aref array index 0) - (aref array index 1)))) - - (multiple-value-bind (indx used) - (cond - ((<= #x0000 wc #x045f) - (summary-of ksc5601-uni2indx-page00 (ash wc -4))) - ((<= #x2000 wc #x266f) - (summary-of ksc5601-uni2indx-page20 (- (ash wc -4) #x200))) - ((<= #x3000 wc #x33df) - (summary-of ksc5601-uni2indx-page30 (- (ash wc -4) #x300))) - ((<= #x4e00 wc #x9f9f) - (summary-of ksc5601-uni2indx-page4e (- (ash wc -4) #x4e0))) - ((<= #xac00 wc #xd79f) - (summary-of ksc5601-uni2indx-pageac (- (ash wc -4) #xac0))) - ((<= #xf900 wc #xfa0f) - (summary-of ksc5601-uni2indx-pagef9 (- (ash wc -4) #xf90))) - ((<= #xff00 wc #xffef) - (summary-of ksc5601-uni2indx-pageff (- (ash wc -4) #xff0))) - (t - (illegal-sequence))) - (let ((i (logand wc #x0f))) - (if (/= 0 (logand used (ash 1 i))) - (let* ((used (logand used (- (ash 1 i) 1))) - (used (+ (logand used #x5555) (ash (logand used #xaaaa) -1))) - (used (+ (logand used #x3333) (ash (logand used #xcccc) -2))) - (used (+ (logand used #x0f0f) (ash (logand used #xf0f0) -4))) - (used (+ (logand used #x00ff) (ash used -8))) - (c (aref ksc5601-2charset (+ indx used)))) - c) - (illegal-sequence)))))) - -#+unicode -(in-package :clim-clx) - -#-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))) @@ -825,7 +702,6 @@ direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) )
-#-unicode (defmethod climi::text-bounding-rectangle* ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) @@ -866,82 +742,8 @@ ;; * font-ascent / ascent (values left (- font-ascent) right font-descent)))))))))
-#+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))) - (unless end (setf end (length string))) - (unless text-style (setf text-style (medium-text-style medium))) - (let* ((xfontset (text-style-to-X-fontset (port medium) text-style)) - (default-font (fontset-default-font xfontset))) - (cond ((= start end) - (values 0 0 0 0 0)) - (t - (let ((position-newline (position #\newline string :start start :end end))) - (cond ((not (null position-newline)) - (multiple-value-bind (width ascent descent left right - font-ascent font-descent direction - first-not-done) - (let ((*fontset* xfontset)) - (xlib:text-extents default-font string - :start start :end position-newline - :translate #'translate)) - (declare (ignorable left right - font-ascent font-descent - direction first-not-done)) - (multiple-value-bind (w h x y baseline) - (text-size medium string :text-style text-style - :start (1+ position-newline) :end end) - (values (max w width) (+ ascent descent h) - x (+ ascent descent y) (+ ascent descent baseline))))) - (t - (multiple-value-bind (width ascent descent left right - font-ascent font-descent direction - first-not-done) - (let ((*fontset* xfontset)) - (xlib:text-extents default-font string - :start start :end end - :translate #'translate)) - (declare (ignorable left right - font-ascent font-descent - direction first-not-done)) - (values width (+ ascent descent) width 0 ascent)) )))))) )
-#-unicode -(defmethod medium-draw-text* ((medium clx-medium) string x y - start end - align-x align-y - toward-x toward-y transform-glyphs) - (declare (ignore toward-x toward-y transform-glyphs)) - (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) - x y) - (with-clx-graphics (medium) - (when (characterp string) - (setq string (make-string 1 :initial-element string))) - (when (null end) (setq end (length string))) - (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) - (text-size medium string :start start :end end) - (declare (ignore x-cursor y-cursor)) - (unless (and (eq align-x :left) (eq align-y :baseline)) - (setq x (- x (ecase align-x - (:left 0) - (:center (round text-width 2)) - (:right text-width)))) - (setq y (ecase align-y - (:top (+ y baseline)) - (:center (+ y baseline (- (floor text-height 2)))) - (:baseline y) - (:bottom (+ y baseline (- text-height))))))) - (let ((x (round-coordinate x)) - (y (round-coordinate y))) - (when (and (<= #x-8000 x #x7FFF) - (<= #x-8000 y #x7FFF)) - (multiple-value-bind (halt width) - (xlib:draw-glyphs mirror gc x y string - :start start :end end - :translate #'translate)))))))
-#+unicode (defmethod medium-draw-text* ((medium clx-medium) string x y start end align-x align-y @@ -973,7 +775,6 @@ (multiple-value-bind (halt width) (xlib:draw-glyphs mirror gc x y string :start start :end end - :size 16 :translate #'translate)))))))
(defmethod medium-buffering-output-p ((medium clx-medium)) --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/01/17 16:57:47 1.118 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/01/22 21:17:07 1.119 @@ -937,7 +937,6 @@
(defvar *fontset* nil)
-#-unicode (defmethod text-style-mapping ((port clx-port) text-style &optional character-set) (declare (ignore character-set)) @@ -972,96 +971,6 @@ (open-font (clx-port-display port) font-name))) font-name))))))
-#+unicode -(defun build-english-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-*-*-*-*-*-*-*" - family-name face-name size-number))) - font-name)))) - -#+unicode -(defun build-korean-font-name (text-style) - (multiple-value-bind (family face size language) - (text-style-components text-style) - (let* ((face (if (equal face '(:bold :italic)) :bold-italic face)) - (font (case family - ((:fix nil) - (case face - ((:roman nil) "baekmuk-dotum-medium-r") - ((:bold) "baekmuk-dotum-bold-r") - ((:italic) "baekmuk-dotum-medium-r") - ((:bold-italic) "baekmuk-dotum-bold-r"))) - ((:serif) - (case face - ((:roman nil) "baekmuk-batang-medium-r") - ((:bold) "baekmuk-batang-bold-r") - ((:italic) "baekmuk-batang-medium-r") - ((:bold-italic) "baekmuk-batang-bold-r"))) - ((:sans-serif) - (case face - ((:roman nil) "baekmuk-gulim-medium-r") - ((:bold) "baekmuk-gulim-bold-r") - ((:italic) "baekmuk-gulim-medium-r") - ((:bold-italic) "baekmuk-gulim-bold-r"))))) - (size-number (if (numberp size) - (round size) - (or (getf *clx-text-sizes* size) - (getf *clx-text-sizes* :normal))))) - (format nil "-~A-*-*-~D-*-*-*-*-*-ksx1001.1997-*" font size-number)))) - -; this needs much refactoring... FIXME -#+unicode -(defmethod text-style-mapping ((port clx-port) text-style - &optional character-set) - (declare (ignore character-set)) - - (let ((table (port-text-style-mappings port))) - (or (car (gethash text-style table)) - (multiple-value-bind (family face size language) - (text-style-components text-style) - (let* ((display (clx-port-display port)) - (fontset (case language - ((nil :english) - (let* ((font-name (build-english-font-name text-style)) - (font (xlib:open-font display font-name))) - (make-fontset font-name - (0 255 font #'external-format::ascii-code-to-font-index)))) - ((:korean) - (let* ((english-font-name (build-english-font-name text-style)) - (english-font (xlib:open-font display english-font-name)) - (korean-font-name (build-korean-font-name text-style)) - (korean-font (xlib:open-font display korean-font-name))) - (make-fontset korean-font-name - (0 255 english-font - #'external-format::ascii-code-to-font-index) - (#xAC00 #xD7A3 korean-font - #'external-format::ksc5601-code-to-font-index) - (#x4E00 #x9FA5 korean-font - #'external-format::ksc5601-code-to-font-index))))))) - (setf (gethash text-style table) - (cons (fontset-name fontset) fontset)) - (fontset-name fontset)))))) - (defmethod (setf text-style-mapping) (font-name (port clx-port) (text-style text-style) &optional character-set) @@ -1070,38 +979,20 @@ (cons font-name (open-font (clx-port-display port) font-name))) font-name)
-#-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 -(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 (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 -(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 (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. -(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))) - (defmethod X-pixel ((port clx-port) color) (let ((table (slot-value port 'color-table))) (or (gethash color table)
-
CVS User afuchs