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

Contents of /mcclim/output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sun Feb 10 01:13:23 2002 UTC (12 years, 2 months ago) by gilbert
Branch: MAIN
Changes since 1.2: +64 -8 lines
Practically a rewrite.

WITH-SHEET-MEDIUM
WITH-SHEET-MEDIUM-BOUND
    These macros moved here from medium.lisp.
    Also these invoke INVOKE-WITH-SHEET-MEDIUM-BOUND now,
    which may specialize.

INVOKE-WITH-SHEET-MEDIUM-BOUND
    New generic function.
    Note: We might want to export this function.
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 (defclass temporary-medium-sheet-output-mixin (sheet-with-medium-mixin)
36 ())
37
38 (defclass permanent-medium-sheet-output-mixin (sheet-with-medium-mixin)
39 ())
40
41 (defmethod initialize-instance :after ((sheet permanent-medium-sheet-output-mixin) &rest args)
42 (declare (ignore args))
43 (setf (%sheet-medium sheet) (make-medium (port sheet) sheet)))
44
45 (defmacro with-sheet-medium ((medium sheet) &body body)
46 (let ((fn (gensym)))
47 `(labels ((,fn (,medium)
48 ,@body))
49 (declare (dynamic-extent #',fn))
50 (invoke-with-sheet-medium-bound #',fn nil ,sheet))))
51
52 (defmacro with-sheet-medium-bound ((sheet medium) &body body)
53 (let ((fn (gensym)))
54 `(labels ((,fn (,medium)
55 ,@body))
56 (declare (dynamic-extent #',fn))
57 (invoke-with-sheet-medium-bound #',fn ,medium ,sheet))))
58
59 (defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet permanent-medium-sheet-output-mixin))
60 (funcall continuation (sheet-medium sheet)))
61
62 (defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet temporary-medium-sheet-output-mixin))
63 (let ((old-medium (sheet-medium sheet))
64 (new-medium (allocate-medium (port sheet) sheet)))
65 (unwind-protect
66 (progn
67 (engraft-medium new-medium (port sheet) sheet)
68 (setf (%sheet-medium sheet) new-medium)
69 (funcall continuation new-medium))
70 (setf (%sheet-medium sheet) old-medium)
71 (degraft-medium new-medium (port sheet) sheet)
72 (deallocate-medium (port sheet) new-medium))))
73
74 ;; The description of WITH-SHEET-MEDIUM-BOUND in the spec, seems to be
75 ;; extremly bogus, what is its purpose?
76
77 (defmethod invoke-with-sheet-medium-bound (continuation
78 (medium basic-medium)
79 (sheet permanent-medium-sheet-output-mixin))
80 ;; this seems to be extremly bogus to me.
81 (funcall continuation medium))
82
83 (defmethod invoke-with-sheet-medium-bound (continuation
84 (medium basic-medium)
85 (sheet temporary-medium-sheet-output-mixin))
86 (cond ((not (null (sheet-medium sheet)))
87 (funcall continuation medium))
88 (t
89 (let ((old-medium (sheet-medium sheet))
90 (new-medium medium))
91 (unwind-protect
92 (progn
93 (engraft-medium new-medium (port sheet) sheet)
94 (setf (%sheet-medium sheet) new-medium)
95 (funcall continuation new-medium))
96 (setf (%sheet-medium sheet) old-medium)
97 (degraft-medium new-medium (port sheet) sheet) )))))

  ViewVC Help
Powered by ViewVC 1.1.5