[mcclim-devel] support for clisp (2)
Bruno Haible
bruno at clisp.org
Sat Dec 18 14:18:02 UTC 2004
Part 2 of the patches are because clisp has UNICODE support but doesn't
define an EXTERNAL-FORMAT package. (It has a CHARSET package.) And McCLIM
doesn't provide a DEFPACKAGE declaration for the package EXTERNAL-FORMAT.
This is a quick hack to get things running with ASCII characters. I'm not
in the position of fixing this code because
- Fontsets are outdated technology. Modern renderers use libXft.
- The ksc5601-code-to-font-index function is incomplete. It lacks not only
the arrays ksc5601-uni2indx-page00 etc. It lacks also a notice
"Copyright (C) 1999-2002 Free Software Foundation, Inc.
This function is taken from the GNU LIBICONV Library."
I mean, I recognize code that I have written in 1999 even if it's
translated into Lisp in 2004.
- Assuming that the only languages of the world are English and Korean
is, hmm, not yet realistic. English and Chinese as sole surviving languages
is more probable in the long run.
diff -r -c3 mcclim.orig/Backends/CLX/medium.lisp mcclim/Backends/CLX/medium.lisp
*** mcclim.orig/Backends/CLX/medium.lisp 2004-04-23 21:29:49.000000000 +0200
--- mcclim/Backends/CLX/medium.lisp 2004-12-18 02:40:27.000000000 +0100
***************
*** 39,45 ****
:initform nil)
(picture
:initform nil)
! #+unicode
(fontset
:initform nil
:accessor medium-fontset)
--- 39,45 ----
:initform nil)
(picture
:initform nil)
! #+(and allegro unicode)
(fontset
:initform nil
:accessor medium-fontset)
***************
*** 55,61 ****
;;; 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
--- 55,61 ----
;;; secondary methods for changing text styles and line styles
! #-(and allegro unicode)
(defmethod (setf medium-text-style) :before (text-style (medium clx-medium))
(with-slots (gc) medium
(when gc
***************
*** 64,70 ****
(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)))
--- 64,70 ----
(setf (xlib:gcontext-font gc)
(text-style-to-X-font (port medium) (medium-text-style medium))))))))
! #+(and allegro unicode)
(defmethod (setf medium-text-style) :before (text-style (medium clx-medium))
(with-slots (fontset) medium
(let ((old-text-style (medium-text-style medium)))
***************
*** 165,173 ****
(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)))
--- 165,173 ----
(xlib:gcontext-dashes gc) (if (eq dashes t) 3
dashes)))))
(setf (xlib:gcontext-function gc) boole-1)
! #-(and allegro unicode)
(setf (xlib:gcontext-font gc) (text-style-to-X-font port (medium-text-style medium)))
! #+(and allegro 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)))
***************
*** 344,350 ****
(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*)))))
--- 344,350 ----
(let* ((line-style (medium-line-style ,medium))
(ink (medium-ink ,medium))
(gc (medium-gcontext ,medium ink))
! #+(and allegro unicode)
(*fontset* (or (medium-fontset ,medium)
(setf (medium-fontset ,medium)
(text-style-to-X-fontset (port ,medium) *default-text-style*)))))
***************
*** 608,655 ****
;;;
;;; 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
--- 608,655 ----
;;;
;;; Methods for text styles
! #-(and allegro 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)))
! #+(and allegro unicode)
(defmethod text-style-ascent (text-style (medium clx-medium))
(let ((fontset (text-style-to-X-fontset (port medium) text-style)))
(fontset-ascent fontset)))
! #-(and allegro 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)))
! #+(and allegro unicode)
(defmethod text-style-descent (text-style (medium clx-medium))
(let ((fontset (text-style-to-X-fontset (port medium) text-style)))
(fontset-descent fontset)))
! #-(and allegro 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))))
! #+(and allegro unicode)
(defmethod text-style-height (text-style (medium clx-medium))
(let ((fontset (text-style-to-X-fontset (port medium) text-style)))
(fontset-height fontset)))
! #-(and allegro 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)))
! #+(and allegro 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))
! #-(and allegro 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
***************
*** 694,700 ****
; 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)))
--- 694,700 ----
; 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...
! #+(and allegro 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)))
***************
*** 724,737 ****
(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"))
--- 724,737 ----
(return (values src nil))))))))))
(values source-start nil))))
! #+(and allegro unicode)
(in-package :external-format)
! #+(and allegro unicode)
(defun ascii-code-to-font-index (code)
(values code (<= #x00 code #x7f)))
! #+(and allegro unicode)
(defun ksc5601-code-to-font-index (wc)
(labels ((illegal-sequence ()
(error "ksc5601-wctomb"))
***************
*** 768,777 ****
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)))
--- 768,777 ----
c)
(illegal-sequence))))))
! #+(and allegro unicode)
(in-package :clim-clx)
! #-(and allegro 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)))
***************
*** 809,815 ****
direction first-not-done))
(values width (+ ascent descent) width 0 ascent)) )))))) )
! #+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)))
--- 809,815 ----
direction first-not-done))
(values width (+ ascent descent) width 0 ascent)) )))))) )
! #+(and allegro 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)))
***************
*** 850,856 ****
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
--- 850,856 ----
direction first-not-done))
(values width (+ ascent descent) width 0 ascent)) )))))) )
! #-(and allegro unicode)
(defmethod medium-draw-text* ((medium clx-medium) string x y
start end
align-x align-y
***************
*** 884,890 ****
:start start :end end
:translate #'translate)))))))
! #+unicode
(defmethod medium-draw-text* ((medium clx-medium) string x y
start end
align-x align-y
--- 884,890 ----
:start start :end end
:translate #'translate)))))))
! #+(and allegro unicode)
(defmethod medium-draw-text* ((medium clx-medium) string x y
start end
align-x align-y
diff -r -c3 mcclim.orig/Backends/CLX/port.lisp mcclim/Backends/CLX/port.lisp
*** mcclim.orig/Backends/CLX/port.lisp 2004-12-11 22:15:22.000000000 +0100
--- mcclim/Backends/CLX/port.lisp 2004-12-18 11:41:47.000000000 +0100
***************
*** 893,899 ****
(defvar *fontset* nil)
! #-unicode
(defmethod text-style-mapping ((port clx-port) text-style
&optional character-set)
(declare (ignore character-set))
--- 893,899 ----
(defvar *fontset* nil)
! #-(and allegro unicode)
(defmethod text-style-mapping ((port clx-port) text-style
&optional character-set)
(declare (ignore character-set))
***************
*** 928,934 ****
(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)
--- 928,934 ----
(open-font (clx-port-display port) font-name)))
font-name))))))
! #+(and allegro unicode)
(defun build-english-font-name (text-style)
(multiple-value-bind (family face size language)
(text-style-components text-style)
***************
*** 955,961 ****
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)
--- 955,961 ----
family-name face-name size-number)))
font-name))))
! #+(and allegro unicode)
(defun build-korean-font-name (text-style)
(multiple-value-bind (family face size language)
(text-style-components text-style)
***************
*** 986,992 ****
(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))
--- 986,992 ----
(format nil "-~A-*-*-~D-*-*-*-*-*-ksx1001.1997-*" font size-number))))
; this needs much refactoring... FIXME
! #+(and allegro unicode)
(defmethod text-style-mapping ((port clx-port) text-style
&optional character-set)
(declare (ignore character-set))
***************
*** 1026,1059 ****
(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)))
--- 1026,1059 ----
(cons font-name (open-font (clx-port-display port) font-name)))
font-name)
! #-(and allegro 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)))))
! #+(and allegro 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)))))
! #-(and allegro 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))
! #+(and allegro 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)))
! #-(and allegro 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))
! #+(and allegro 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)))
More information about the mcclim-devel
mailing list