[mcclim-cvs] CVS mcclim/Backends/CLX
CVS User afuchs
afuchs at common-lisp.net
Sun Jan 22 21:17:07 UTC 2006
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 , at 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)
More information about the Mcclim-cvs
mailing list