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

Contents of /mcclim/output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide 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 mikemac 1.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 mikemac 1.9 (in-package :clim-internals)
21 mikemac 1.1
22     (defclass standard-sheet-output-mixin ()
23     (
24     ))
25    
26 rouanet 1.2 (defclass sheet-mute-output-mixin ()
27 mikemac 1.1 (
28     ))
29    
30 gilbert 1.3 (defclass sheet-with-medium-mixin ()
31     ((medium :initform nil
32     :reader sheet-medium
33     :writer (setf %sheet-medium))))
34    
35 moore 1.6 (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 hefner1 1.10 (frob medium-current-text-style medium)
61     (frob medium-beep medium))
62 moore 1.6
63 gilbert 1.3 (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 mikemac 1.1
69     (defmethod initialize-instance :after ((sheet permanent-medium-sheet-output-mixin) &rest args)
70     (declare (ignore args))
71 gilbert 1.4 ;; hmm,
72     (setf (%sheet-medium sheet) (make-medium (port sheet) sheet))
73     ;; hmm...
74     (engraft-medium (sheet-medium sheet) (port sheet) sheet))
75 gilbert 1.3
76     (defmacro with-sheet-medium ((medium sheet) &body body)
77 adejneka 1.7 (check-type medium symbol)
78 gilbert 1.3 (let ((fn (gensym)))
79     `(labels ((,fn (,medium)
80 adejneka 1.7 (declare (ignorable ,medium))
81 gilbert 1.3 ,@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 adejneka 1.7 (check-type medium symbol)
87 gilbert 1.3 (let ((fn (gensym)))
88     `(labels ((,fn (,medium)
89 adejneka 1.7 (declare (ignorable ,medium))
90 gilbert 1.3 ,@body))
91     (declare (dynamic-extent #',fn))
92     (invoke-with-sheet-medium-bound #',fn ,medium ,sheet))))
93 mikemac 1.1
94 gilbert 1.3 (defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet permanent-medium-sheet-output-mixin))
95     (funcall continuation (sheet-medium sheet)))
96    
97 brian 1.5 ; 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 gilbert 1.3 (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 adejneka 1.8
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