/[cmucl]/src/motif/lisp/internals.lisp
ViewVC logotype

Contents of /src/motif/lisp/internals.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Tue Mar 23 12:16:49 2004 UTC (10 years, 1 month ago) by emarsden
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.8: +2 -2 lines
 - various package-related cleanups. PROFILE and CLX packages use
   COMMON-LISP instead of LISP.
1 ;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please
7 ;;; contact Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/motif/lisp/internals.lisp,v 1.9 2004/03/23 12:16:49 emarsden Rel $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Written by Michael Garland
15 ;;;
16 ;;; This file contains internal functions required to support the Motif
17 ;;; toolkit in Lisp.
18 ;;;
19
20 (in-package "TOOLKIT-INTERNALS")
21
22
23
24 ;;;; Special TOOLKIT-ERROR
25
26 (define-condition toolkit-error (error) ())
27
28 (define-condition simple-toolkit-error (toolkit-error simple-condition) ()
29 (:documentation "An error has occurred in the X Toolkit code.")
30 (:report (lambda (condition stream)
31 (declare (stream stream))
32 (format stream "A Toolkit error has occurred.~%~?"
33 (simple-condition-format-control condition)
34 (simple-condition-format-arguments condition)))))
35
36 (define-condition toolkit-eof-error (toolkit-error)
37 ((string :reader toolkit-eof-error-string :initarg :string))
38 (:report (lambda (condition stream)
39 (write-line (toolkit-eof-error-string condition) stream))))
40
41 ;;; TOOLKIT-ERROR -- Internal
42 ;;; TOOLKIT-CERROR -- Internal
43 ;;;
44 ;;; These functions act just like ERROR and CERROR except that they signal
45 ;;; a TOOLKIT-ERROR instead of a SIMPLE-ERROR. This is mainly intended for
46 ;;; a graphical debugger which must stop attempting graphical interaction
47 ;;; when a toolkit error occurs.
48 ;;;
49 (defun toolkit-error (string &rest args)
50 (error 'simple-toolkit-error :format-control string :format-arguments args))
51
52 (defun toolkit-cerror (continue-string string &rest args)
53 (cerror continue-string 'simple-toolkit-error
54 :format-control string :format-arguments args))
55
56
57
58 ;;;; Internal communication functions
59
60 (defvar *xt-tcp-port* 8000)
61
62 (defun connect-to-host (host pid)
63 (declare (type (or null simple-string) host))
64 (handler-case
65 (if host
66 (handler-case
67 (ext:connect-to-inet-socket host *xt-tcp-port*)
68 (error ()
69 (ext:connect-to-inet-socket host (+ *xt-tcp-port*
70 (unix:unix-getuid)))))
71 (handler-case
72 (ext:connect-to-unix-socket
73 (if pid
74 (format nil "/tmp/.motif_socket-p~D" pid)
75 (format nil "/tmp/.motif_socket-u~D" (unix:unix-getuid))))
76 (error ()
77 (ext:connect-to-unix-socket "/tmp/.motif_socket"))))
78 (error ()
79 (toolkit-error "Unable to connect to Motif server."))))
80
81 (declaim (inline wait-for-input wait-for-input-or-timeout))
82 (defun wait-for-input (fd)
83 (system:wait-until-fd-usable fd :input))
84
85 (defun wait-for-input-or-timeout (fd interval)
86 (system:wait-until-fd-usable fd :input interval))
87
88
89
90 ;;;; Toolkit connection stuff
91
92 ;;; These will be dynamically bound in the context of the event handlers.
93 (defvar *motif-connection*)
94 (defvar *x-display*)
95
96 (defstruct (motif-connection
97 (:print-function print-motif-connection)
98 (:constructor make-motif-connection (fd)))
99 fd
100 (display-name "" :type simple-string)
101 display
102 (serial 1 :type fixnum)
103 (terminated nil :type (member t nil))
104 (close-hook nil :type (or symbol function))
105 ;;
106 ;; This maps widget ids (unsigned-byte 32)'s into widget structures
107 ;; It has to have :test #'eql, not #'eq, because otherwise result widgets
108 ;; from calls aren't necessarily found in the table. An example is
109 ;; (get-values foo :menu-bar)
110 (widget-table (make-hash-table :test #'eql) :type hash-table)
111 (function-table (make-array 32 :element-type '(or symbol function)
112 :adjustable t :fill-pointer 0))
113 (callback-table (make-hash-table :test #'equal) :type hash-table)
114 (protocol-table (make-hash-table :test #'equal) :type hash-table)
115 (event-table (make-hash-table :test #'equal) :type hash-table)
116 ;; This table tracks all the misc. id's we get from the server
117 ;; ie. xm-strings, translations, accelerators, font-lists
118 ;; Needs to be #'eql for same reasons as widget-table
119 (id-table (make-hash-table :test #'eql) :type hash-table))
120
121 (defun print-motif-connection (c stream d)
122 (declare (ignore d)
123 (stream stream))
124 (format stream "#<X Toolkit Connection, fd=~a>"
125 (motif-connection-fd c)))
126
127
128
129 ;;;; Internal structure definitions
130
131 (defstruct (widget
132 (:print-function print-widget)
133 (:constructor make-widget (id)))
134 (id 0 :type (unsigned-byte 32))
135 (type nil :type symbol)
136 (parent nil :type (or null widget))
137 (children nil :type list)
138 (callbacks nil :type list)
139 (protocols nil :type list)
140 (events nil :type list)
141 (user-data nil))
142
143 ;; A toolkit object is simply a wrapper for a pointer passed from the server
144 ;; process. The TYPE field allows us to discriminate the type of the pointer
145 ;; but still treat all pointers in the same way (ie. instead of having separate
146 ;; tables for xmstring, font-list, etc.)
147 ;;
148 (defstruct (motif-object
149 (:print-function print-motif-object)
150 (:constructor make-motif-object (id)))
151 (id 0 :type (unsigned-byte 32))
152 (type nil :type symbol))
153
154 (defun print-widget (w stream d)
155 (declare (ignore d)
156 (stream stream))
157 (format stream "#<X Toolkit Widget: ~A ~X>" (widget-type w) (widget-id w)))
158
159 (defun print-motif-object (obj stream d)
160 (declare (ignore d)
161 (stream stream))
162 (format stream "#<Motif object: ~A ~X>"
163 (motif-object-type obj) (motif-object-id obj)))
164
165 ;;; Some handy type abbreviations for motif-object
166 (deftype xmstring () 'motif-object)
167 (deftype font-list () 'motif-object)
168 (deftype translations () 'motif-object)
169 (deftype accelerators () 'motif-object)
170
171
172
173 ;;;; Tables for tracking stuff
174
175 (defvar *toolkit-string-table* (make-array 350 :element-type 'simple-string
176 :adjustable t :fill-pointer 0))
177
178 (defun find-widget (id)
179 (declare (type (unsigned-byte 32) id))
180 (let* ((widget-table (motif-connection-widget-table *motif-connection*))
181 (widget (gethash id widget-table)))
182 (unless widget
183 (setf widget (make-widget id))
184 (setf (gethash id widget-table) widget))
185 widget))
186
187 (defun find-motif-object (id type)
188 (declare (type (unsigned-byte 32) id)
189 (symbol type))
190 (let* ((table (motif-connection-id-table *motif-connection*))
191 (object (gethash id table)))
192 (unless object
193 (setf object (make-motif-object id))
194 (setf (gethash id table) object))
195 (setf (motif-object-type object) type)
196 object))
197
198
199
200 ;;;; Various helpful goodies
201
202 ;;; Converts a symbol into a resource class
203 ;;; ex. :label-string ===> LabelString
204 (defun symbol-class (symbol)
205 (delete #\- (string-capitalize (symbol-name symbol))))
206
207 ;;; Converts a symbol into a resource base-name.
208 ;;; ex. :label-string ===> labelString
209 (defun symbol-resource (symbol)
210 (let ((resource (symbol-class symbol)))
211 (setf (schar resource 0) (char-downcase (schar resource 0)))
212 resource))
213
214 ;;; Converts a symbol into an atom.
215 (defun symbol-atom (symbol)
216 (intern (substitute #\_ #\- (symbol-name symbol)) :KEYWORD))
217
218 (defun widget-add-child (parent child)
219 (declare (type widget parent child))
220 (setf (widget-parent child) parent)
221 (push child (widget-children parent)))

  ViewVC Help
Powered by ViewVC 1.1.5