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

Diff of /mcclim/ports.lisp

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

revision 1.20 by moore, Fri Feb 8 18:32:27 2002 UTC revision 1.21 by gilbert, Mon Feb 11 21:46:36 2002 UTC
# Line 48  returns a list in CLIM X11 format (:x11 Line 48  returns a list in CLIM X11 format (:x11
48  (defvar *all-ports* nil)  (defvar *all-ports* nil)
49    
50  (defclass port ()  (defclass port ()
51      ()
52      (:documentation
53       "The protocol class that corresponds to a port."))
54    
55    (defclass basic-port (port)
56    ((server-path :initform nil    ((server-path :initform nil
57                  :initarg :server-path                  :initarg :server-path
58                  :reader port-server-path)                  :reader port-server-path)
# Line 64  returns a list in CLIM X11 format (:x11 Line 69  returns a list in CLIM X11 format (:x11
69     (keyboard-input-focus :initform nil     (keyboard-input-focus :initform nil
70                           :initarg :keyboard-input-focus                           :initarg :keyboard-input-focus
71                           :accessor port-keyboard-input-focus)                           :accessor port-keyboard-input-focus)
72     )     (event-process
73    )      :initform nil
74        :initarg  :event-process
75        :accessor port-event-process
76        :documentation "In a multiprocessing environment, the particular process
77                        reponsible for calling PROCESS-NEXT-EVENT in a loop.")
78    
79       (lock
80        :initform (make-recursive-lock "port lock")
81        :accessor port-lock) ))
82    
83  (defun find-port (&key (server-path *default-server-path*))  (defun find-port (&key (server-path *default-server-path*))
84    (loop for port in *all-ports*    (loop for port in *all-ports*
# Line 79  returns a list in CLIM X11 format (:x11 Line 92  returns a list in CLIM X11 format (:x11
92                  (push port *all-ports*)                  (push port *all-ports*)
93                  (return port))))                  (return port))))
94    
95  (defmethod port-lookup-mirror ((port port) (sheet mirrored-sheet-mixin))  (defmethod initialize-instance :after ((port basic-port) &rest args)
96      (declare (ignorable args))
97      )
98    
99    (defmethod destroy-port :before ((port basic-port))
100      (when *multiprocessing-p*
101        (destroy-process (port-event-process port))
102        (setf (port-event-process port) nil)))
103    
104    (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
105    (gethash sheet (slot-value port 'sheet->mirror)))    (gethash sheet (slot-value port 'sheet->mirror)))
106    
107  (defmethod port-lookup-sheet ((port port) mirror)  (defmethod port-lookup-sheet ((port basic-port) mirror)
108    (gethash mirror (slot-value port 'mirror->sheet)))    (gethash mirror (slot-value port 'mirror->sheet)))
109    
110  (defmethod port-register-mirror ((port port) (sheet mirrored-sheet-mixin) mirror)  (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
111    (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)    (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
112    (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)    (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
113    nil)    nil)
114    
115  (defmethod port-unregister-mirror ((port port) (sheet mirrored-sheet-mixin) mirror)  (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
116    (remhash sheet (slot-value port 'sheet->mirror))    (remhash sheet (slot-value port 'sheet->mirror))
117    (remhash mirror (slot-value port 'mirror->sheet))    (remhash mirror (slot-value port 'mirror->sheet))
118    nil)    nil)
119    
120  (defmethod realize-mirror ((port port) (sheet mirrored-sheet-mixin))  (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
121    (error "Don't know how to realize the mirror of a generic mirrored-sheet"))    (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
122    
123  (defmethod destroy-mirror ((port port) (sheet mirrored-sheet-mixin))  (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
124    (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))    (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
125    
126  (defmethod mirror-transformation ((port port) mirror)  (defmethod mirror-transformation ((port basic-port) mirror)
127    (declare (ignore mirror))    (declare (ignore mirror))
128    (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))    (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
129    
130  (defmethod port-properties ((port port) indicator)  (defmethod port-properties ((port basic-port) indicator)
131    (with-slots (properties) port    (with-slots (properties) port
132      (getf properties indicator)))      (getf properties indicator)))
133    
134  (defmethod (setf port-properties) (value (port port) indicator)  (defmethod (setf port-properties) (value (port basic-port) indicator)
135    (with-slots (properties) port    (with-slots (properties) port
136      (setf (getf properties indicator) value)))      (setf (getf properties indicator) value)))
137    
138  (defmethod get-next-event ((port port) &key wait-function timeout)  (defmethod get-next-event ((port basic-port) &key wait-function timeout)
139    (declare (ignore wait-function timeout))    (declare (ignore wait-function timeout))
140    (error "Calling GET-NEXT-EVENT on a PORT protocol class"))    (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
141    
142  (defmethod process-next-event ((port port) &key wait-function timeout)  (defmethod process-next-event ((port basic-port) &key wait-function timeout)
143    (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))    (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))
144      (cond      (cond
145       ((null event) nil)       ((null event) nil)
# Line 126  returns a list in CLIM X11 format (:x11 Line 148  returns a list in CLIM X11 format (:x11
148        (distribute-event port event)        (distribute-event port event)
149        t))))        t))))
150    
151  (defmethod distribute-event ((port port) event)  (defmethod distribute-event ((port basic-port) event)
152    (cond    (cond
153     ((typep event 'keyboard-event)     ((typep event 'keyboard-event)
154      (dispatch-event (or (port-keyboard-input-focus port)      (dispatch-event (or (port-keyboard-input-focus port)
# Line 141  returns a list in CLIM X11 format (:x11 Line 163  returns a list in CLIM X11 format (:x11
163     (t     (t
164      (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))      (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
165    
166    (defmacro with-port-locked ((port) &body body)
167      (let ((fn (gensym "CONT.")))
168        `(labels ((,fn ()
169                   ,@body))
170          (declare (dynamic-extent #',fn))
171          `(invoke-with-port-locked ,port #',fn))))
172    
173    (defmethod invoke-with-port-locked ((port basic-port) continuation)
174      (with-recursive-lock-held ((port-lock port))
175        (funcall continuation)))
176    
177  (defun map-over-ports (function)  (defun map-over-ports (function)
178    (mapc function *all-ports*))    (mapc function *all-ports*))
179    
180  (defmethod restart-port ((port port))  (defmethod restart-port ((port basic-port))
181    (reset-watcher port :restart)    (reset-watcher port :restart)
182    nil)    nil)
183    
184  (defmethod destroy-port ((port port))  (defmethod destroy-port ((port basic-port))
185    (reset-watcher port :destroy)    (reset-watcher port :destroy)
186    (setf *all-ports* (remove port *all-ports*)))    (setf *all-ports* (remove port *all-ports*)))
187    
188  (defmethod add-watcher ((port port) watcher)  (defmethod add-watcher ((port basic-port) watcher)
189    (declare (ignore watcher))    (declare (ignore watcher))
190    nil)    nil)
191    
192  (defmethod delete-watcher ((port port) watcher)  (defmethod delete-watcher ((port basic-port) watcher)
193    (declare (ignore watcher))    (declare (ignore watcher))
194    nil)    nil)
195    
196  (defmethod reset-watcher ((port port) how)  (defmethod reset-watcher ((port basic-port) how)
197    (declare (ignore how))    (declare (ignore how))
198    nil)    nil)
199    
200  (defmethod make-graft ((port port) &key (orientation :default) (units :device))  (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
201    (let ((graft (make-instance 'graft    (let ((graft (make-instance 'graft
202                   :port port :mirror nil                   :port port :mirror nil
203                   :orientation orientation :units units)))                   :orientation orientation :units units)))
204      (push graft (port-grafts port))      (push graft (port-grafts port))
205      graft))      graft))
206    
207  (defmethod make-medium ((port port) sheet)  #||
208    (defmethod make-medium ((port basic-port) sheet)
209    (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))    (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
210    ||#
211    
212  ;;; Pixmap  ;;; Pixmap
213    
214  (defmethod port-lookup-mirror ((port port) (pixmap pixmap))  (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
215    (gethash pixmap (slot-value port 'pixmap->mirror)))    (gethash pixmap (slot-value port 'pixmap->mirror)))
216    
217  (defmethod port-lookup-pixmap ((port port) mirror)  (defmethod port-lookup-pixmap ((port basic-port) mirror)
218    (gethash mirror (slot-value port 'mirror->pixmap)))    (gethash mirror (slot-value port 'mirror->pixmap)))
219    
220  (defmethod port-register-mirror ((port port) (pixmap pixmap) mirror)  (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
221    (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)    (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
222    (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)    (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
223    nil)    nil)
224    
225  (defmethod port-unregister-mirror ((port port) (pixmap pixmap) mirror)  (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
226    (remhash pixmap (slot-value port 'pixmap->mirror))    (remhash pixmap (slot-value port 'pixmap->mirror))
227    (remhash mirror (slot-value port 'mirror->pixmap))    (remhash mirror (slot-value port 'mirror->pixmap))
228    nil)    nil)
229    
230  (defmethod realize-mirror ((port port) (pixmap mirrored-pixmap))  (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
231    (declare (ignorable port pixmap))    (declare (ignorable port pixmap))
232    (error "Don't know how to realize the mirror on a generic port"))    (error "Don't know how to realize the mirror on a generic port"))
233    
234  (defmethod destroy-mirror ((port port) (pixmap mirrored-pixmap))  (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
235    (declare (ignorable port pixmap))    (declare (ignorable port pixmap))
236    (error "Don't know how to destroy the mirror on a generic port"))    (error "Don't know how to destroy the mirror on a generic port"))
237    
238  (defmethod port-allocate-pixmap ((port port) sheet width height)  (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
239    (declare (ignore sheet width height))    (declare (ignore sheet width height))
240    (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))    (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
241    
242  (defmethod port-deallocate-pixmap ((port port) pixmap)  (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
243    (declare (ignore pixmap))    (declare (ignore pixmap))
244    (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))    (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

Legend:
Removed from v.1.20  
changed lines
  Added in v.1.21

  ViewVC Help
Powered by ViewVC 1.1.5