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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (hide annotations)
Fri Mar 21 22:07:06 2003 UTC (11 years ago) by mikemac
Branch: MAIN
Changes since 1.38: +1 -1 lines
make all code lowercase for ACL's java mode - leave gensyms alone
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3 mikemac 1.19 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.5 ;;; (c) copyright 2000 by
5     ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6     ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8 mikemac 1.1
9     ;;; This library is free software; you can redistribute it and/or
10     ;;; modify it under the terms of the GNU Library General Public
11     ;;; License as published by the Free Software Foundation; either
12     ;;; version 2 of the License, or (at your option) any later version.
13     ;;;
14     ;;; This library is distributed in the hope that it will be useful,
15     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17     ;;; Library General Public License for more details.
18     ;;;
19     ;;; You should have received a copy of the GNU Library General Public
20     ;;; License along with this library; if not, write to the
21     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22     ;;; Boston, MA 02111-1307 USA.
23    
24 mikemac 1.38 (in-package :clim-internals)
25 mikemac 1.1
26 mikemac 1.39 (defvar *default-server-path* nil)
27 mikemac 1.22
28 mikemac 1.32 (defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl))
29 mikemac 1.22
30     (defun find-default-server-path ()
31     (loop for port in *server-path-search-order*
32     if (get port :port-type)
33     do (return-from find-default-server-path (list port))
34     finally (error "No CLIM backends have been loaded!")))
35 mikemac 1.1
36     (defvar *all-ports* nil)
37    
38 gilbert 1.37 (define-protocol-class port ())
39 gilbert 1.21
40     (defclass basic-port (port)
41 mikemac 1.1 ((server-path :initform nil
42     :initarg :server-path
43     :reader port-server-path)
44     (properties :initform nil
45     :initarg :properties)
46     (grafts :initform nil
47     :accessor port-grafts)
48     (frame-managers :initform nil
49     :reader frame-managers)
50     (sheet->mirror :initform (make-hash-table :test #'eq))
51     (mirror->sheet :initform (make-hash-table :test #'eq))
52 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
53     (mirror->pixmap :initform (make-hash-table :test #'eq))
54 mikemac 1.1 (keyboard-input-focus :initform nil
55     :initarg :keyboard-input-focus
56     :accessor port-keyboard-input-focus)
57 gilbert 1.21 (event-process
58     :initform nil
59     :initarg :event-process
60     :accessor port-event-process
61     :documentation "In a multiprocessing environment, the particular process
62     reponsible for calling PROCESS-NEXT-EVENT in a loop.")
63 adejneka 1.34
64 gilbert 1.21 (lock
65     :initform (make-recursive-lock "port lock")
66 mikemac 1.25 :accessor port-lock)
67     (event-count :initform 0)
68 adejneka 1.34 (text-style-mappings :initform (make-hash-table :test #'eq)
69     :reader port-text-style-mappings)
70 moore 1.36 (pointer-sheet :initform nil :accessor port-pointer-sheet
71     :documentation "The sheet the pointer is over, if any")
72 mikemac 1.25 ))
73 mikemac 1.1
74     (defun find-port (&key (server-path *default-server-path*))
75 mikemac 1.22 (if (null server-path)
76     (setq server-path (find-default-server-path)))
77     (if (atom server-path)
78     (setq server-path (list server-path)))
79     (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
80 mikemac 1.1 (loop for port in *all-ports*
81     if (equal server-path (port-server-path port))
82     do (return port)
83     finally (let ((port-type (get (first server-path) :port-type))
84     port)
85     (if (null port-type)
86     (error "Don't know how to make a port of type ~S" server-path))
87     (setq port (funcall 'make-instance port-type :server-path server-path))
88     (push port *all-ports*)
89     (return port))))
90    
91 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
92     (declare (ignorable args))
93     )
94    
95     (defmethod destroy-port :before ((port basic-port))
96 adejneka 1.33 (when (and *multiprocessing-p* (port-event-process port))
97 gilbert 1.21 (destroy-process (port-event-process port))
98     (setf (port-event-process port) nil)))
99    
100     (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
101 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
102    
103 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
104 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
105    
106 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
107 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
108     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
109     nil)
110    
111 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
112 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
113     (remhash mirror (slot-value port 'mirror->sheet))
114     nil)
115    
116 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
117 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
118    
119 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
120 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
121 mikemac 1.1
122 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
123 rouanet 1.16 (declare (ignore mirror))
124     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
125    
126 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
127 mikemac 1.1 (with-slots (properties) port
128     (getf properties indicator)))
129    
130 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
131 mikemac 1.1 (with-slots (properties) port
132     (setf (getf properties indicator) value)))
133    
134 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
135 mikemac 1.1 (declare (ignore wait-function timeout))
136     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
137    
138 mikemac 1.25 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
139     (declare (ignore wait-function timeout))
140     (with-slots (event-count) port
141     (incf event-count)))
142    
143 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
144 moore 1.26 (let ((event (get-next-event port
145     :wait-function wait-function
146     :timeout timeout)))
147 mikemac 1.1 (cond
148     ((null event) nil)
149     ((eq event :timeout) (values nil :timeout))
150     (t
151 moore 1.27 (distribute-event port event)
152 mikemac 1.1 t))))
153    
154 moore 1.27 ;;; Called in the application frame process.
155 moore 1.26 (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout
156     ((:event-count old-count) nil))
157 mikemac 1.25 (declare (ignorable wait-function))
158 moore 1.29 (with-slots (event-count) port
159     (if *multiprocessing-p*
160 moore 1.26 (let ((old-event-count (or old-count event-count))
161 mikemac 1.25 (flag nil))
162 moore 1.27 (flet ((wait-fn ()
163     (when (not (eql old-event-count event-count))
164     (setq flag t))))
165     (if timeout
166     (process-wait-with-timeout "Wait for event" timeout #'wait-fn)
167     (process-wait "Wait for event" #'wait-fn))
168     (if flag
169     event-count
170 moore 1.29 (values nil :timeout))))
171     (multiple-value-bind (result reason)
172     (process-next-event port
173     :wait-function wait-function
174     :timeout timeout)
175     (values (and result event-count) reason)))))
176 mikemac 1.25
177 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
178 mikemac 1.1 (cond
179     ((typep event 'keyboard-event)
180 moore 1.35 (dispatch-event (or (port-keyboard-input-focus port) (event-sheet event))
181     event))
182 mikemac 1.1 ((typep event 'window-event)
183 brian 1.28 ; (dispatch-event (window-event-mirrored-sheet event) event)
184 cvs 1.4 (dispatch-event (event-sheet event) event))
185 mikemac 1.1 ((typep event 'pointer-event)
186     (dispatch-event (event-sheet event) event))
187 mikemac 1.23 ((typep event 'window-manager-delete-event)
188     ;; not sure where this type of event should get sent - mikemac
189 moore 1.27 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
190     (dispatch-event (event-sheet event) event))
191 mikemac 1.1 ((typep event 'timer-event)
192     (error "Where do we send timer-events?"))
193     (t
194     (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
195    
196 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
197     (let ((fn (gensym "CONT.")))
198     `(labels ((,fn ()
199     ,@body))
200     (declare (dynamic-extent #',fn))
201 moore 1.29 (invoke-with-port-locked ,port #',fn))))
202 gilbert 1.21
203     (defmethod invoke-with-port-locked ((port basic-port) continuation)
204     (with-recursive-lock-held ((port-lock port))
205     (funcall continuation)))
206    
207 mikemac 1.1 (defun map-over-ports (function)
208     (mapc function *all-ports*))
209    
210 gilbert 1.21 (defmethod restart-port ((port basic-port))
211 mikemac 1.1 (reset-watcher port :restart)
212     nil)
213    
214 gilbert 1.21 (defmethod destroy-port ((port basic-port))
215 mikemac 1.1 (reset-watcher port :destroy)
216     (setf *all-ports* (remove port *all-ports*)))
217    
218 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
219 mikemac 1.1 (declare (ignore watcher))
220     nil)
221    
222 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
223 mikemac 1.1 (declare (ignore watcher))
224     nil)
225    
226 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
227 mikemac 1.1 (declare (ignore how))
228     nil)
229    
230 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
231 mikemac 1.1 (let ((graft (make-instance 'graft
232     :port port :mirror nil
233     :orientation orientation :units units)))
234     (push graft (port-grafts port))
235     graft))
236    
237 gilbert 1.21 #||
238     (defmethod make-medium ((port basic-port) sheet)
239 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
240 gilbert 1.21 ||#
241 mikemac 1.1
242 cvs 1.10 ;;; Pixmap
243    
244 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
245 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
246    
247 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
248 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
249    
250 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
251 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
252     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
253     nil)
254    
255 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
256 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
257     (remhash mirror (slot-value port 'mirror->pixmap))
258     nil)
259    
260 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
261 cvs 1.10 (declare (ignorable port pixmap))
262     (error "Don't know how to realize the mirror on a generic port"))
263    
264 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
265 cvs 1.10 (declare (ignorable port pixmap))
266 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
267 cvs 1.10
268 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
269 mikemac 1.1 (declare (ignore sheet width height))
270 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
271 mikemac 1.1
272 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
273 mikemac 1.1 (declare (ignore pixmap))
274 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5