Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2943 Modified Files: medium.lisp Log Message: Merge a hacky but functional implementation of device-font-text-styles, working on CLX, mcclim-freetype and postscript backends. No exported or documented functionality for now. --- /project/mcclim/cvsroot/mcclim/medium.lisp 2006/01/22 21:17:07 1.57 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2006/03/10 10:56:01 1.58 @@ -87,6 +87,7 @@ (defgeneric text-style-fixed-width-p (text-style medium)) (defgeneric text-style-equalp (style1 style2)) +(defmethod text-style-equalp ((style1 text-style) (style2 text-style)) nil) (defclass standard-text-style (text-style) ((family :initarg :text-family @@ -155,7 +156,7 @@ ) ; end eval-when -(defmethod print-object ((self text-style) stream) +(defmethod print-object ((self standard-text-style) stream) (print-unreadable-object (self stream :type t :identity nil) (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self))))) @@ -196,15 +197,25 @@ ;;; Device-Font-Text-Style class (defclass device-font-text-style (text-style) - ()) + ((display-device :initarg :display-device :accessor display-device) + (device-font-name :initarg :device-font-name :accessor device-font-name))) + +(defmethod print-object ((self device-font-text-style) stream) + (print-unreadable-object (self stream :type t :identity nil) + (format stream "~S on ~S" (device-font-name self) (display-device self)))) (defun device-font-text-style-p (s) (typep s 'device-font-text-style)) +(defmethod text-style-equalp ((style1 device-font-text-style) (style2 device-font-text-style)) + (eq style1 style2)) + (defmethod text-style-mapping ((port basic-port) text-style &optional character-set) (declare (ignore character-set)) - (gethash (parse-text-style text-style) (port-text-style-mappings port))) + (if (keywordp text-style) + (gethash (parse-text-style text-style) (port-text-style-mappings port)) + (gethash text-style (port-text-style-mappings port)))) (defmethod (setf text-style-mapping) (mapping (port basic-port) text-style @@ -221,11 +232,12 @@ (setf (gethash text-style (port-text-style-mappings port)) mapping)) -(defun make-device-font-text-style (port font-name) +(defgeneric make-device-font-text-style (port font-name)) + +(defmethod make-device-font-text-style (port font-name) (let ((text-style (make-instance 'device-font-text-style - :text-family font-name - :text-face nil - :text-size nil))) + :display-device port + :device-font-name font-name))) (setf (text-style-mapping port text-style) font-name) text-style))