/usr/share/common-lisp/source/mcclim/output.lisp is in cl-mcclim 0.9.6.dfsg.cvs20100315-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :clim-internals)
(defclass standard-sheet-output-mixin ()
(
))
(defclass sheet-mute-output-mixin ()
(
))
(defclass sheet-with-medium-mixin ()
((medium :initform nil
:reader sheet-medium
:writer (setf %sheet-medium))))
(macrolet ((frob (fn &rest args)
`(defmethod ,fn ,(substitute '(medium sheet-with-medium-mixin)
'medium
args)
;; medium arg is really a sheet
(let ((medium (sheet-medium medium)))
,(if (symbolp fn)
`(,fn ,@args)
`(funcall #',fn ,@args))))))
(frob medium-foreground medium)
(frob medium-background medium)
(frob (setf medium-foreground) design medium)
(frob (setf medium-background) design medium)
(frob medium-ink medium)
(frob (setf medium-ink) design medium)
(frob medium-transformation medium)
(frob (setf medium-transformation) transformation medium)
(frob medium-clipping-region medium)
(frob (setf medium-clipping-region) region medium)
(frob medium-line-style medium)
(frob (setf medium-line-style) line-style medium)
(frob medium-default-text-style medium)
(frob (setf medium-default-text-style) text-style medium)
(frob medium-text-style medium)
(frob (setf medium-text-style) text-style medium)
(frob medium-current-text-style medium)
(frob medium-beep medium))
(defclass temporary-medium-sheet-output-mixin (sheet-with-medium-mixin)
())
(defclass permanent-medium-sheet-output-mixin (sheet-with-medium-mixin)
())
(defmethod initialize-instance :after ((sheet permanent-medium-sheet-output-mixin) &rest args)
(declare (ignore args))
;; hmm,
(setf (%sheet-medium sheet) (make-medium (port sheet) sheet))
;; hmm...
(engraft-medium (sheet-medium sheet) (port sheet) sheet))
(defmacro with-sheet-medium ((medium sheet) &body body)
(check-type medium symbol)
(let ((fn (gensym)))
`(labels ((,fn (,medium)
,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',fn))
(invoke-with-sheet-medium-bound #',fn nil ,sheet))))
(defmacro with-sheet-medium-bound ((sheet medium) &body body)
(check-type medium symbol)
(let ((fn (gensym)))
`(labels ((,fn (,medium)
,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',fn))
(invoke-with-sheet-medium-bound #',fn ,medium ,sheet))))
(defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet permanent-medium-sheet-output-mixin))
(funcall continuation (sheet-medium sheet)))
; BTS added this. CHECKME
(defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet mirrored-pixmap))
(funcall continuation (pixmap-medium sheet)))
(defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet temporary-medium-sheet-output-mixin))
(let ((old-medium (sheet-medium sheet))
(new-medium (allocate-medium (port sheet) sheet)))
(unwind-protect
(progn
(engraft-medium new-medium (port sheet) sheet)
(setf (%sheet-medium sheet) new-medium)
(funcall continuation new-medium))
(setf (%sheet-medium sheet) old-medium)
(degraft-medium new-medium (port sheet) sheet)
(deallocate-medium (port sheet) new-medium))))
;; The description of WITH-SHEET-MEDIUM-BOUND in the spec, seems to be
;; extremly bogus, what is its purpose?
(defmethod invoke-with-sheet-medium-bound (continuation
(medium basic-medium)
(sheet permanent-medium-sheet-output-mixin))
;; this seems to be extremly bogus to me.
(funcall continuation medium))
(defmethod invoke-with-sheet-medium-bound (continuation
(medium basic-medium)
(sheet temporary-medium-sheet-output-mixin))
(cond ((not (null (sheet-medium sheet)))
(funcall continuation medium))
(t
(let ((old-medium (sheet-medium sheet))
(new-medium medium))
(unwind-protect
(progn
(engraft-medium new-medium (port sheet) sheet)
(setf (%sheet-medium sheet) new-medium)
(funcall continuation new-medium))
(setf (%sheet-medium sheet) old-medium)
(degraft-medium new-medium (port sheet) sheet) )))))
(defmethod invoke-with-special-choices (continuation (sheet sheet-with-medium-mixin))
(with-sheet-medium (medium sheet)
(with-special-choices (medium)
(funcall continuation sheet))))
|