/[cmucl]/src/code/serve-event.lisp
ViewVC logotype

Diff of /src/code/serve-event.lisp

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

revision 1.14 by wlott, Fri Feb 14 23:45:32 1992 UTC revision 1.15 by wlott, Thu Mar 26 03:17:26 1992 UTC
# Line 20  Line 20 
20  (in-package "SYSTEM")  (in-package "SYSTEM")
21    
22  (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor  (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
23            serve-event serve-all-events wait-until-fd-usable))            serve-event serve-all-events wait-until-fd-usable
24              make-object-set object-set-operation *xwindow-table*
25              map-xwindow add-xwindow-object remove-xwindow-object))
26    
27  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
28    
# Line 30  Line 32 
32    
33    
34    
35  ;;;; MACH Message receiving noise.  ;;;; Object set stuff.
36    
37  (defvar *in-server* NIL  ;;;
38    "*In-server* is set to T when the SIGMSG interrupt has been enabled  ;;;    Hashtable from ports to objects.  Each entry is a cons (object . set).
39    in Server.")  ;;;
40    ;(defvar *port-table* (make-hash-table :test #'eql))
41    
42    ;;; Hashtable from windows to objects.  Each entry is a cons (object . set).
43    ;;;
44    (defvar *xwindow-table* (make-hash-table :test #'eql))
45    
46    
47    (defstruct (object-set
48                (:constructor make-object-set
49                              (name &optional
50                                    (default-handler #'default-default-handler)))
51                (:print-function
52                 (lambda (s stream d)
53                   (declare (ignore d))
54                   (format stream "#<Object Set ~S>" (object-set-name s)))))
55      name                                  ; Name, for descriptive purposes.
56      (table (make-hash-table :test #'eq))  ; Message-ID or xevent-type --> handler fun.
57      default-handler)
58    
59    (setf (documentation 'make-object-set 'function)
60          "Make an object set for use by a RPC/xevent server.  Name is for
61          descriptive purposes only.")
62    
63    ;;; Default-Default-Handler  --  Internal
64    ;;;
65    ;;;    If no such operation defined, signal an error.
66    ;;;
67    (defun default-default-handler (object)
68      (error "You lose, object: ~S" object))
69    
70    
71    ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
72    ;;; object set mapped to by a xwindow or port in *xwindow-table* or
73    ;;; *port-table*.
74    ;;;
75    (macrolet ((defmapper (name table)
76                  `(defun ,(intern (concatenate 'simple-string
77                                                "MAP-" (symbol-name name)))
78                          (,name)
79                     ,(format nil "Return as multiple values the object and ~
80                                   object-set mapped to by ~A."
81                              (string-downcase (symbol-name name)))
82                     (let ((temp (gethash ,name ,table)))
83                       (if temp
84                           (values (car temp) (cdr temp))
85                           (values nil nil))))))
86      ;(defmapper port *port-table*)
87      (defmapper xwindow *xwindow-table*))
88    
89    
90    ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
91    ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
92    ;;;
93    (macrolet ((def-add-object (name table)
94                  `(defun ,(intern (concatenate 'simple-string
95                                                "ADD-" (symbol-name name)
96                                                "-OBJECT"))
97                          (,name object object-set)
98                     ,(format nil "Add a new ~A/object/object-set association."
99                              (string-downcase (symbol-name name)))
100                     (check-type object-set object-set)
101                     (setf (gethash ,name ,table) (cons object object-set))
102                     object)))
103      ;(def-add-object port *port-table*)
104      (def-add-object xwindow *xwindow-table*))
105    
106    
107    ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
108    ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
109    ;;;
110    (macrolet ((def-remove-object (name table)
111                  `(defun ,(intern (concatenate 'simple-string
112                                                "REMOVE-" (symbol-name name)
113                                                "-OBJECT"))
114                          (,name)
115                     ,(format nil
116                              "Remove ~A and its associated object/object-set pair."
117                              (string-downcase (symbol-name name)))
118                     (remhash ,name ,table))))
119      ;(def-remove-object port *port-table*)
120      (def-remove-object xwindow *xwindow-table*))
121    
122    
123    ;;; Object-Set-Operation  --  Public
124    ;;;
125    ;;;    Look up the handler function for a given message ID.
126    ;;;
127    (defun object-set-operation (object-set message-id)
128      "Return the handler function in Object-Set for the operation specified by
129       Message-ID, if none, NIL is returned."
130      (check-type object-set object-set)
131      (check-type message-id fixnum)
132      (values (gethash message-id (object-set-table object-set))))
133    
134    ;;; %Set-Object-Set-Operation  --  Internal
135    ;;;
136    ;;;    The setf inverse for Object-Set-Operation.
137    ;;;
138    (defun %set-object-set-operation (object-set message-id new-value)
139      (check-type object-set object-set)
140      (check-type message-id fixnum)
141      (setf (gethash message-id (object-set-table object-set)) new-value))
142    ;;;
143    (defsetf object-set-operation %set-object-set-operation
144      "Sets the handler function for an object set operation.")
145    
146    
147    

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

  ViewVC Help
Powered by ViewVC 1.1.5