anchor.diff:  
   (defmethod medium-device-region ((medium medium))
     (sheet-device-region (medium-sheet medium)))
  -
  --
  -;;; Text-Style class
  -
  -(eval-when (eval load compile)
  -
  -(defclass text-style ()
  -  ())
  -
  -(defmethod text-style-p ((x text-style))
  -  (declare (ignorable x))
  -  t)
  -
  -(defmethod text-style-p ((x t))
  -  (declare (ignorable x))
  -  nil)
  -
  -(defclass standard-text-style (text-style)
  -  ((family :initarg :text-family
  -	   :initform :fix
  -	   :reader text-style-family)
  -   (face :initarg :text-face
  -	 :initform :roman
  -	 :reader text-style-face)
  -   (size :initarg :text-size
  -	 :initform :normal
  -	 :reader text-style-size)))
  -
  -(defun family-key (family)
  -  (ecase family
  -    ((nil) 0)
  -    ((:fix :fixed) 1)
  -    ((:serif) 2)
  -    ((:sans-serif) 3)))
  -
  -(defun face-key (face)
  -  (if (equal face '(:bold :italic))
  -      4
  -      (ecase face
  -	((nil) 0)
  -	((:roman) 1)
  -	((:bold) 2)
  -	((:italic) 3))))
  -
  -(defun size-key (size)
  -  (if (numberp size)
  -      (+ 10 (round (* 256 size)))
  -      (ecase size
  -	((nil) 0)
  -	((:tiny) 1)
  -	((:very-small) 2)
  -	((:small) 3)
  -	((:normal) 4)
  -	((:large) 5)
  -	((:very-large) 6)
  -	((:huge) 7)
  -	((:smaller 8))
  -	((:larger 9)))))
  -
  -(defun text-style-key (family face size)
  -  (+ (* 256 (size-key size))
  -     (* 16 (face-key face))
  -     (family-key family)))
  -
  -(defvar *text-style-hash-table* (make-hash-table :test #'eql))
  -
  -(defun make-text-style (family face size)
  -  (let ((key (text-style-key family face size)))
  -    (declare (type fixnum key))
  -    (or (gethash key *text-style-hash-table*)
  -	(setf (gethash key *text-style-hash-table*)
  -	      (make-instance 'standard-text-style
  -			     :text-family family
  -			     :text-face face
  -			     :text-size size)))))
  -) ; end eval-when
  -
  -(defmethod print-object ((self text-style) stream)
  -  (print-unreadable-object (self stream :type t :identity nil)
  -    (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self)))))
  -
  -(defconstant *default-text-style* (make-text-style :fix :roman :normal))
  -
  -(defconstant *smaller-sizes* '(:huge :very-large :large :normal
  -			       :small :very-small :tiny :tiny))
  -
  -(defconstant *font-scaling-factor* 4/3)
  -(defconstant *font-min-size* 6)
  -(defconstant *font-max-size* 48)
  -
  -(defun find-smaller-size (size)
  -  (if (numberp size)
  -      (max (round (/ size *font-scaling-factor*)) *font-min-size*)
  -    (cadr (member size *smaller-sizes*))))
  -
  -(defconstant *larger-sizes* '(:tiny :very-small :small :normal
  -			      :large :very-large :huge :huge))
  -
  -(defun find-larger-size (size)
  -  (if (numberp size)
  -      (min (round (* size *font-scaling-factor*)) *font-max-size*)
  -    (cadr (member size *larger-sizes*))))
  -
  -(defmethod text-style-components ((text-style standard-text-style))
  -  (values (text-style-family text-style)
  -          (text-style-face text-style)
  -          (text-style-size text-style)))
  -
  -;;; Device-Font-Text-Style class
  -
  -(defclass device-font-text-style (text-style)
  -  ())
  -
  -(defun device-font-text-style-p (s)
  -  (typep s 'device-font-text-style))
  -
  -(defun make-device-font-text-style (display-device device-font-name)
  -  (port-make-font-text-style (port display-device) device-font-name))
  -
  -;;; Text-style utilities
  -
  -(defun merge-text-styles (s1 s2)
  -  (if (and (not (device-font-text-style-p s1))
  -	   (not (device-font-text-style-p s2)))
  -      (let ((new-style (make-text-style (or (text-style-family s1)
  -					    (text-style-family s2))
  -					(or (text-style-face s1)
  -					    (text-style-face s2))
  -					(or (text-style-size s1)
  -					    (text-style-size s2)))))
  -	(with-slots (size) new-style
  -	  (case size
  -	    (:smaller
  -	     (setq size (find-smaller-size (text-style-size s2))))
  -	    (:larger
  -	     (setq size (find-larger-size (text-style-size s2))))))
  -	new-style)
  -      s1))
  -
  -(defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
  -  (invoke-with-text-style (sheet-medium sheet) continuation text-style))
  -
  -(defmethod invoke-with-text-style ((medium medium) continuation text-style)
  -  (let ((old-style (medium-text-style medium)))
  -    (setf (medium-text-style medium)
  -      (merge-text-styles text-style (medium-merged-text-style medium)))
  -    (unwind-protect
  -	(funcall continuation)
  -      (setf (medium-text-style medium) old-style))))
  -
  -(defun parse-text-style (style)
  -  (if (text-style-p style)
  -      style
  -    (let ((family nil)
  -	  (face nil)
  -	  (size nil))
  -      (loop for item in style
  -	    do (cond
  -		((member item '(fix :serif :sans-serif))
  -		 (setq family item))
  -		((or (member item '(:roman :bold :italic))
  -		     (listp item))
  -		 (setq face item))
  -		((or (member item '(:tiny :very-small :small :normal
  -				    :large :very-large :huge))
  -		     (numberp item))
  -		 (setq size item))))
  -      (make-text-style family face size))))
  -
  -(defmacro with-text-style ((medium text-style) &body body)
  -  (declare (type symbol medium))
  -  (when (eq medium t)
  -    (setq medium '*standard-output*))
  -  `(flet ((continuation ()
  -	    ,@body))
  -     #-clisp (declare (dynamic-extent #'continuation))
  -     (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
  -
  -(defmacro with-text-family ((medium family) &body body)
  -  (declare (type symbol medium))
  -  (when (eq medium t)
  -    (setq medium '*standard-output*))
  -  `(flet ((continuation ()
  -	    ,@body))
  -     #-clisp (declare (dynamic-extent #'continuation))
  -     (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
  -
  -(defmacro with-text-face ((medium face) &body body)
  -  (declare (type symbol medium))
  -  (when (eq medium t)
  -    (setq medium '*standard-output*))
  -  `(flet ((continuation ()
  -	    ,@body))
  -     #-clisp (declare (dynamic-extent #'continuation))
  -     (invoke-with-text-style ,medium
  -                             #'continuation (make-text-style nil ,face nil))))
  -
  -(defmacro with-text-size ((medium size) &body body)
  -  (declare (type symbol medium))
  -  (when (eq medium t)
  -    (setq medium '*standard-output*))
  -  `(flet ((continuation ()
  -	    ,@body))
  -     #-clisp (declare (dynamic-extent #'continuation))
  -     (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
   
    
  
positive.code:    ;; always use this slot through its accessor, since there may
     ;; be secondary methods on it -RS 2001-08-23
     (text-style :initarg :text-style
                 :initform (make-text-style :fix :roman :normal)
                 :accessor medium-text-style)
     (default-text-style :initarg :default-text-style
       :initform (make-text-style :fix :roman :normal)
       :accessor medium-default-text-style)
     (sheet :initarg :sheet
            :initform nil                 ; this means that medium is not linked to a sheet
  
negative.code: ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
  ;;; Boston, MA  02111-1307  USA.
  
  ;;;; TODO
  
  ;;; Text Styles
  
  ;; - *UNDEFINED-TEXT-STYLE* is missing
  ;; - Why is (EQ (MAKE-TEXT-STYLE NIL NIL 10) (MAKE-TEXT-STYLE NIL NIL 10.0005)) = T?
  ;;   Does it matter?
  ;; - Don't we want a weak hash-table for *TEXT-STYLE-HASH-TABLE*
  ;; - we need more macro hygiene in WITH-TEXT-STYLE
  ;;
  ;; --GB 2002-02-26
  
  ;;; Media
  
  ;; - MEDIUM-DRAW-POINTS*, MEDIUM-DRAW-LINES*, MEDIUM-DRAW-RECTANGLES*
  ;; - MEDIUM-DRAW-RECTANGLES*
  ;;
  ;; --GB 2002-02-26
  
  ;;; Notes
  
  ;; The text-style protocol is kind of useless for now. How is an
  ;; application programmer expected to implement new text-styles? I
  ;; think we would need something like:
  ;;
  ;;  TEXT-STYLE-CHARACTER-METRICS text-style character[1]
  ;;    -> width, ascent, descent, left-bearing, right-bearing
  ;;
  ;;  TEXT-STYLE-DRAW-TEXT text-style medium string x y
  ;;  Or even better:
  ;;  DESIGN-FROM-TEXT-STYLE-CHARACTER text-style character
  ;;
  ;;
  ;; And when you start to think about it, text-styles are not fonts. So
  ;; we need two protocols: A text style protocol and a font protocol. 
  ;;
  ;; A text style is then something, which maps a sequence of characters
  ;; into a couple of drawing commands, while probably using some font.
  ;;
  ;; While a font is something, which maps a _glyph index_ into a design.
  ;;
  ;; Example: Underlined with extra word spacing is a text style, while
  ;;          Adobe Times Roman 12pt is a font.
  ;;
  ;; And [it can't be said too often] unicode is not a glyph encoding
  ;; but more a kind of text formating.
  ;; 
  ;; [1] or even a code position
  ;; --GB
  
  (in-package :CLIM-INTERNALS)
  
  ;; This must come early, because of implementation quirks:
  
  (define-protocol-class medium ()
    ())
  
  ;;;;
  ;;;; 11 Text Styles
  ;;;;
  
  (eval-when (eval load compile)
  
  (define-protocol-class text-style ()
    ())
  
  (defgeneric text-style-components (text-style))
  (defgeneric text-style-family (text-style))
  (defgeneric text-style-face (text-style))
  (defgeneric text-style-size (text-style))
  (defgeneric merge-text-style (text-style-1 text-style-2))
  (defgeneric text-style-ascent (text-style medium))
  (defgeneric text-style-descent (text-style medium))
  (defgeneric text-style-height (text-style medium))
  (defgeneric text-style-width (text-style medium))
  (defgeneric text-style-fixed-width-p (text-style medium))
  
  (defclass standard-text-style (text-style)
    ((family :initarg :text-family
  	   :initform :fix
  	   :reader text-style-family)
     (face   :initarg :text-face
  	   :initform :roman
  	   :reader text-style-face)
     (size   :initarg :text-size
  	   :initform :normal
  	   :reader text-style-size)))
  
  (defun family-key (family)
    (ecase family
      ((nil) 0)
      ((:fix :fixed) 1)
      ((:serif) 2)
      ((:sans-serif) 3)))
  
  (defun face-key (face)
    (if (equal face '(:bold :italic))
        4
        (ecase face
  	((nil) 0)
  	((:roman) 1)
  	((:bold) 2)
  	((:italic) 3))))
  
  (defun size-key (size)
    (if (numberp size)
        (+ 10 (round (* 256 size)))
        (ecase size
  	((nil) 0)
  	((:tiny) 1)
  	((:very-small) 2)
  	((:small) 3)
  	((:normal) 4)
  	((:large) 5)
  	((:very-large) 6)
  	((:huge) 7)
  	((:smaller 8))
  	((:larger 9)))))
  
  (defun text-style-key (family face size)
    (+ (* 256 (size-key size))
       (* 16 (face-key face))
       (family-key family)))
  
  (defvar *text-style-hash-table* (make-hash-table :test #'eql))
  
  (defun make-text-style (family face size)
    (let ((key (text-style-key family face size)))
      (declare (type fixnum key))
      (or (gethash key *text-style-hash-table*)
  	(setf (gethash key *text-style-hash-table*)
  	      (make-instance 'standard-text-style
  			     :text-family family
  			     :text-face face
  			     :text-size size)))))
  ) ; end eval-when
  
  (defmethod print-object ((self text-style) stream)
    (print-unreadable-object (self stream :type t :identity nil)
      (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self)))))
  
  (defconstant *default-text-style* (make-text-style :fix :roman :normal))
  
  (defconstant *smaller-sizes* '(:huge :very-large :large :normal
  			       :small :very-small :tiny :tiny))
  
  (defconstant *font-scaling-factor* 4/3)
  (defconstant *font-min-size* 6)
  (defconstant *font-max-size* 48)
  
  (defun find-smaller-size (size)
    (if (numberp size)
        (max (round (/ size *font-scaling-factor*)) *font-min-size*)
      (cadr (member size *smaller-sizes*))))
  
  (defconstant *larger-sizes* '(:tiny :very-small :small :normal
  			      :large :very-large :huge :huge))
  
  (defun find-larger-size (size)
    (if (numberp size)
        (min (round (* size *font-scaling-factor*)) *font-max-size*)
      (cadr (member size *larger-sizes*))))
  
  (defmethod text-style-components ((text-style standard-text-style))
    (values (text-style-family text-style)
            (text-style-face text-style)
            (text-style-size text-style)))
  
  ;;; Device-Font-Text-Style class
  
  (defclass device-font-text-style (text-style)
    ())
  
  (defun device-font-text-style-p (s)
    (typep s 'device-font-text-style))
  
  (defun make-device-font-text-style (display-device device-font-name)
    (port-make-font-text-style (port display-device) device-font-name))
  
  ;;; Text-style utilities
  
  (defun merge-text-styles (s1 s2)
    (if (and (not (device-font-text-style-p s1))
  	   (not (device-font-text-style-p s2)))
        (let ((new-style (make-text-style (or (text-style-family s1)
  					    (text-style-family s2))
  					(or (text-style-face s1)
  					    (text-style-face s2))
  					(or (text-style-size s1)
  					    (text-style-size s2)))))
  	(with-slots (size) new-style
  	  (case size
  	    (:smaller
  	     (setq size (find-smaller-size (text-style-size s2))))
  	    (:larger
  	     (setq size (find-larger-size (text-style-size s2))))))
  	new-style)
        s1))
  
  (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
    (invoke-with-text-style (sheet-medium sheet) continuation text-style))
  
  (defmethod invoke-with-text-style ((medium medium) continuation text-style)
    (let ((old-style (medium-text-style medium)))
      (setf (medium-text-style medium)
        (merge-text-styles text-style (medium-merged-text-style medium)))
      (unwind-protect
  	(funcall continuation)
        (setf (medium-text-style medium) old-style))))
  
  (defun parse-text-style (style)
    (if (text-style-p style)
        style
      (let ((family nil)
  	  (face nil)
  	  (size nil))
        (loop for item in style
  	    do (cond
  		((member item '(fix :serif :sans-serif))
  		 (setq family item))
  		((or (member item '(:roman :bold :italic))
  		     (listp item))
  		 (setq face item))
  		((or (member item '(:tiny :very-small :small :normal
  				    :large :very-large :huge))
  		     (numberp item))
  		 (setq size item))))
        (make-text-style family face size))))
  
  (defmacro with-text-style ((medium text-style) &body body)
    (declare (type symbol medium))
    (when (eq medium t)
      (setq medium '*standard-output*))
    `(flet ((continuation ()
  	    ,@body))
       #-clisp (declare (dynamic-extent #'continuation))
       (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
  
  (defmacro with-text-family ((medium family) &body body)
    (declare (type symbol medium))
    (when (eq medium t)
      (setq medium '*standard-output*))
    `(flet ((continuation ()
  	    ,@body))
       #-clisp (declare (dynamic-extent #'continuation))
       (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
  
  (defmacro with-text-face ((medium face) &body body)
    (declare (type symbol medium))
    (when (eq medium t)
      (setq medium '*standard-output*))
    `(flet ((continuation ()
  	    ,@body))
       #-clisp (declare (dynamic-extent #'continuation))
       (invoke-with-text-style ,medium
                               #'continuation (make-text-style nil ,face nil))))
  
  (defmacro with-text-size ((medium size) &body body)
    (declare (type symbol medium))
    (when (eq medium t)
      (setq medium '*standard-output*))
    `(flet ((continuation ()
  	    ,@body))
       #-clisp (declare (dynamic-extent #'continuation))
       (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
  
  
  ;;; MEDIUM class
  
  (defclass basic-medium (medium)
    ((foreground :initarg :foreground
  