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

Diff of /mcclim/output.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by mikemac, Thu Jun 8 22:01:12 2000 UTC revision 1.11 by gbaumann, Thu Dec 1 11:10:55 2005 UTC
# Line 17  Line 17 
17  ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,  ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18  ;;; Boston, MA  02111-1307  USA.  ;;; Boston, MA  02111-1307  USA.
19    
20  (in-package :CLIM-INTERNALS)  (in-package :clim-internals)
21    
22  (defclass standard-sheet-output-mixin ()  (defclass standard-sheet-output-mixin ()
23    (    (
24     ))     ))
25    
26  (defclass mute-sheet-output-mixin ()  (defclass sheet-mute-output-mixin ()
27    (    (
28     ))     ))
29    
30  (defclass permanent-medium-sheet-output-mixin (standard-sheet-output-mixin)  (defclass sheet-with-medium-mixin ()
31    ((medium :accessor sheet-medium)    ((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)  (defmethod initialize-instance :after ((sheet permanent-medium-sheet-output-mixin) &rest args)
70    (declare (ignore args))    (declare (ignore args))
71    (setf (sheet-medium sheet) (make-medium (port sheet) sheet)))    ;; hmm,
72      (setf (%sheet-medium sheet) (make-medium (port sheet) sheet))
73  (defclass temporary-medium-sheet-output-mixin (standard-sheet-output-mixin)    ;; hmm...
74    ((medium :initform nil    (engraft-medium (sheet-medium sheet) (port sheet) sheet))
75             :accessor sheet-medium)  
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-form* 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-form* 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))))

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.11

  ViewVC Help
Powered by ViewVC 1.1.5