/[mcclim]/mcclim/protocol-classes.lisp
ViewVC logotype

Contents of /mcclim/protocol-classes.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Wed Jan 28 19:27:22 2009 UTC (5 years, 2 months ago) by crhodes
Branch: MAIN
CVS Tags: HEAD
Changes since 1.4: +2 -4 lines
The spec says that PORT is an accessor on frame-manager; remove
CLIMI::FRAME-MANAGER-PORT and implement PORT instead.  Fixup all uses
that I can find.

(Motivated by Climacs's own frame management)
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2006 by Tim Moore (moore@bricoworks.com)
4 ;;; This library is free software; you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Library General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 2 of the License, or (at your option) any later version.
8 ;;;
9 ;;; This library is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Library General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Library General Public
15 ;;; License along with this library; if not, write to the
16 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17 ;;; Boston, MA 02111-1307 USA.
18
19 ;;; Collect all the class definitions in the Spec in one file that is compiled
20 ;;; and loaded early.
21
22 (in-package :clim-internals)
23
24 (defmacro define-protocol-class (name super-classes &optional slots &rest options)
25 (let* ((sym-name (symbol-name name))
26 (protocol-predicate
27 (intern (concatenate 'string
28 sym-name
29 (if (find #\- sym-name) "-" "")
30 (symbol-name '#:p))))
31 (predicate-docstring
32 (concatenate 'string
33 "Protocol predicate checking for class " sym-name)))
34 `(progn
35 (defclass ,name ,super-classes ,slots ,@options)
36
37 (let ((the-class (find-class ',name)))
38 (setf (documentation the-class 'type) "CLIM protocol class")
39 (defmethod initialize-instance :after ((object ,name) &key &allow-other-keys)
40 (when (eq (class-of object) the-class)
41 (error "~S is a protocol class and thus can't be instantiated" ',name))))
42
43 (defgeneric ,protocol-predicate (object)
44 (:method ((object t))
45 nil)
46 (:method ((object ,name))
47 t)
48 (:documentation ,predicate-docstring))
49
50 ',name)))
51
52 ;;; 3.1 General Regions
53 (define-protocol-class bounding-rectangle ())
54
55
56 (define-protocol-class region (design))
57 (define-protocol-class path (region bounding-rectangle))
58 (define-protocol-class area (region bounding-rectangle))
59 (define-protocol-class region-set (region bounding-rectangle))
60 (define-protocol-class point (region bounding-rectangle))
61 (define-protocol-class polyline (path))
62 (define-protocol-class polygon (area))
63 (define-protocol-class line (polyline))
64 (define-protocol-class rectangle (polygon))
65 (define-protocol-class ellipse (area))
66 (define-protocol-class elliptical-arc (path))
67
68 ;;; 5.1 Transformations
69 (define-protocol-class transformation ())
70
71 ;;; 7.1 Basic Sheet Classes
72 (define-protocol-class sheet (bounding-rectangle))
73
74 ;;; 8.2 Standard Device Events
75 (define-protocol-class event ()
76 ())
77
78 ;;; 8.3.1 Output Properties
79
80 (define-protocol-class medium ()
81 ())
82
83 ;;; 9.2 Ports
84 (define-protocol-class port ())
85
86 ;;; 10.3 Line Styles
87
88 (define-protocol-class line-style ())
89
90 ;;; 11.1 Text Styles
91
92 (define-protocol-class text-style ()
93 ())
94
95 ;;; 13.2 Basic Designs
96
97 (define-protocol-class design ())
98
99 ;;; 13.3 Color class
100
101 (define-protocol-class color (design))
102
103 ;;; 13.4
104
105 (define-protocol-class opacity (design))
106
107 ;;; 15.2 Extended Output Streams
108 (define-protocol-class extended-output-stream
109 (fundamental-character-output-stream)
110 ;; CLIM Specification says that E-O-S is a subclass of
111 ;; OUTPUT-STREAM, but it does not says what is it.
112 ())
113
114 ;;; 15.3 The Text Cursor
115 (define-protocol-class cursor ())
116
117 ;;; 16.2 Output Records
118 (define-protocol-class output-record (bounding-rectangle)
119 ())
120
121 (define-protocol-class displayed-output-record (output-record)
122 ())
123
124 ;;; 16.3.2 Graphics Displayed Output Records
125 (define-protocol-class graphics-displayed-output-record
126 (displayed-output-record)
127 ())
128
129 ;;; 16.3.3 Text Displayed Output Record
130 (define-protocol-class text-displayed-output-record (displayed-output-record)
131 ())
132
133 ;;; 16.4 Output Recording Streams
134 (define-protocol-class output-recording-stream ()
135 ())
136
137 ;;; 17.3.1 Table Formatting Protocol
138 (define-protocol-class table-output-record (output-record))
139
140 ;;; 17.3.2 Row and Column Formatting Protocol
141 (define-protocol-class row-output-record (output-record))
142 (define-protocol-class column-output-record (output-record))
143
144 ;;; 17.3.3 Cell Formatting Protocol
145 (define-protocol-class cell-output-record (output-record))
146
147 ;;; 17.3.4 Item List Formatting Protocol
148 (define-protocol-class item-list-output-record ()
149 ())
150
151 ;;; 18.2 The Graph Formatting Protocol
152 (define-protocol-class graph-output-record (output-record))
153 (define-protocol-class graph-node-output-record (output-record))
154
155 ;;; 21.3 Incremental Redisplay Protocol
156 (define-protocol-class updating-output-record (output-record))
157
158 ;;; 22.2 Extended Input Streams
159
160 (define-protocol-class extended-input-stream
161 (fundamental-character-input-stream)
162 ())
163
164 ;;; 22.4 The Pointer Protocol
165
166 (define-protocol-class pointer ()
167 ())
168
169 ;;; 23.2 Presentations
170 (define-protocol-class presentation ())
171
172 ;;; 23.6 Views
173 (define-protocol-class view ())
174
175 ;;; 24.1.1 The Input Editing Stream Protocol
176 (define-protocol-class input-editing-stream ())
177
178 ;;; 27.2 Command Tables
179 (define-protocol-class command-table ()
180 ())
181
182 ;;; 28.2 Application Frames
183 (define-protocol-class application-frame ()
184 ())
185
186 ;;; 28.5 Frame Managers
187 ;;; XXX The slot definitions shouldn't be here, but there is no
188 ;;; standard-frame-manager and I don't want to add these slots to all the frame
189 ;;; manager classes right now.
190 (define-protocol-class frame-manager ()
191 ((port :initarg :port :reader port)
192 (frames :initform nil :reader frame-manager-frames)))
193
194 ;;; 30.3 Basic Gadget Classes
195 ;;; XXX Slots definitions should be banished.
196 (define-protocol-class gadget (pane)
197 ((id :initarg :id
198 :initform (gensym "GADGET")
199 :accessor gadget-id)
200 (client :initarg :client
201 :initform *application-frame*
202 :accessor gadget-client)
203 (armed-callback :initarg :armed-callback
204 :initform nil
205 :reader gadget-armed-callback)
206 (disarmed-callback :initarg :disarmed-callback
207 :initform nil
208 :reader gadget-disarmed-callback)
209 ;; [Arthur] I'm not so sure about the value for :initform.
210 ;; Maybe T is better? Or maybe we should call
211 ;; ACTIVATE-GADGET after creating a gadget?
212 ;;
213 ;; I think, T is correct here --GB
214
215 (active-p :initform t :initarg :active
216 :reader gadget-active-p)
217 ;;
218 ;; I am not so lucky with the armed slot in GADGET --GB
219 (armed :initform nil)
220
221 ))
222
223 ;;; C.1 Encapsulating Streams
224 (define-protocol-class encapsulating-stream ()
225 ())
226

  ViewVC Help
Powered by ViewVC 1.1.5