/[mcclim]/mcclim/output.lisp
ViewVC logotype

Contents of /mcclim/output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5