diff --git a/motif/lisp/callbacks.lisp b/motif/lisp/callbacks.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2eb5dabc6f0f09ce7190d02dea2bfa4180a37c4c --- /dev/null +++ b/motif/lisp/callbacks.lisp @@ -0,0 +1,457 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; This file contains all the functions which handle callbacks dispatched +;;; from the C server. +;;; + +(in-package "TOOLKIT") + + + +;;;; Functions for registering deferred actions + +(defvar *callback-deferred-action* nil) + +(defmacro with-callback-deferred-actions (&body forms) + `(setf *callback-deferred-action* #'(lambda () ,@forms))) + +(declaim (inline invoke-deferred-actions)) +(defun invoke-deferred-actions () + (when *callback-deferred-action* + (let ((action *callback-deferred-action*)) + (setf *callback-deferred-action* nil) + (funcall action)))) + + + +;;;; Functions which track all registered callbacks +;;; +;;; The actual toolkit functions are provided by functions +;;; %add-callback, %remove-callback, etc. +;;; +;;; The callback hash table is keyed on: +;;; (widget-id . callback-name) +;;; The callback data is (fn . client-data) + +(defun add-callback (widget sym-name fn &rest args) + "Registers a callback function on the specified widget." + (declare (type widget widget) + (type (or symbol function) fn) + (keyword sym-name)) + (let* ((name (symbol-resource sym-name)) + (table (motif-connection-callback-table *motif-connection*)) + (key (cons (widget-id widget) name)) + (data (cons fn args))) + + (unless (member sym-name (widget-callbacks widget)) + (%add-callback widget name) + (push sym-name (widget-callbacks widget))) + (setf (gethash key table) (cons data (gethash key table))))) + + +;; The 'args' list must be EQUAL to the args passed when the callback was +;; created for this callback to be removed. + +(defun remove-callback (widget sym-name fn &rest args) + "Removes a callback function from the specified widget." + (declare (type widget widget) + (type (or symbol function) fn) + (keyword sym-name)) + (let* ((name (symbol-resource sym-name)) + (table (motif-connection-callback-table *motif-connection*)) + (key (cons (widget-id widget) name)) + (data (cons fn args)) + (new-list (delete data (gethash key table) :test #'equal))) + + (setf (gethash key table) new-list) + (unless new-list + (%remove-callback widget name) + (setf (widget-callbacks widget) + (delete sym-name (widget-callbacks widget) :test #'eq))))) + +(defun remove-all-callbacks (widget sym-name) + "Removes all callback functions on the specified widget." + (declare (type widget widget) + (keyword sym-name)) + (let* ((name (symbol-resource sym-name)) + (table (motif-connection-callback-table *motif-connection*)) + (key (cons (widget-id widget) name))) + (%remove-callback widget name) + (setf (gethash key table) nil) + (setf (widget-callbacks widget) + (delete sym-name (widget-callbacks widget) :test #'eq)))) + +(defun handle-callback (reply) + (unwind-protect + (let* ((widget (toolkit-read-value reply)) + (name (toolkit-read-value reply)) + (table (motif-connection-callback-table *motif-connection*)) + (calldata (read-callback-info widget reply))) + ;; Invoke the callback function + (dolist (callback (gethash (cons (widget-id widget) name) table)) + (apply (car callback) + widget + calldata + (cdr callback)))) + (unless (motif-connection-terminated *motif-connection*) + (terminate-callback) + (invoke-deferred-actions)) + (destroy-message reply))) + + + +;;;; Functions which deal with protocol callbacks +;;; +;;; The protocol table is keyed on: +;;; (widget property protocol) +;;; The data stored in the table is: +;;; (fn . call-data) + +(defun add-protocol-callback (widget property protocol fn &rest args) + "Registers a protocol callback function on the specified widget." + (declare (type widget widget) + (type keyword property protocol) + (type (or symbol function) fn)) + (let* ((table (motif-connection-protocol-table *motif-connection*)) + (key (list (widget-id widget) property protocol)) + (data (cons fn args))) + + (let ((entry (cons property protocol))) + (unless (member entry (widget-protocols widget)) + (push entry (widget-protocols widget)) + (%add-protocol-callback widget property protocol))) + (setf (gethash key table) (cons data (gethash key table))))) + +(defun remove-protocol-callback (widget property protocol fn &rest args) + "Removes a protocol callback function on the specified widget." + (declare (type widget widget) + (type keyword property protocol) + (type (or symbol function) fn)) + (let* ((table (motif-connection-protocol-table *motif-connection*)) + (key (list (widget-id widget) property protocol)) + (data (cons fn args)) + (new-list (delete data (gethash key table) :test #'equal))) + (setf (gethash key table) new-list) + (unless new-list + (%remove-protocol-callback widget property protocol) + (setf (widget-protocols widget) + (delete (cons property protocol) (widget-protocols widget) + :test #'equal))))) + +;; (declaim (inline add-wm-protocol-callback remove-wm-protocol-callback)) +(defun add-wm-protocol-callback (widget protocol fn &rest args) + "Registers a window manager protocol callback function on the specified + widget." + (declare (type widget widget) + (keyword protocol) + (type (or symbol function) fn)) + (apply #'add-protocol-callback widget :wm-protocols protocol fn args)) + +(defun remove-wm-protocol-callback (widget protocol fn &rest args) + "Removes a window manager protocol callback function on the specified + widget." + (declare (type widget widget) + (keyword protocol) + (type (or symbol function) fn)) + (apply #'remove-protocol-callback widget :wm-protocols protocol fn args)) + +(defun handle-protocol (reply) + (unwind-protect + (let* ((widget (toolkit-read-value reply)) + (property (toolkit-read-value reply)) + (protocol (toolkit-read-value reply)) + (event (toolkit-read-value reply)) + (table (motif-connection-protocol-table *motif-connection*)) + (calldata (make-any-callback :reason :cr-protocols :event event))) + (dolist (callback (gethash (list (widget-id widget) property protocol) + table)) + (apply (car callback) + widget + calldata + (cdr callback)))) + (unless (motif-connection-terminated *motif-connection*) + (terminate-callback) + (invoke-deferred-actions)) + (destroy-message reply))) + + + +;;;; Functions for dealing with call-data info + +;;; These structures are used to hold the various callback information. +;;; When the server begins processing a callback, it will dump the callback +;;; data into the message in slot order. The client will unpack the data +;;; and create a callback structure which will be passed to the Lisp +;;; callback as the call-data. It reason field, possibly together with the +;;; widget class, will be enough to determine what callback structure is +;;; appropriate. The event slot is the (XEvent *) received in C. If the +;;; client wants access to the event, there will be some sort of macro such +;;; as (with-event-info ((<callback-struct>) ... <slots to bind>) ....) or +;;; something. This will be added later. +(defstruct (any-callback + (:print-function print-callback)) + (reason :cr-none :type keyword) + (event 0 :type (unsigned-byte 32))) + +(defun print-callback (callback stream d) + (declare (ignore d) + (stream stream)) + (format stream "#<Motif Callback -- ~a>" (any-callback-reason callback))) + +(defstruct (button-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-button-callback (reason event click-count))) + (click-count 0 :type fixnum)) + +(defstruct (drawing-area-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-drawing-area-callback (reason event window))) + window) + +(defstruct (drawn-button-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-drawn-button-callback + (reason event window click-count))) + window + (click-count 0 :type fixnum)) + +;;; RowColumnCallbackStruct is weird and probably not necessary + +(defstruct (scroll-bar-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-scroll-bar-callback (reason event value pixel))) + (value 0 :type fixnum) + (pixel 0 :type fixnum)) + +(defstruct (toggle-button-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-toggle-button-callback (reason event set))) + (set nil :type (member t nil))) + +;;; ListCallbackStruct is fairly complex +(defstruct (list-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-list-callback (reason event item item-position))) + (item nil :type (or null xmstring)) + (item-position 0 :type fixnum) + (selected-items nil :type list) ;; a list of strings (maybe array?) + (selected-item-positions nil :type list) ;; of integers + (selection-type 0 :type fixnum)) + +;; used for selection-box and command callbacks +(defstruct (selection-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-selection-callback (reason event value))) + (value nil :type (or null xmstring))) + +(defstruct (file-selection-callback + (:include selection-callback) + (:print-function print-callback) + (:constructor make-file-selection-callback + (reason event value mask dir pattern))) + (mask nil :type (or null xmstring)) + (dir nil :type (or null xmstring)) + (pattern nil :type (or null xmstring))) + +(defstruct (scale-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-scale-callback (reason event value))) + (value 0 :type fixnum)) + +(defstruct (text-callback + (:include any-callback) + (:print-function print-callback) + (:constructor make-text-callback + (reason event))) + (doit t :type (member t nil)) + (curr-insert 0 :type fixnum) + (new-insert 0 :type fixnum) + (start-pos 0 :type fixnum) + (end-pos 0 :type fixnum) + (text "" :type simple-string) + format ;; ***** Don't yet know what this is +) + +(defun read-callback-info (widget reply) + (let* ((reason (toolkit-read-value reply)) + (event (toolkit-read-value reply))) + (case (widget-type widget) + ((:arrow-button :arrow-button-gadget :push-button :push-button-gadget) + (make-button-callback reason event (toolkit-read-value reply))) + (:drawing-area + (make-drawing-area-callback reason event (toolkit-read-value reply))) + (:drawn-button + (let* ((window (toolkit-read-value reply)) + (count (toolkit-read-value reply))) + (make-drawn-button-callback reason event window count))) + (:scroll-bar + (let* ((value (toolkit-read-value reply)) + (pixel (toolkit-read-value reply))) + (make-scroll-bar-callback reason event value pixel))) + ((:toggle-button :toggle-button-gadget) + (make-toggle-button-callback reason event (toolkit-read-value reply))) + (:list + (let* ((item (toolkit-read-value reply)) + (item-position (toolkit-read-value reply)) + (info (make-list-callback reason event item item-position))) + (when (or (eq reason :cr-multiple-select) + (eq reason :cr-extended-select)) + (setf (list-callback-selected-items info) + (toolkit-read-value reply)) + (setf (list-callback-selected-item-positions info) + (toolkit-read-value reply)) + (setf (list-callback-selection-type info) + (toolkit-read-value reply))) + info)) + (:text + (let ((info (make-text-callback reason event))) + (when (member reason '(:cr-losing-focus :cr-modifying-text-value + :cr-moving-insert-cursor)) + (setf (text-callback-doit info) (toolkit-read-value reply)) + (setf (text-callback-curr-insert info) (toolkit-read-value reply)) + (setf (text-callback-new-insert info) (toolkit-read-value reply)) + + (case reason + (:cr-losing-focus + (setf (text-callback-start-pos info) (toolkit-read-value reply)) + (setf (text-callback-end-pos info) (toolkit-read-value reply))) + (:cr-modifying-text-value + (setf (text-callback-start-pos info) (toolkit-read-value reply)) + (setf (text-callback-end-pos info) (toolkit-read-value reply)) + (setf (text-callback-text info) (toolkit-read-value reply)) + (setf (text-callback-format info) (toolkit-read-value reply)) + ))) + info)) + ((:selection-box :command) + (make-selection-callback reason event (toolkit-read-value reply))) + (:file-selection-box + (let* ((value (toolkit-read-value reply)) + (mask (toolkit-read-value reply)) + (dir (toolkit-read-value reply)) + (pattern (toolkit-read-value reply))) + (make-file-selection-callback reason event + value mask dir pattern))) + (:scale + (make-scale-callback reason event (toolkit-read-value reply))) + (t nil)))) + +(defmacro with-callback-event ((event cback) &body forms) + `(let ((,event (transport-event (any-callback-event ,cback)))) + ,@forms)) + + + +;;;; Action table support + +(defmacro with-action-event ((event handle) &body forms) + `(let ((,event (transport-event ,handle))) + ,@forms)) + +(defun handle-action (reply) + (let* ((widget (toolkit-read-value reply)) + (event-handle (toolkit-read-value reply)) + (fun-name (toolkit-read-value reply))) + (unwind-protect + (funcall (read-from-string fun-name) widget event-handle) + (unless (motif-connection-terminated *motif-connection*) + (terminate-callback) + (invoke-deferred-actions)) + (destroy-message reply)))) + + + +;;;; Functions for managing event handlers + +(defun add-event-handler (widget event-mask non-maskable function &rest args) + "Registers an event handler function on the specified widget." + (declare (type widget widget) + (type (or symbol list) event-mask) + (type (member t nil) non-maskable) + (type (or symbol function) function)) + (when (symbolp event-mask) + (setf event-mask (list event-mask))) + (let ((table (motif-connection-event-table *motif-connection*)) + (data (cons function args))) + (dolist (event-class event-mask) + (let ((mask (xlib:make-event-mask event-class)) + (key (cons (widget-id widget) event-class))) + + (unless (member data (gethash key table) :test #'equal) + (push data (gethash key table))) + (unless (member event-class (widget-events widget)) + (push event-class (widget-events widget)) + (%add-event-handler widget mask nil)))) + (when non-maskable + (let ((mask 0) ; NoEventMask + (key (cons (widget-id widget) :non-maskable-mask))) + (unless (member data (gethash key table) :test #'equal) + (push data (gethash key table))) + (unless (member :non-maskable-mask (widget-events widget)) + (push :non-maskable-mask (widget-events widget)) + (%add-event-handler widget mask t)))))) + +(defun remove-event-handler (widget event-mask non-maskable function &rest args) + "Removes an event handler function on the specified widget." + (declare (type widget widget) + (type (or symbol list) event-mask) + (type (member t nil) non-maskable) + (type (or symbol function) function)) + (when (symbolp event-mask) + (setf event-mask (list event-mask))) + (let ((table (motif-connection-event-table *motif-connection*)) + (data (cons function args))) + (dolist (event-class event-mask) + (let* ((mask (xlib:make-event-mask event-class)) + (key (cons (widget-id widget) event-class)) + (new-list (delete data (gethash key table) :test #'equal))) + (unless new-list + (setf (widget-events widget) + (delete event-class (widget-events widget))) + (%remove-event-handler widget mask nil)))) + (when non-maskable + (let* ((mask 0) ; NoEventMask + (key (cons (widget-id widget) :non-maskable-mask)) + (new-list (delete data (gethash key table) :test #'equal))) + (unless new-list + (setf (widget-events widget) + (delete :non-maskable-mask (widget-events widget))) + (%remove-event-handler widget mask t)))))) + +(defun handle-event (reply) + (unwind-protect + (let* ((widget (toolkit-read-value reply)) + (mask (toolkit-read-value reply)) + (nonmaskable (toolkit-read-value reply)) + (event (toolkit-read-value reply)) + (table (motif-connection-event-table *motif-connection*)) + (event-class)) + + (setf event-class (if nonmaskable + :non-maskable-mask + (car (xlib:make-event-keys mask)))) + (dolist (handler (gethash (cons (widget-id widget) event-class) table)) + (apply (car handler) + widget + event + (cdr handler)))) + (unless (motif-connection-terminated *motif-connection*) + (terminate-callback) + (invoke-deferred-actions)) + (destroy-message reply))) diff --git a/motif/lisp/conversion.lisp b/motif/lisp/conversion.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f2a5e22bf67f2a7bf0dc42e71fb503d33890b7b0 --- /dev/null +++ b/motif/lisp/conversion.lisp @@ -0,0 +1,364 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; These are the functions necessary for reading/writing Lisp data objects +;;; into messages for communicating with the C server. +;;; + +(in-package "TOOLKIT-INTERNALS") + + + +;;;; Type definitions + +;;; This table maps normal type tags into the symbol for their type. +;;; Symbol types include :xid, :int, :widget, etc. +(defvar *type-table* (make-array 80 :element-type 'cons)) + +(defvar *enum-table* (make-hash-table :test #'eq)) + + + +;;;; Functions for extracting/creating typed data in messages + +(declaim (inline combine-type-and-data)) +(defun combine-type-and-data (type data) + (declare (type (unsigned-byte 24) data) + (keyword type)) + (let ((tag (get type :xtk-type-tag))) + (declare (type (unsigned-byte 8) tag)) + (logior (ash tag 24) data))) + +(declaim (inline extract-type-and-data)) +(defun extract-type-and-data (stuff) + (declare (type (unsigned-byte 32) stuff)) + (let ((tag (ash stuff -24)) + (data (logand stuff #x00FFFFFF))) + (declare (type (unsigned-byte 8) tag) + (type (unsigned-byte 24) data)) + (values tag data))) + + + +;;;; Interface functions for transporting resource values + +;;; In non-CMU Lisps, this can be converted into a (declaim (inline ...)) +;;; and add a (declaim (notinline ..)) after the function. +; (declaim (maybe-inline toolkit-write-value)) + +(defun toolkit-write-value (message value &optional (type t)) + (typecase value + (widget (message-write-widget message value)) + (motif-object (message-write-motif-object message value)) + (simple-string + (if (eq type :atom) + (message-write-atom message value) + (message-write-string message value))) + (xlib:font (message-write-xid message (xlib:font-id value) :font)) + (xlib:cursor (message-write-xid message (xlib:cursor-id value) :cursor)) + ((unsigned-byte 24) + (message-put-dblword message (combine-type-and-data :short value))) + ((signed-byte 32) + (message-put-dblword message (combine-type-and-data :int 0)) + (message-put-dblword message value)) + ((member t nil) + (if (eq type t) + (message-write-boolean message value) + ;; It's a null list + (message-put-dblword message + (combine-type-and-data type 0)))) + (list + (case type + (:resource-list (message-write-resource-list message value)) + (:resource-names (message-write-resource-names message value)) + (:widget-list (message-write-widget-list message value)) + (:xm-string-table (message-write-xmstring-table message value)) + (:string-table (message-write-string-table message value)) + (:int-list (message-write-int-list message value)) + (t (toolkit-error "Illegal list type -- ~a for ~s" type value)))) + (symbol + (cond + ((eq type :atom) (message-write-atom message value)) + ((get value :widget-class) (message-write-widget-class message value)) + ((get value :enum-value) (message-write-enum message value)) + (t (message-write-function message value)))) + (function (message-write-function message value)) + (xlib:color (message-write-color message value)) + (t + (toolkit-error "Unsupported argument type -- ~a for ~a" + (type-of value) value)))) + +(declaim (inline lookup-function)) +(defun lookup-function (fid) + (aref (motif-connection-function-table *motif-connection*) fid)) + +(defun toolkit-read-value (message) + (multiple-value-bind (tag data) + (extract-type-and-data (message-get-dblword message)) + (declare (type (unsigned-byte 8) tag) + (type (unsigned-byte 24) data)) + (let ((type (cdr (svref *type-table* tag)))) + (case type + (:widget (find-widget (message-get-dblword message))) + (:xm-string (find-motif-object (message-get-dblword message) type)) + (:short data) + (:atom (xlib:atom-name *x-display* (message-get-dblword message))) + (:boolean (not (zerop data))) + (:int (message-get-dblword message)) + (:xid (get-xresource (message-get-dblword message) tag)) + (:function (lookup-function data)) + (:string-token (svref *toolkit-string-table* data)) + ((:resource-list :xm-string-table :string-table :int-list) + (message-read-list message data)) + (:widget-list (break "Shouldn't be reading WidgetList.")) + (:string (message-read-string message data)) + (:translation-table + (find-motif-object (message-get-dblword message) type)) + (:accelerator-table + (find-motif-object (message-get-dblword message) type)) + (:font-list (find-motif-object (message-get-dblword message) type)) + (:event (construct-event message)) + (:float (vm::make-single-float (message-get-dblword message))) + (:color (message-read-color message data)) + (t ;; assume an enumerated value + (let ((table (gethash type *enum-table*))) + (unless table + (toolkit-error "Unknown or illegal value type -- ~a" type)) + (cdr (assoc data table)))))))) + + + +;;;; Functions for reading/writing strings + +(defun packet-write-string (packet string start length) + (declare (simple-string string) + (fixnum start length)) + (kernel:copy-to-system-area string + (+ (the fixnum (* start vm:byte-bits)) + (the fixnum + (* vm:vector-data-offset vm:word-bits))) + (packet-head packet) + (* (packet-fill packet) vm:byte-bits) + (* length vm:byte-bits)) + (incf (packet-fill packet) length) + (incf (packet-length packet) length)) + +(defun packet-read-string (packet string start length) + (declare (simple-string string) + (fixnum start length)) + (kernel:copy-from-system-area (packet-head packet) + (* (packet-fill packet) vm:byte-bits) + string + (+ (the fixnum (* start vm:byte-bits)) + (the fixnum + (* vm:vector-data-offset vm:word-bits))) + (* length vm:byte-bits)) + (incf (packet-fill packet) length)) + +(defun message-read-string (message length) + (declare (fixnum length)) + ;; length includes the '\0' + (let ((string (make-string (1- length) :initial-element #\Space))) + (declare (simple-string string)) + ;; + ;; ***** This is of course a gross oversimplification !!! + (packet-read-string (message-fill-packet message) + string 0 length) + (let ((packet (message-fill-packet message))) + (let ((pad (- 4 (mod (packet-fill packet) 4)))) + (unless (> pad 3) + (dotimes (i pad) + (packet-get-byte packet)))) + string))) + +(defun message-write-string (message string) + (declare (simple-string string)) + (let ((token (position string *toolkit-string-table* :test #'string=))) + (if token + (message-put-dblword message + (combine-type-and-data :string-token token)) + (let ((length (1+ (length string)))) + ;; We put the type header here so that we'll spill over into a new + ;; packet if necessary + (message-put-dblword message (combine-type-and-data :string length)) + (let ((packet (message-fill-packet message))) + (cond + ((< (+ length (packet-length packet)) *packet-size*) + (packet-write-string packet string 0 length)) + ((< length (- *packet-size* *header-size*)) + (message-add-packet message) + (setf packet (message-fill-packet message)) + (packet-write-string (message-fill-packet message) + string 0 length)) + (t + (break "Attempt to write a string larger than *packet-size*. + Come back later to get this to work."))) + (let ((pad (- 4 (mod (packet-fill packet) 4)))) + (unless (> pad 3) + (dotimes (i pad) + (packet-put-byte packet 0))))))))) + + + +;;;; Functions for writing most other types + +(defun message-write-widget (message widget) + (message-put-dblword message (combine-type-and-data :widget 0)) + (message-put-dblword message (widget-id widget))) + +(defun message-write-widget-list (message list) + (declare (list list)) + (let ((length (length list))) + (message-put-dblword message + (combine-type-and-data :widget-list length)) + (dolist (widget list) + (message-write-widget message widget)))) + +(defun message-write-widget-class (message widget-class) + (let ((val (get widget-class :widget-class))) + (message-put-dblword message + (combine-type-and-data :widget-class val)))) + +(defun message-write-xid (message id type) + (message-put-dblword message (combine-type-and-data type 0)) + (message-put-dblword message id)) + +(defun message-write-atom (message atom) + (declare (type xlib:xatom atom)) + (let ((id (xlib:find-atom *x-display* atom))) + (unless id + (setf id (xlib:intern-atom *x-display* atom)) + (xlib:display-force-output *x-display*)) + (message-put-dblword message (combine-type-and-data :atom 0)) + (message-put-dblword message id))) + +(defun message-write-enum (message enum) + (let ((val (get enum :enum-value))) + (message-put-dblword message (combine-type-and-data :enum val)))) + +(defun message-write-boolean (message value) + (let ((intval (if value 1 0))) + (message-put-dblword message (combine-type-and-data :boolean intval)))) + +(defun message-write-function (message fn) + (let ((fn-id (find-function-id fn))) + (message-put-dblword message (combine-type-and-data :function fn-id)))) + +(defun message-write-motif-object (message obj) + (message-put-dblword message + (combine-type-and-data (motif-object-type obj) 0)) + (message-put-dblword message (motif-object-id obj))) + +(defun message-write-int-list (message list) + (declare (list list)) + (let ((length (length list))) + (message-put-dblword message + (combine-type-and-data :int-list length)) + (dolist (int list) + (message-put-dblword message (combine-type-and-data :int 0)) + (message-put-dblword message int)))) + +(defun message-write-xmstring-table (message list) + (declare (list list)) + (let ((length (length list))) + (message-put-dblword message + (combine-type-and-data :xm-string-table length)) + (dolist (string list) + (typecase string + (simple-string (message-write-string message string)) + (xmstring (message-write-motif-object message string)) + (t (toolkit-error "Invalid entry in XmStringTable -- ~s" string)))))) + +(defun message-write-string-table (message list) + (declare (list list)) + (let ((length (length list))) + (message-put-dblword message + (combine-type-and-data :string-table length)) + (dolist (string list) + (message-write-string message string)))) + +(defun message-write-resource-names (message list) + (declare (list list)) + (let ((length (length list))) + (message-put-dblword message + (combine-type-and-data :resource-names length)) + (dolist (name list) + (message-write-string message name)))) + +(defun message-write-resource-list (message list) + (declare (list list)) + (let ((length (length list))) + (unless (zerop (mod length 2)) + (toolkit-error "Resource list of odd length -- ~a" list)) + (message-put-dblword message + (combine-type-and-data :resource-list length)) + (loop + (let ((name (first list)) + (value (second list)) + (rest (cddr list))) + (message-write-string message name) + (toolkit-write-value message value) + (unless rest (return)) + (setf list rest))))) + +(defun message-read-list (message length) + (declare (fixnum length)) + (let ((list)) + (dotimes (i length) + (push (toolkit-read-value message) list)) + (nreverse list))) + +(defun message-read-color (message red) + (let* ((green (message-get-word message)) + (blue (message-get-word message))) + (xlib:make-color :blue (the single-float (/ blue 65535.0)) + :red (the single-float (/ red 65535.0)) + :green (the single-float (/ green 65535.0))))) + +(defun message-write-color (message color) + (let ((green (round (* (xlib:color-green color) 65535))) + (red (round (* (xlib:color-red color) 65535))) + (blue (round (* (xlib:color-blue color)) 65535))) + (declare (type (unsigned-byte 16) green red blue)) + (message-put-dblword message + (combine-type-and-data :color red)) + (message-put-word message green) + (message-put-word message blue))) + + + +;;;; Functions for handling resource ID's + +(defun find-function-id (fn) + (declare (type (or symbol function) fn)) + (let* ((fn-table (motif-connection-function-table *motif-connection*)) + (pos (position fn fn-table))) + (declare (vector fn-table)) + (unless pos + (setf pos (vector-push-extend fn fn-table))) + pos)) + +(defun get-xresource (xid tag) + (let ((kind (car (svref *type-table* tag)))) + (case kind + (:window (xlib::lookup-window *x-display* xid)) + (:pixmap (xlib::lookup-pixmap *x-display* xid)) + (:cursor (xlib::lookup-cursor *x-display* xid)) + (:colormap (xlib::lookup-colormap *x-display* xid)) + (:font (xlib::lookup-font *x-display* xid)) + (t + (toolkit-error "Unknown X resource type -- ~a" kind))))) + +(defun construct-event (message) + (let ((packet (message-fill-packet message))) + (alien:sap-alien (system:sap+ (packet-head packet) + (packet-fill packet)) + xevent))) diff --git a/motif/lisp/events.lisp b/motif/lisp/events.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b16323413cc7a1e69b5bf4fe57973daa03349700 --- /dev/null +++ b/motif/lisp/events.lisp @@ -0,0 +1,876 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; Alien definitions for all the various XEvent structures. +;;; + +(in-package "TOOLKIT-INTERNALS") + + + +;;;; Definitions of the various XEvent structures +;;; We never include the (Display *) because it would be useless in Lisp and +;;; we add the HANDLE field so that we can pass this event back to C. + +(def-alien-type xid (unsigned 32)) +(def-alien-type window xid) +(def-alien-type colormap xid) +(def-alien-type drawable xid) +(def-alien-type atom (unsigned 32)) +(def-alien-type bool (boolean 32)) +(def-alien-type time (unsigned 32)) + +(def-alien-type x-key-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (root window) + (subwindow window) + (time time) + (x int) + (y int) + (x-root int) + (y-root int) + (state unsigned-int) + (keycode unsigned-int) + (same-screen bool))) + +(def-alien-type x-button-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (root window) + (subwindow window) + (time time) + (x int) + (y int) + (x-root int) + (y-root int) + (state unsigned-int) + (button unsigned-int) + (same-screen bool))) + +(def-alien-type x-motion-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (root window) + (subwindow window) + (time time) + (x int) + (y int) + (x-root int) + (y-root int) + (state unsigned-int) + (is-hint char) + (same-screen bool))) + +(def-alien-type x-crossing-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (root window) + (subwindow window) + (time time) + (x int) + (y int) + (x-root int) + (y-root int) + (mode int) + (detail int) + (same-screen bool) + (focus bool) + (state unsigned-int))) + +(def-alien-type x-focus-change-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (mode int) + (detail int))) + +(def-alien-type x-keymap-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (key-vector (array char 32)))) + +(def-alien-type x-expose-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (x int) + (y int) + (width int) + (height int) + (count int))) + +(def-alien-type x-graphics-expose-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (drawable drawable) + (x int) + (y int) + (width int) + (height int) + (count int) + (major-code int) + (minor-code int))) + +(def-alien-type x-no-expose-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (drawable drawable) + (major-code int) + (minor-code int))) + +(def-alien-type x-visibility-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (state int))) + +(def-alien-type x-create-window-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (parent window) + (window window) + (x int) + (y int) + (width int) + (height int) + (override-redirect bool))) + +(def-alien-type x-destroy-window-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (event window) + (window window))) + +(def-alien-type x-unmap-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (event window) + (window window) + (from-configure bool))) + +(def-alien-type x-map-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (event window) + (window window) + (override-redirect bool))) + +(def-alien-type x-map-request-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (parent window) + (window window))) + +(def-alien-type x-reparent-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (event window) + (parent window) + (x int) + (y int) + (override-redirect bool))) + +(def-alien-type x-configure-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (event window) + (window window) + (x int) + (y int) + (width int) + (height int) + (border-width int) + (above window) + (override-redirect bool))) + +(def-alien-type x-gravity-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (event window) + (window window) + (x int) + (y int))) + +(def-alien-type x-resize-request-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (width int) + (height int))) + +(def-alien-type x-configure-request-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (parent window) + (window window) + (x int) + (y int) + (width int) + (height int) + (border-width int) + (above window) + (detail int) + (value-mask unsigned-long))) + +(def-alien-type x-circulate-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (event window) + (window window) + (place int))) + +(def-alien-type x-circulate-request-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (parent window) + (window window) + (place int))) + +(def-alien-type x-property-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (atom atom) + (time time) + (state int))) + +(def-alien-type x-selection-clear-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (selection atom) + (time time))) + +(def-alien-type x-selection-request-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (owner window) + (requestor window) + (selection atom) + (target atom) + (property atom) + (time time))) + +(def-alien-type x-selection-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (requestor window) + (selection atom) + (target atom) + (property atom) + (time time))) + +(def-alien-type x-colormap-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (colormap colormap) + (new bool) + (state int))) + +(def-alien-type x-client-message-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (message-type atom) + (format int) + (data (union nil + (b (array char 20)) + (s (array short 10)) + (l (array long 5)))))) + +(def-alien-type x-mapping-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window) + (request int) + (first-keycode int) + (count int))) + +(def-alien-type x-any-event + (struct nil + (handle unsigned-long) + (type int) + (serial unsigned-long) + (send-event bool) + (window window))) + +(def-alien-type xevent + (union nil + (xany x-any-event) + (xkey x-key-event) + (xbutton x-button-event) + (xmotion x-motion-event) + (xcrossing x-crossing-event) + (xfocus x-focus-change-event) + (xexpose x-expose-event) + (xgraphicsexpose x-graphics-expose-event) + (xnoexpose x-no-expose-event) + (xvisibility x-visibility-event) + (xcreatewindow x-create-window-event) + (xdestroywindow x-destroy-window-event) + (xunmap x-unmap-event) + (xmap x-map-event) + (xmaprequest x-map-request-event) + (xreparent x-reparent-event) + (xconfigure x-configure-event) + (xgravity x-gravity-event) + (xresizerequest x-resize-request-event) + (xconfigurerequest x-configure-request-event) + (xcirculate x-circulate-event) + (xcirculaterequest x-circulate-request-event) + (xproperty x-property-event) + (xselectionclear x-selection-clear-event) + (xselectionrequest x-selection-request-event) + (xselection x-selection-event) + (xcolormap x-colormap-event) + (xclient x-client-message-event) + (xmapping x-mapping-event) + (xkeymap x-keymap-event))) + +(deftype toolkit-event () '(alien xevent)) + + + +;;;; Functions for accessing the common fields of all XEvents + +(eval-when (compile eval) + (defmacro def-event-access (name union-slot slot) + `(defun ,name (event) + (declare (type toolkit-event event)) + (alien:slot (alien:slot event ,union-slot) ,slot))) + + (defmacro def-event-window-access (name union-slot slot) + `(defun ,name (event) + (declare (type toolkit-event event)) + (xlib::lookup-window + *x-display* + (alien:slot (alien:slot event ,union-slot) ,slot)))) + + (defmacro def-event-drawable-access (name union-slot slot) + `(defun ,name (event) + (declare (type toolkit-event event)) + (xlib::lookup-drawable + *x-display* + (alien:slot (alien:slot event ,union-slot) ,slot)))) + + (defmacro def-event-colormap-access (name union-slot slot) + `(defun ,name (event) + (declare (type toolkit-event event)) + (xlib::lookup-colormap + *x-display* + (alien:slot (alien:slot event ,union-slot) ,slot)))) + + (defmacro def-event-atom-access (name union-slot slot) + `(defun ,name (event) + (declare (type toolkit-event event)) + (xlib::atom-name *x-display* + (alien:slot (alien:slot event ,union-slot) ,slot)))) +) ;; EVAL-WHEN + +(declaim (inline event-handle event-serial event-send-event event-window + event-type)) + +(def-event-access event-handle 'xany 'handle) +(def-event-access event-serial 'xany 'serial) +(def-event-access event-send-event 'xany 'send-event) +(def-event-window-access event-window 'xany 'window) +(defun event-type (event) + (declare (type toolkit-event event)) + (svref xlib::*event-key-vector* + (alien:slot (alien:slot event 'xany) 'type))) + + +;;;; Functions for accessing the fields of XButton events + +(declaim (inline button-event-root button-event-subwindow button-event-time + button-event-x button-event-y button-event-x-root + button-event-y-root button-event-state + button-event-same-screen button-event-button)) + +(def-event-window-access button-event-root 'xbutton 'root) +(def-event-window-access button-event-subwindow 'xbutton 'subwindow) +(def-event-access button-event-time 'xbutton 'time) +(def-event-access button-event-x 'xbutton 'x) +(def-event-access button-event-y 'xbutton 'y) +(def-event-access button-event-x-root 'xbutton 'x-root) +(def-event-access button-event-y-root 'xbutton 'y-root) +(def-event-access button-event-state 'xbutton 'state) +(def-event-access button-event-button 'xbutton 'button) +(def-event-access button-event-same-screen 'xbutton 'same-screen) + + + +;;;; Functions for accessing the fields of XKey events + +(declaim (inline key-event-root key-event-subwindow key-event-time + key-event-x key-event-y key-event-x-root key-event-y-root + key-event-state key-event-keycode key-event-same-screen)) + +(def-event-window-access key-event-root 'xkey 'root) +(def-event-window-access key-event-subwindow 'xkey 'subwindow) +(def-event-access key-event-time 'xkey 'time) +(def-event-access key-event-x 'xkey 'x) +(def-event-access key-event-y 'xkey 'y) +(def-event-access key-event-x-root 'xkey 'x-root) +(def-event-access key-event-y-root 'xkey 'y-root) +(def-event-access key-event-state 'xkey 'state) +(def-event-access key-event-keycode 'xkey 'keycode) +(def-event-access key-event-same-screen 'xkey 'same-screen) + + + +;;;; Functions for accessing XMotion event slots + +(declaim (inline motion-event-root motion-event-subwindow motion-event-time + motion-event-x motion-event-y motion-event-x-root + motion-event-y-root motion-event-state motion-event-is-hint + motion-event-same-screen)) + +(def-event-window-access motion-event-root 'xmotion 'root) +(def-event-window-access motion-event-subwindow 'xmotion 'subwindow) +(def-event-access motion-event-time 'xmotion 'time) +(def-event-access motion-event-x 'xmotion 'x) +(def-event-access motion-event-y 'xmotion 'y) +(def-event-access motion-event-x-root 'xmotion 'x-root) +(def-event-access motion-event-y-root 'xmotion 'y-root) +(def-event-access motion-event-state 'xmotion 'state) +(def-event-access motion-event-is-hint 'xmotion 'is-hint) +(def-event-access motion-event-same-screen 'xmotion 'same-screen) + + + +;;;; Functions for accessing XCrossingEvent slots + +(declaim (inline crossing-event-root crossing-event-subwindow + crossing-event-time crossing-event-x crossing-event-y + crossing-event-x-root crossing-event-y-root + crossing-event-mode crossing-event-detail + crossing-event-same-screen crossing-event-focus + crossing-event-state)) + +(def-event-window-access crossing-event-root 'xcrossing 'root) +(def-event-window-access crossing-event-subwindow 'xcrossing 'subwindow) +(def-event-access crossing-event-time 'xcrossing 'time) +(def-event-access crossing-event-x 'xcrossing 'x) +(def-event-access crossing-event-y 'xcrossing 'y) +(def-event-access crossing-event-x-root 'xcrossing 'x-root) +(def-event-access crossing-event-y-root 'xcrossing 'y-root) +(def-event-access crossing-event-mode 'xcrossing 'mode) +(def-event-access crossing-event-detail 'xcrossing 'detail) +(def-event-access crossing-event-same-screen 'xcrossing 'same-screen) +(def-event-access crossing-event-focus 'xcrossing 'focus) +(def-event-access crossing-event-state 'xcrossing 'state) + + + +;;;; Functions for accessing XFocusChangeEvent slots + +(declaim (inline focus-change-event-mode focus-change-event-detail)) + +(def-event-access focus-change-event-mode 'xfocus 'mode) +(def-event-access focus-change-event-detail 'xfocus 'detail) + + + +;;;; Functions for accessing XKeymapEvent slots + +;; **** These need to be added + + + +;;;; Functions for accessing XExposeEvent slots + +(declaim (inline expose-event-x expose-event-y expose-event-width + expose-event-height expose-event-count)) + +(def-event-access expose-event-x 'xexpose 'x) +(def-event-access expose-event-y 'xexpose 'y) +(def-event-access expose-event-width 'xexpose 'width) +(def-event-access expose-event-height 'xexpose 'height) +(def-event-access expose-event-count 'xexpose 'count) + + + +;;;; Functions for accessing XGraphicsExposeEvent structures + +(declaim (inline graphics-expose-event-drawable graphics-expose-event-x + graphics-expose-event-y graphics-expose-event-width + graphics-expose-event-height graphics-expose-event-count + graphics-expose-event-major-code + graphics-expose-event-minor-code)) + +(def-event-drawable-access graphics-expose-event-drawable + 'xgraphicsexpose 'drawable) +(def-event-access graphics-expose-event-x 'xgraphicsexpose 'x) +(def-event-access graphics-expose-event-y 'xgraphicsexpose 'y) +(def-event-access graphics-expose-event-width 'xgraphicsexpose 'width) +(def-event-access graphics-expose-event-height 'xgraphicsexpose 'height) +(def-event-access graphics-expose-event-count 'xgraphicsexpose 'count) +(def-event-access graphics-expose-event-major-code + 'xgraphicsexpose 'major-code) +(def-event-access graphics-expose-event-minor-code + 'xgraphicsexpose 'minor-code) + + + +;;;; Functions for accessing XNoExposeEvent slots + +(declaim (inline no-expose-event-drawable no-expose-event-major-code + no-expose-event-minor-code)) + +(def-event-drawable-access no-expose-event-drawable 'xnoexpose 'drawable) +(def-event-access no-expose-event-major-code 'xnoexpose 'major-code) +(def-event-access no-expose-event-minor-code 'xnoexpose 'minor-code) + + + +;;;; Functions for accesssing XVisibilityEvent slots + +(declaim (inline visibility-event-state)) + +(def-event-access visibility-event-state 'xvisibility 'state) + + + +;;;; Function for accessing XCreateWindowEvent data + +(declaim (inline create-window-event-parent create-window-event-window + create-window-event-x create-window-event-y + create-window-event-width create-window-event-height + create-window-event-override-redirect)) + +(def-event-window-access create-window-event-parent 'xcreatewindow 'parent) +(def-event-window-access create-window-event-window 'xcreatewindow 'window) +(def-event-access create-window-event-x 'xcreatewindow 'x) +(def-event-access create-window-event-y 'xcreatewindow 'y) +(def-event-access create-window-event-width 'xcreatewindow 'width) +(def-event-access create-window-event-height 'xcreatewindow 'height) +(def-event-access create-window-event-override-redirect + 'xcreatewindow 'override-redirect) + + + +;;;; Functions for accessing XDestroyWindowEvent slots + +(declaim (inline destroy-window-event-event destroy-window-event-window)) + +(def-event-window-access destroy-window-event-event 'xdestroywindow 'event) +(def-event-window-access destroy-window-event-window 'xdestroywindow 'window) + + + +;;;; Functions for accessing XUnmapEvent structures + +(declaim (inline unmap-event-event unmap-event-window + unmap-event-from-configure)) + +(def-event-window-access unmap-event-event 'xunmap 'event) +(def-event-window-access unmap-event-window 'xunmap 'window) +(def-event-access unmap-event-from-configure 'xunmap 'from-configure) + + + +;;;; Functions for accessing XMapRequestEvent slots + +(declaim (inline map-request-event-parent map-request-event-window)) + +(def-event-window-access map-request-event-parent 'xmaprequest 'parent) +(def-event-window-access map-request-event-window 'xmaprequest 'window) + + + +;;;; Functions to access XReparentEvent structures + +(declaim (inline reparent-event-event reparent-event-parent + reparent-event-x reparent-event-y + reparent-event-override-redirect)) + +(def-event-window-access reparent-event-event 'xreparent 'event) +(def-event-window-access reparent-event-parent 'xreparent 'parent) +(def-event-access reparent-event-x 'xreparent 'x) +(def-event-access reparent-event-y 'xreparent 'y) +(def-event-access reparent-event-override-redirect + 'xreparent 'override-redirect) + + + +;;;; Functions to access XConfigureEvent slots + +(declaim (inline configure-event-event configure-event-window + configure-event-x configure-event-y configure-event-width + configure-event-height configure-event-border-width + configure-event-above configure-event-override-redirect)) + +(def-event-window-access configure-event-event 'xconfigure 'event) +(def-event-window-access configure-event-window 'xconfigure 'window) +(def-event-access configure-event-x 'xconfigure 'x) +(def-event-access configure-event-y 'xconfigure 'y) +(def-event-access configure-event-width 'xconfigure 'width) +(def-event-access configure-event-height 'xconfigure 'height) +(def-event-access configure-event-border-width 'xconfigure 'border-width) +(def-event-window-access configure-event-above 'xconfigure 'above) +(def-event-access configure-event-override-redirect + 'xconfigure 'override-redirect) + + + +;;;; Functions for accessing XGravityEvent slots + +(declaim (inline gravity-event-event gravity-event-window gravity-event-x + gravity-event-y)) + +(def-event-window-access gravity-event-event 'xgravity 'event) +(def-event-window-access gravity-event-window 'xgravity 'window) +(def-event-access gravity-event-x 'xgravity 'x) +(def-event-access gravity-event-y 'xgravity 'y) + + + +;;;; Functions for accessing XResizeRequestEvent structures + +(declaim (inline resize-request-event-width resize-request-event-height)) + +(def-event-access resize-request-event-width 'xresizerequest 'width) +(def-event-access resize-request-event-height 'xresizerequest 'height) + + + +;;;; Functions for accessing XConfigureRequestEvent structures + +(declaim (inline configure-request-event-parent + configure-request-event-window configure-request-event-x + configure-request-event-y configure-request-event-width + configure-request-event-height + configure-request-event-border-width + configure-request-event-above configure-request-event-detail + configure-request-event-value-mask)) + +(def-event-window-access configure-request-event-parent + 'xconfigurerequest 'parent) +(def-event-window-access configure-request-event-window + 'xconfigurerequest 'window) +(def-event-access configure-request-event-x 'xconfigurerequest 'x) +(def-event-access configure-request-event-y 'xconfigurerequest 'y) +(def-event-access configure-request-event-width 'xconfigurerequest 'width) +(def-event-access configure-request-event-height 'xconfigurerequest 'height) +(def-event-access configure-request-event-border-width + 'xconfigurerequest 'border-width) +(def-event-window-access configure-request-event-above + 'xconfigurerequest 'above) +(def-event-access configure-request-event-detail 'xconfigurerequest 'detail) +(def-event-access configure-request-value-mask 'xconfigurerequest 'value-mask) + + + +;;;; Functions for accessing XCirculateEvent structures + +(declaim (inline circulate-event-event circulate-event-window + circulate-event-place)) + +(def-event-window-access circulate-event-event 'xcirculate 'event) +(def-event-window-access circulate-event-window 'xcirculate 'window) +(def-event-access circulate-event-place 'xcirculate 'place) + + + +;;;; Functions for accessing XCirculateRequestEvent slots + +(declaim (inline circulate-request-event-parent + circulate-request-event-window circulate-request-event-place)) + +(def-event-window-access circulate-request-event-parent + 'xcirculaterequest 'parent) +(def-event-window-access circulate-request-event-window + 'xcirculaterequest 'window) +(def-event-access circulate-request-event-place 'xcirculaterequest 'place) + + + +;;;; Functions for accessing XPropertyEvent slots + +(declaim (inline property-event-atom property-event-time property-event-state)) + +(def-event-atom-access property-event-atom 'xproperty 'atom) +(def-event-access property-event-time 'xproperty 'time) +(def-event-access property-event-state 'xproperty 'state) + + + +;;;; Functions for accessing XSelectionClearEvent slots + +(declaim (inline selection-clear-event-selection selection-clear-event-time)) + +(def-event-atom-access selection-clear-event-selection + 'xselectionclear 'selection) +(def-event-access selection-clear-event-time 'xselectionclear 'time) + + + +;;;; Functions for accessing XSelectionRequestEvent slots + +(declaim (inline selection-request-event-owner + selection-request-event-requestor + selection-request-event-selection + selection-request-event-target + selection-request-event-property selection-request-event-time)) + +(def-event-window-access selection-request-event-owner + 'xselectionrequest 'owner) +(def-event-window-access selection-request-event-requestor + 'xselectionrequest 'requestor) +(def-event-atom-access selection-request-event-selection + 'xselectionrequest 'selection) +(def-event-atom-access selection-request-event-target + 'xselectionrequest 'target) +(def-event-atom-access selection-request-event-property + 'xselectionrequest 'property) +(def-event-access selection-request-event-time 'xselectionrequest 'time) + + + +;;;; Functions for accessing XSelectionEvent structures + +(declaim (inline selection-event-requestor selection-event-selection + selection-event-target selection-event-property + selection-event-time)) + +(def-event-window-access selection-event-requestor 'xselection 'requestor) +(def-event-atom-access selection-event-selection 'xselection 'selection) +(def-event-atom-access selection-event-target 'xselection 'target) +(def-event-atom-access selection-event-property 'xselection 'property) +(def-event-access selection-event-time 'xselection 'time) + + + +;;;; Functions for accessing XColormapEvent structures + +(declaim (inline colormap-event-colormap colormap-event-new + colormap-event-state)) + +(def-event-colormap-access colormap-event-colormap 'xcolormap 'colormap) +(def-event-access colormap-event-new 'xcolormap 'new) +(def-event-access colormap-event-state 'xcolormap 'state) + + + +;;;; Functions for accessing XClientMessageEvent structures + +(declaim (inline client-message-event-message-type client-message-event-format)) + +(def-event-atom-access client-message-event-message-type + 'xclient 'message-type) +(def-event-access client-message-event-format 'xclient 'format) +;; ***** Need to access client-msg data + + + +;;;; Functions for accessing XMappingEvent slots + +(declaim (inline mapping-event-request mapping-event-first-keycode + mapping-event-count)) + +(def-event-access mapping-event-request 'xmapping 'request) +(def-event-access mapping-event-first-keycode 'xmapping 'first-keycode) +(def-event-access mapping-event-count 'xmapping 'count) diff --git a/motif/lisp/initial.lisp b/motif/lisp/initial.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6ee8bbe59577d0a7b960df4b8528edd11fa02895 --- /dev/null +++ b/motif/lisp/initial.lisp @@ -0,0 +1,226 @@ +;;;; -*- Mode: Lisp ; Package: User -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; This file is the initial startup code for the Motif Toolkit +;;; + +(in-package "USER") + + + +;;;; Set up Lisp for the loading of the Motif toolkit + +(defpackage "TOOLKIT-INTERNALS" + (:nicknames "XTI") + (:use "COMMON-LISP" "EXTENSIONS" "ALIEN" "C-CALL") + (:export "*MOTIF-CONNECTION*" "*X-DISPLAY*" "MOTIF-CONNECTION" + "MAKE-MOTIF-CONNECTION" "MOTIF-CONNECTION-FD" + "MOTIF-CONNECTION-DISPLAY-NAME" "MOTIF-CONNECTION-DISPLAY" + "MOTIF-CONNECTION-SERIAL" "MOTIF-CONNECTION-WIDGET-TABLE" + "MOTIF-CONNECTION-FUNCTION-TABLE" + "MOTIF-CONNECTION-CALLBACK-TABLE" "MOTIF-CONNECTION-CLOSE-HOOK" + "MOTIF-CONNECTION-PROTOCOL-TABLE" "MOTIF-CONNECTION-TERMINATED" + "MOTIF-CONNECTION-EVENT-TABLE" "TOOLKIT-ERROR" + "TOOLKIT-CERROR" "TOOLKIT-EOF-ERROR" "CONNECT-TO-HOST" + "WAIT-FOR-INPUT" "WAIT-FOR-INPUT-OR-TIMEOUT" "WIDGET" + "MAKE-WIDGET" "WIDGET-ID" "WIDGET-TYPE" "WIDGET-PARENT" + "WIDGET-CHILDREN" "WIDGET-CALLBACKS" "WIDGET-PROTOCOLS" + "WIDGET-EVENTS" "WIDGET-USER-DATA" "MOTIF-OBJECT" "FONT-LIST" + "XMSTRING" "TRANSLATIONS" "ACCELERATORS" "SYMBOL-RESOURCE" + "SYMBOL-CLASS" "SYMBOL-ATOM" "WIDGET-ADD-CHILD" "CREATE-MESSAGE" + "DESTROY-MESSAGE" "TRANSMIT-MESSAGE" "RECEIVE-MESSAGE" + "CREATE-NEXT-MESSAGE" "PREPARE-REQUEST" "*TYPE-TABLE*" + "*ENUM-TABLE*" "TOOLKIT-READ-VALUE" "TOOLKIT-WRITE-VALUE" + "TOOLKIT-EVENT" "EVENT-HANDLE" "EVENT-SERIAL" "EVENT-SEND-EVENT" + "EVENT-WINDOW" "EVENT-TYPE" "BUTTON-EVENT-ROOT" + "BUTTON-EVENT-SUBWINDOW" "BUTTON-EVENT-TIME" "BUTTON-EVENT-X" + "BUTTON-EVENT-Y" "BUTTON-EVENT-X-ROOT" "BUTTON-EVENT-Y-ROOT" + "BUTTON-EVENT-STATE" "BUTTON-EVENT-SAME-SCREEN" + "BUTTON-EVENT-BUTTON" "KEY-EVENT-ROOT" "KEY-EVENT-SUBWINDOW" + "KEY-EVENT-TIME" "KEY-EVENT-X" "KEY-EVENT-Y" "KEY-EVENT-X-ROOT" + "KEY-EVENT-Y-ROOT" "KEY-EVENT-STATE" "KEY-EVENT-KEYCODE" + "KEY-EVENT-SAME-SCREEN" "MOTION-EVENT-ROOT" + "MOTION-EVENT-SUBWINDOW" "MOTION-EVENT-TIME" "MOTION-EVENT-X" + "MOTION-EVENT-Y" "MOTION-EVENT-X-ROOT" "MOTION-EVENT-Y-ROOT" + "MOTION-EVENT-STATE" "MOTION-EVENT-IS-HINT" + "MOTION-EVENT-SAME-SCREEN" "CROSSING-EVENT-ROOT" + "CROSSING-EVENT-SUBWINDOW" "CROSSING-EVENT-TIME" + "CROSSING-EVENT-X" "CROSSING-EVENT-Y" "CROSSING-EVENT-X-ROOT" + "CROSSING-EVENT-Y-ROOT" "CROSSING-EVENT-MODE" + "CROSSING-EVENT-DETAIL" "CROSSING-EVENT-FOCUS" + "CROSSING-EVENT-SAME-SCREEN" "CROSSING-EVENT-STATE" + "FOCUS-CHANGE-EVENT-MODE" "FOCUS-CHANGE-EVENT-DETAIL" + "EXPOSE-EVENT-X" "EXPOSE-EVENT-Y" "EXPOSE-EVENT-WIDTH" + "EXPOSE-EVENT-HEIGHT" "EXPOSE-EVENT-COUNT" + "GRAPHICS-EXPOSE-EVENT-X" "GRAPHICS-EXPOSE-EVENT-DRAWABLE" + "GRAPHICS-EXPOSE-EVENT-Y" "GRAPHICS-EXPOSE-EVENT-WIDTH" + "GRAPHICS-EXPOSE-EVENT-HEIGHT" "GRAPHICS-EXPOSE-EVENT-COUNT" + "GRAPHICS-EXPOSE-EVENT-MAJOR-CODE" + "GRAPHICS-EXPOSE-EVENT-MINOR-CODE" "NO-EXPOSE-EVENT-MINOR-CODE" + "NO-EXPOSE-EVENT-DRAWABLE" "NO-EXPOSE-EVENT-MAJOR-CODE" + "VISIBILITY-EVENT-STATE" "CREATE-WINDOW-EVENT-PARENT" + "CREATE-WINDOW-EVENT-WINDOW" "CREATE-WINDOW-EVENT-X" + "CREATE-WINDOW-EVENT-Y" "CREATE-WINDOW-EVENT-WIDTH" + "CREATE-WINDOW-EVENT-HEIGHT" + "CREATE-WINDOW-EVENT-OVERRIDE-REDIRECT" + "DESTROY-WINDOW-EVENT-EVENT" "DESTROY-WINDOW-EVENT-WINDOW" + "UNMAP-EVENT-EVENT" "UNMAP-EVENT-WINDOW" + "UNMAP-EVENT-FROM-CONFIGURE" "MAP-REQUEST-EVENT-PARENT" + "MAP-REQUEST-EVENT-WINDOW" "REPARENT-EVENT-EVENT" + "REPARENT-EVENT-PARENT" "REPARENT-EVENT-X" "REPARENT-EVENT-Y" + "REPARENT-EVENT-OVERRIDE-REDIRECT" "CONFIGURE-EVENT-EVENT" + "CONFIGURE-EVENT-WINDOW" "CONFIGURE-EVENT-X" "CONFIGURE-EVENT-Y" + "CONFIGURE-EVENT-WIDTH" "CONFIGURE-EVENT-HEIGHT" + "CONFIGURE-EVENT-BORDER-WIDTH" "CONFIGURE-EVENT-ABOVE" + "CONFIGURE-EVENT-OVERRIDE-REDIRECT" "GRAVITY-EVENT-EVENT" + "GRAVITY-EVENT-WINDOW" "GRAVITY-EVENT-X" "GRAVITY-EVENT-Y" + "RESIZE-REQUEST-EVENT-WIDTH" "RESIZE-REQUEST-EVENT-HEIGHT" + "CONFIGURE-REQUEST-EVENT-PARENT" + "CONFIGURE-REQUEST-EVENT-WINDOW" "CONFIGURE-REQUEST-EVENT-X" + "CONFIGURE-REQUEST-EVENT-Y" "CONFIGURE-REQUEST-EVENT-WIDTH" + "CONFIGURE-REQUEST-EVENT-HEIGHT" "CONFIGURE-REQUEST-EVENT-ABOVE" + "CONFIGURE-REQUEST-EVENT-BORDER-WIDTH" + "CONFIGURE-REQUEST-EVENT-DETAIL" + "CONFIGURE-REQUEST-EVENT-VALUE-MASK" "CIRCULATE-EVENT-EVENT" + "CIRCULATE-EVENT-WINDOW" "CIRCULATE-EVENT-PLACE" + "CIRCULATE-REQUEST-EVENT-EVENT" "CIRCULATE-REQUEST-EVENT-WINDOW" + "CIRCULATE-REQUEST-EVENT-PLACE" "PROPERTY-EVENT-ATOM" + "PROPERTY-EVENT-TIME" "PROPERTY-EVENT-STATE" + "SELECTION-CLEAR-EVENT-SELECTION" "SELECTION-CLEAR-EVENT-TIME" + "SELECTION-REQUEST-EVENT-OWNER" + "SELECTION-REQUEST-EVENT-REQUESTOR" + "SELECTION-REQUEST-EVENT-SELECTION" + "SELECTION-REQUEST-EVENT-TARGET" + "SELECTION-REQUEST-EVENT-PROPERTY" + "SELECTION-REQUEST-EVENT-TIME" "SELECTION-EVENT-REQUESTOR" + "SELECTION-EVENT-SELECTION" "SELECTION-EVENT-TARGET" + "SELECTION-EVENT-PROPERTY" "SELECTION-EVENT-TIME" + "COLORMAP-EVENT-COLORMAP" "COLORMAP-EVENT-NEW" + "COLORMAP-EVENT-STATE" "MAPPING-EVENT-REQUEST" + "MAPPING-EVENT-FIRST-KEYCODE" "MAPPING-EVENT-COUNT")) + +(defpackage "TOOLKIT" + (:nicknames "XT") + (:use "COMMON-LISP" "EXTENSIONS" "TOOLKIT-INTERNALS") + (:export "ADD-CALLBACK" "REMOVE-CALLBACK" "REMOVE-ALL-CALLBACKS" + "ADD-PROTOCOL-CALLBACK" "REMOVE-PROTOCOL-CALLBACK" + "ADD-WM-PROTOCOL-CALLBACK" "REMOVE-WM-PROTOCOL-CALLBACK" + "WITH-CALLBACK-EVENT" "WITH-ACTION-EVENT" "ADD-EVENT-HANDLER" + "REMOVE-EVENT-HANDLER" "ANY-CALLBACK" "ANY-CALLBACK-REASON" + "ANY-CALLBACK-EVENT" "BUTTON-CALLBACK" "DRAWING-AREA-CALLBACK" + "BUTTON-CALLBACK-CLICK-COUNT" "DRAWING-AREA-CALLBACK-WINDOW" + "DRAWN-BUTTON-CALLBACK" "DRAWN-BUTTON-CALLBACK-WINDOW" + "DRAWN-BUTTON-CALLBACK-CLICK-COUNT" "SCROLL-BAR-CALLBACK" + "SCROLL-BAR-CALLBACK-VALUE" "SCROLL-BAR-CALLBACK-PIXEL" + "TOGGLE-BUTTON-CALLBACK" "TOGGLE-BUTTON-CALLBACK-SET" + "LIST-CALLBACK" "LIST-CALLBACK-ITEM" + "LIST-CALLBACK-ITEM-POSITION" "LIST-CALLBACK-SELECTED-ITEMS" + "LIST-CALLBACK-SELECTED-ITEM-POSITIONS" + "LIST-CALLBACK-SELECTION-TYPE" "SELECTION-CALLBACK" + "SELECTION-CALLBACK-VALUE" "FILE-SELECTION-CALLBACK" + "FILE-SELECTION-CALLBACK-VALUE" "FILE-SELECTION-CALLBACK-MASK" + "FILE-SELECTION-CALLBACK-DIR" "FILE-SELECTION-CALLBACK-PATTERN" + "SCALE-CALLBACK" "SCALE-CALLBACK-VALUE" "TEXT-CALLBACK" + "TEXT-CALLBACK-DOIT" "TEXT-CALLBACK-CURR-INSERT" + "TEXT-CALLBACK-NEW-INSERT" "TEXT-CALLBACK-START-POS" + "TEXT-CALLBACK-END-POS" "TEXT-CALLBACK-TEXT" "WITH-ACTION-EVENT" + "TEXT-CALLBACK-FORMAT" "*DEBUG-MODE*" "*DEFAULT-SERVER-HOST*" + "*CLM-BINARY-DIRECTORY*" "*CLM-BINARY-NAME*" + "*DEFAULT-DISPLAY*" "QUIT-APPLICATION" "WITH-MOTIF-CONNECTION" + "RUN-MOTIF-APPLICATION" "WITH-CLX-REQUESTS" + "BUILD-SIMPLE-FONT-LIST" "BUILD-FONT-LIST" "*MOTIF-CONNECTION*" + "*X-DISPLAY*" "WIDGET" "XMSTRING" "FONT-LIST" "SET-VALUES" + "GET-VALUES" "CREATE-MANAGED-WIDGET" "CREATE-WIDGET" + "CREATE-POPUP-SHELL" "CREATE-APPLICATION-SHELL" "DESTROY-WIDGET" + "*CONVENIENCE-AUTO-MANAGE*" "MANAGE-CHILDREN" + "UNMANAGE-CHILDREN" "WITH-RESOURCE-VALUES" "MENU-POSITION" + "CREATE-ARROW-BUTTON" "CREATE-ARROW-BUTTON-GADGET" + "CREATE-BULLETIN-BOARD" "CREATE-CASCADE-BUTTON" + "CREATE-CASCADE-BUTTON-GADGET" "CREATE-COMMAND" + "CREATE-DIALOG-SHELL" "CREATE-DRAWING-AREA" + "CREATE-DRAWN-BUTTON" "CREATE-FILE-SELECTION-BOX" "CREATE-FORM" + "CREATE-FRAME" "CREATE-LABEL" "CREATE-LABEL-GADGET" + "CREATE-LIST" "CREATE-MAIN-WINDOW" "CREATE-MENU-SHELL" + "CREATE-MESSAGE-BOX" "CREATE-PANED-WINDOW" "CREATE-PUSH-BUTTON" + "CREATE-PUSH-BUTTON-GADGET" "CREATE-ROW-COLUMN" "CREATE-SCALE" + "CREATE-SCROLL-BAR" "CREATE-SCROLLED-WINDOW" + "CREATE-SELECTION-BOX" "CREATE-SEPARATOR" + "CREATE-SEPARATOR-GADGET" "CREATE-TEXT" "CREATE-TOGGLE-BUTTON" + "CREATE-TOGGLE-BUTTON-GADGET" "CREATE-MENU-BAR" + "CREATE-OPTION-MENU" "CREATE-RADIO-BOX" "CREATE-WARNING-DIALOG" + "CREATE-BULLETIN-BOARD-DIALOG" "CREATE-ERROR-DIALOG" + "CREATE-FILE-SELECTION-DIALOG" "CREATE-FORM-DIALOG" + "CREATE-INFORMATION-DIALOG" "CREATE-MESSAGE-DIALOG" + "CREATE-POPUP-MENU" "CREATE-PROMPT-DIALOG" + "CREATE-PULLDOWN-MENU" "CREATE-QUESTION-DIALOG" + "CREATE-SCROLLED-LIST" "CREATE-SCROLLED-TEXT" + "CREATE-SELECTION-DIALOG" "CREATE-WORKIG-DIALOG" + "REALIZE-WIDGET" "UNREALIZE-WIDGET" "MAP-WIDGET" "UNMAP-WIDGET" + "SET-SENSITIVE" "POPUP" "POPDOWN" "MANAGE-CHILD" + "UNMANAGE-CHILD" "PARSE-TRANSLATION-TABLE" + "AUGMENT-TRANSLATIONS" "OVERRIDE-TRANSLATIONS" + "UNINSTALL-TRANSLATIONS" "PARSE-ACCELERATOR-TABLE" + "INSTALL-ACCELERATORS" "INSTALL-ALL-ACCELERATORS" "IS-MANAGED" + "POPUP-SPRING-LOADED" "IS-REALIZED" "WIDGET-WINDOW" "WIDGET-NAME" + "IS-SENSITIVE" "COMMAND-APPEND-VALUE" "COMMAND-ERROR" + "COMMAND-SET-VALUE" "SCALE-GET-VALUE" "SCALE-SET-VALUE" + "TOGGLE-BUTTON-GET-STATE" "TOGGLE-BUTTON-SET-STATE" + "LIST-ADD-ITEM" "LIST-ADD-ITEM-UNSELECTED" "LIST-DELETE-ITEM" + "LIST-DELETE-POS" "LIST-DESELECT-ALL-ITEMS" "LIST-DESELECT-ITEM" + "LIST-DESELECT-POS" "LIST-SELECT-ITEM" "LIST-SELECT-POS" + "LIST-SET-BOTTOM-ITEM" "LIST-SET-BOTTOM-POS" + "LIST-SET-HORIZ-POS" "LIST-SET-ITEM" "LIST-SET-POS" + "ADD-TAB-GROUP" "REMOVE-TAB-GROUP" "PROCESS-TRAVERSAL" + "FONT-LIST-ADD" "FONT-LIST-CREATE" "FONT-LIST-FREE" + "COMPOUND-STRING-BASELINE" "COMPOUND-STRING-BYTE-COMPARE" + "COMPOUND-STRING-COMPARE" "COMPOUND-STRING-CONCAT" + "COMPOUND-STRING-COPY" "COMPOUND-STRING-CREATE" + "COMPOUND-STRING-CREATE-LTOR" "COMPOUND-STRING-CREATE-SIMPLE" + "COMPOUND-STRING-CREATE-EMPTY" "COMPOUND-STRING-CREATE-EXTENT" + "COMPOUND-STRING-FREE" "COMPOUND-STRING-HAS-SUBSTRING" + "COMPOUND-STRING-HEIGHT" "COMPOUND-STRING-LENGTH" + "COMPOUND-LINE-COUNT" "COMPOUND-STRING-NCONCAT" + "COMPOUND-STRING-NCOPY" "COMPOUND-STRING-SEPARATOR-CREATE" + "COMPOUND-STRING-WIDTH" "TEXT-CLEAR-SELECTION" "TEXT-COPY" + "TEXT-CUT" "TEXT-GET-BASELINE" "TEXT-GET-EDITABLE" + "TEXT-GET-INSERTION-POINT" "TEXT-GET-LAST-POSITION" + "TEXT-GET-MAX-LENGTH" "TEXT-GET-SELECTION" + "TEXT-GET-SELECTION-POSITION" "TEXT-GET-STRING" + "TEXT-GET-TOP-CHARACTER" "TEXT-INSERT" "TEXT-PASTE" + "TEXT-POS-TO-XY" "TEXT-REMOVE" "TEXT-REPLACE" "TEXT-SCROLL" + "TEXT-SET-ADD-MODE" "TEXT-SET-EDITABLE" "TEXT-SET-HIGHLIGHT" + "TEXT-SET-INSERTION-POSITION" "TEXT-SET-MAX-LENGTH" + "TEXT-SET-SELECTION" "TEXT-SET-STRING" "TEXT-SET-TOP-CHARACTER" + "TEXT-SHOW-POSITION" "TEXT-XY-TO-POS" "MESSAGE-BOX-GET-CHILD" + "SELECTION-BOX-GET-CHILD" "FILE-SELECTION-BOX-GET-CHILD" + "COMMAND-GET-CHILD" "UPDATE-DISPLAY" "IS-MOTIF-WM-RUNNING" + "LIST-ADD-ITEMS" "LIST-DELETE-ALL-ITEMS" "LIST-DELETE-ITEMS" + "LIST-DELETE-ITEMS-POS" "LIST-ITEM-EXISTS" "LIST-ITEM-POS" + "LIST-REPLACE-ITEMS" "LIST-REPLACE-ITEMS-POS" + "LIST-SET-ADD-MODE" "TRANSLATE-COORDS" "SCROLL-BAR-GET-VALUES" + "SCROLL-BAR-SET-VALUES" "COMPOUND-STRING-GET-LTOR" + "TRACKING-LOCATE" "SCROLLED-WINDOW-SET-AREAS" "CREATE-FONT-CURSOR" + "LIST-GET-SELECTED-POS" "QUIT-APPLICATION-CALLBACK" + "DESTROY-CALLBACK" "MANAGE-CALLBACK" "UNMANAGE-CALLBACK" + "POPUP-CALLBACK" "POPDOWN-CALLBACK" "SET-ITEMS" "GET-ITEMS" + "WITH-CALLBACK-DEFERRED-ACTIONS")) + + + +;;;; Set up the tables used in defining interface components. + +(in-package "TOOLKIT") + +(defvar *request-table* (make-array 50 :element-type 'simple-string + :adjustable t :fill-pointer 0)) +(defvar *class-table* (make-array 40 :element-type 'cons + :adjustable t :fill-pointer 0)) +(defvar next-type-tag) diff --git a/motif/lisp/interface-build.lisp b/motif/lisp/interface-build.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e1578e232d8754f7b28bb1969ebae7abb6aab337 --- /dev/null +++ b/motif/lisp/interface-build.lisp @@ -0,0 +1,89 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; Interface Builder +;;; +;;; This defines functions to crunch through the information generated +;;; about the various request operations and automatically generate the +;;; interface files for the C server. + +(in-package "TOOLKIT") + + + +;;;; Files where interface information will be stored + +(defconstant *string-table-file* "target:motif/server/StringTable.h") +(defconstant *class-file* "target:motif/server/ClassTable.h") +(defconstant *interface-file* "target:motif/server/Interface.h") +(defconstant *type-file* "target:motif/server/TypeTable.h") + + + +;;;; Functions for building the C interface files + +(defun build-class-file (out) + (declare (stream out)) + (write-line "WidgetClass *class_table[] = {" out) + (dotimes (index (length *class-table*)) + (let ((entry (aref *class-table* index))) + (format out " (WidgetClass *)(&~a),~%" (cdr entry)))) + (format out " NULL~%};~%~%#define CLASS_TABLE_SIZE ~a~%" + (length *class-table*))) + +(defun build-type-file (out) + (declare (stream out)) + (write-line "type_entry type_table[] = {" out) + (dotimes (index next-type-tag) + (let* ((stuff (svref *type-table* index)) + (name (car stuff)) + (kind (cdr stuff))) + (if (and (eq kind name) (gethash kind *enum-table*)) + (setf kind (symbol-atom :enum)) + (setf kind (symbol-atom kind))) + (format out " {\"~a\",message_write_~(~a~),message_read_~(~a~)},~%" + (symbol-class name) kind kind))) + (format out " {NULL,NULL,NULL}~%};~%~%#define TYPE_TABLE_SIZE ~a~%" + next-type-tag)) + +(defun build-interface-file (out) + (declare (stream out)) + (write-line "request_f request_table[] = {" out) + (dotimes (index (length *request-table*)) + (format out " ~a,~%" (aref *request-table* index))) + (format out " NULL~%};~%")) + +(defun build-toolkit-interface () + (with-open-file (out *class-file* + :direction :output :if-exists :supersede + :if-does-not-exist :create) + (build-class-file out)) + (with-open-file (out *type-file* + :direction :output :if-exists :supersede + :if-does-not-exist :create) + (build-type-file out)) + (with-open-file (out *interface-file* + :direction :output :if-exists :supersede + :if-does-not-exist :create) + (build-interface-file out))) + +(defun build-string-table () + (with-open-file (out *string-table-file* + :direction :output :if-exists :supersede + :if-does-not-exist :create) + (declare (stream out)) + (let ((table xti::*toolkit-string-table*)) + (declare (simple-vector table)) + (write-line "String string_table[] = {" out) + (dotimes (index (length table)) + (format out " \"~a\",~%" (svref table index))) + (format out " NULL~%};~%~%") + (format out "#define STRING_TABLE_SIZE ~a~%" (length table))))) diff --git a/motif/lisp/interface-glue.lisp b/motif/lisp/interface-glue.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a2605f739a832f498d8dde50b4bdc1c87672fe29 --- /dev/null +++ b/motif/lisp/interface-glue.lisp @@ -0,0 +1,213 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; Functions which provide the glue for the interface between the C server +;;; and the Lisp client. + +(in-package "TOOLKIT") + + + +;;;; Functions for handling server requests + +(defvar reply-table + (vector :confirm :values :callback :event :error :warning :protocol :action)) + +(defun wait-for-server-reply (fd) + (wait-for-input fd) + (loop + (let ((reply (dispatch-server-reply fd))) + (when reply (return reply))))) + +(defun dispatch-server-reply (fd) + (let* ((reply (receive-message fd)) + (kind (svref reply-table (xti::message-get-dblword reply)))) + (case kind + ((:confirm :values) reply) + (:callback (handle-callback reply)) + (:protocol (handle-protocol reply)) + (:action (handle-action reply)) + (:event (handle-event reply)) + (:error + (let ((errmsg (toolkit-read-value reply))) + (destroy-message reply) + (toolkit-error "Toolkit Server -- ~a" errmsg))) + (:warning + (let ((errmsg (toolkit-read-value reply))) + (destroy-message reply) + (warn "Toolkit Server -- ~a" errmsg) + ;; Point out that this was not really a reply + nil)) + (t + (destroy-message reply) + (toolkit-error "Invalid reply type: ~d" kind))))) + +(defun send-request-to-server (message options) + (let ((fd (motif-connection-fd *motif-connection*))) + (unwind-protect + (transmit-message message fd) + (destroy-message message)) + (when (eq options :confirm) (wait-for-server-reply fd)))) + + + +;;;; Functions for handling server connections + +(defvar *default-server-host* nil + "Name of machine where the Motif server resides. Using the value NIL + causes a local connection to be made.") + +(defvar *default-display* nil + "If non-nil, the display which will be opened. Otherwise, the DISPLAY + environment variable is consulted.") + +(defvar *debug-mode* nil + "Controls whether the client is in debugging mode.") + +(defvar *active-handlers* nil + "An alist of (fd . handler) for active X toolkit connections.") + +(defvar *default-timeout-interval* 15 + "Default time, in seconds, which the Lisp process will wait for input on + the toolkit connection before assuming a timeout has occured.") + +(defvar *clm-binary-directory* "library:" + "Directory in which the Motif server resides.") + +(defvar *clm-binary-name* "motifd" + "Name of the Motif server executable.") + +(defun add-toolkit-handler (conn) + (let ((fd (motif-connection-fd conn))) + (when (assoc fd *active-handlers*) + (break "There is already a handler for fd=~d " fd)) + (push (cons fd + (system:add-fd-handler + fd :input + #'(lambda (this-fd) + (declare (ignore this-fd)) + (toolkit-handler conn)))) + *active-handlers*))) + +(defun remove-toolkit-handler (fd) + (let ((handler (cdr (assoc fd *active-handlers*)))) + (unless handler + (toolkit-error "Cannot remove handler (fd=~d) because there is none." fd)) + (system:remove-fd-handler handler) + (setf *active-handlers* (remove fd *active-handlers* + :key #'car :test #'=)))) + +(defvar *local-motif-server* nil) + +(defun local-server-status-hook (process) + (let ((status (ext:process-status process))) + (when (or (eq status :exited) + (eq status :signaled)) + (setf *local-motif-server* nil)))) + +(defun verify-local-server-exists () + (when (or (not *local-motif-server*) + (and *local-motif-server* + (not (ext:process-alive-p *local-motif-server*)))) + (let ((process (ext:run-program (merge-pathnames *clm-binary-name* + *clm-binary-directory*) + '() + :wait nil + :status-hook #'local-server-status-hook))) + (unless (and process (ext:process-alive-p process)) + (toolkit-error "Could not start local Motif server process.")) + ;; + ;; Wait until the server has started up + (loop + (when (probe-file (format nil "/tmp/.motif_socket-u~a" + (unix:unix-getuid))) + (return)) + (sleep 1)) + (setf *local-motif-server* process)))) + +(defun open-motif-connection (host dpy-name app-name app-class &optional pid) + (declare (simple-string app-name app-class)) + (unless (or host pid) + (verify-local-server-exists)) + (let* ((socket (connect-to-host host pid)) + (tmp (system:allocate-system-memory 4)) + (conn (make-motif-connection socket)) + (display (or dpy-name (cdr (assoc :display *environment-list*)))) + (clx-dpy (open-clx-display display)) + (greeting (create-message 0))) + + (unless display + (toolkit-error "No display name available.")) + + ;; + ;; Fairly gross means of sending the swap information to the server + (setf (system:sap-ref-16 tmp 0) 1) + (unwind-protect + (unix:unix-write socket tmp 0 2) + (system:deallocate-system-memory tmp 4)) + + (toolkit-write-value greeting display) + (toolkit-write-value greeting app-name) + (toolkit-write-value greeting app-class) + (transmit-message greeting socket) + (destroy-message greeting) + + (setf (motif-connection-display-name conn) display) + (setf (motif-connection-display conn) clx-dpy) + (add-toolkit-handler conn) + conn)) + +(defun close-motif-connection (connection) + (unless (motif-connection-terminated connection) + (let ((fd (motif-connection-fd connection)) + (hook (motif-connection-close-hook connection))) + (when hook + (funcall hook connection)) + (setf (motif-connection-terminated connection) t) + (remove-toolkit-handler fd) + (close-socket fd) + (xlib:close-display (motif-connection-display connection))))) + +(defmacro with-motif-connection ((connection) &body forms) + `(let ((*motif-connection* ,connection) + (*x-display* (motif-connection-display ,connection))) + (handler-case + (restart-case + (progn ,@forms) + (continue () + :report "Ignore problem and continue." + ()) + (kill-app () + :report "Close current application." + (quit-server) + (close-motif-connection ,connection))) + (toolkit-eof-error (cond) + (format t "~%Connection to server broken: ~a" cond) + (close-motif-connection ,connection) + (signal cond))))) + +(defmacro with-clx-requests (&body forms) + `(unwind-protect + (progn ,@forms) + (xlib:display-force-output *x-display*))) + +;;; This is the functions which listens for input from the server and calls +;;; the dispatcher when it detects incoming data. +(defun toolkit-handler (connection) + (unless (motif-connection-terminated connection) + (with-motif-connection (connection) + (let ((fd (motif-connection-fd connection))) + (cond + ((wait-for-input-or-timeout fd *default-timeout-interval*) + (dispatch-server-reply fd)) + (t + (warn "Got timeout on fd=~d" fd))) + (xlib:display-force-output *x-display*))))) diff --git a/motif/lisp/internals.lisp b/motif/lisp/internals.lisp new file mode 100644 index 0000000000000000000000000000000000000000..fcdebae7df7706fc2107358c66f28acaa70f1e06 --- /dev/null +++ b/motif/lisp/internals.lisp @@ -0,0 +1,214 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; This file contains internal functions required to support the Motif +;;; toolkit in Lisp. +;;; + +(in-package "TOOLKIT-INTERNALS") + + + +;;;; Special TOOLKIT-ERROR + +(define-condition toolkit-error (error) + ((format-string) + (format-arguments)) + (:documentation "An error has occurred in the X Toolkit code.") + (:report (lambda (condition stream) + (declare (stream stream)) + (format stream "A Toolkit error has occurred.~%~?" + (toolkit-error-format-string condition) + (toolkit-error-format-arguments condition))))) + +(define-condition toolkit-eof-error (toolkit-error) + ((string)) + (:report (lambda (condition stream) + (write-line (toolkit-eof-error-string condition) stream)))) + +;;; TOOLKIT-ERROR -- Internal +;;; TOOLKIT-CERROR -- Internal +;;; +;;; These functions act just like ERROR and CERROR except that they signal +;;; a TOOLKIT-ERROR instead of a SIMPLE-ERROR. This is mainly intended for +;;; a graphical debugger which must stop attempting graphical interaction +;;; when a toolkit error occurs. +;;; +(declaim (inline toolkit-error toolkit-cerror)) +(defun toolkit-error (string &rest args) + (error 'toolkit-error :format-string string :format-arguments args)) + +(defun toolkit-cerror (continue-string string &rest args) + (cerror continue-string 'toolkit-error + :format-string string :format-arguments args)) + + + +;;;; Internal communication functions + +(defvar *xt-tcp-port* 8000) + +(defun connect-to-host (host pid) + (declare (type (or null simple-string) host)) + (handler-case + (if host + (handler-case + (ext:connect-to-inet-socket host *xt-tcp-port*) + (error () + (ext:connect-to-inet-socket host (+ *xt-tcp-port* + (unix:unix-getuid))))) + (handler-case + (ext::connect-to-unix-socket + (if pid + (format nil "/tmp/.motif_socket-p~a" pid) + (format nil "/tmp/.motif_socket-u~a" (unix:unix-getuid)))) + (error () + (ext:connect-to-unix-socket "/tmp/.motif_socket")))) + (error () + (toolkit-error "Unable to connect to Motif server.")))) + +(declaim (inline wait-for-input wait-for-input-or-timeout)) +(defun wait-for-input (fd) + (system:wait-until-fd-usable fd :input)) + +(defun wait-for-input-or-timeout (fd interval) + (system:wait-until-fd-usable fd :input interval)) + + + +;;;; Toolkit connection stuff + +;;; These will be dynamically bound in the context of the event handlers. +(defvar *motif-connection*) +(defvar *x-display*) + +(defstruct (motif-connection + (:print-function print-motif-connection) + (:constructor make-motif-connection (fd))) + fd + (display-name "" :type simple-string) + display + (serial 1 :type fixnum) + (terminated nil :type (member t nil)) + (close-hook nil :type (or symbol function)) + ;; + ;; This maps widget ids (unsigned-byte 32)'s into widget structures + (widget-table (make-hash-table :test #'eq) :type hash-table) + (function-table (make-array 32 :element-type '(or symbol function) + :adjustable t :fill-pointer 0)) + (callback-table (make-hash-table :test #'equal) :type hash-table) + (protocol-table (make-hash-table :test #'equal) :type hash-table) + (event-table (make-hash-table :test #'equal) :type hash-table) + ;; This table tracks all the misc. id's we get from the server + ;; ie. xm-strings, translations, accelerators, font-lists + (id-table (make-hash-table :test #'eq) :type hash-table)) + +(defun print-motif-connection (c stream d) + (declare (ignore d) + (stream stream)) + (format stream "#<X Toolkit Connection, fd=~a>" + (motif-connection-fd c))) + + + +;;;; Internal structure definitions + +(defstruct (widget + (:print-function print-widget) + (:constructor make-widget (id))) + (id 0 :type (unsigned-byte 32)) + (type nil :type symbol) + (parent nil :type widget) + (children nil :type list) + (callbacks nil :type list) + (protocols nil :type list) + (events nil :type list) + (user-data nil)) + +;; A toolkit object is simply a wrapper for a pointer passed from the server +;; process. The TYPE field allows us to discriminate the type of the pointer +;; but still treat all pointers in the same way (ie. instead of having separate +;; tables for xmstring, font-list, etc.) +;; +(defstruct (motif-object + (:print-function print-motif-object) + (:constructor make-motif-object (id))) + (id 0 :type (unsigned-byte 32)) + (type nil :type symbol)) + +(defun print-widget (w stream d) + (declare (ignore d) + (stream stream)) + (format stream "#<X Toolkit Widget: ~A ~X>" (widget-type w) (widget-id w))) + +(defun print-motif-object (obj stream d) + (declare (ignore d) + (stream stream)) + (format stream "#<Motif object: ~A ~X>" + (motif-object-type obj) (motif-object-id obj))) + +;;; Some handy type abbreviations for motif-object +(deftype xmstring () 'motif-object) +(deftype font-list () 'motif-object) +(deftype translations () 'motif-object) +(deftype accelerators () 'motif-object) + + + +;;;; Tables for tracking stuff + +(defvar *toolkit-string-table* (make-array 350 :element-type 'simple-string + :adjustable t :fill-pointer 0)) + +(defun find-widget (id) + (declare (type (unsigned-byte 32) id)) + (let* ((widget-table (motif-connection-widget-table *motif-connection*)) + (widget (gethash id widget-table))) + (unless widget + (setf widget (make-widget id)) + (setf (gethash id widget-table) widget)) + widget)) + +(defun find-motif-object (id type) + (declare (type (unsigned-byte 32) id) + (symbol type)) + (let* ((table (motif-connection-id-table *motif-connection*)) + (object (gethash id table))) + (unless object + (setf object (make-motif-object id)) + (setf (gethash id table) object)) + (setf (motif-object-type object) type) + object)) + + + +;;;; Various helpful goodies + +;;; Converts a symbol into a resource class +;;; ex. :label-string ===> LabelString +(defun symbol-class (symbol) + (delete #\- (string-capitalize (symbol-name symbol)))) + +;;; Converts a symbol into a resource base-name. +;;; ex. :label-string ===> labelString +(defun symbol-resource (symbol) + (let ((resource (symbol-class symbol))) + (setf (schar resource 0) (char-downcase (schar resource 0))) + resource)) + +;;; Converts a symbol into an atom. +(defun symbol-atom (symbol) + (substitute #\_ #\- (symbol-name symbol))) + +(defun widget-add-child (parent child) + (declare (type widget parent child)) + (setf (widget-parent child) parent) + (push child (widget-children parent))) diff --git a/motif/lisp/main.lisp b/motif/lisp/main.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a9e96dae039addcf5e578cd85d4cff15b234b258 --- /dev/null +++ b/motif/lisp/main.lisp @@ -0,0 +1,108 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; Various high-level interface functions for use with the Motif toolkit. +;;; + +(in-package "TOOLKIT") + + + +;;; These are just randomly placed here at the moment. +(defconstant string-default-charset "" + "The default character set used in building Motif compound strings.") + +(defun font-list-add-component (flist charset font-spec) + (let ((font (xlib:open-font *x-display* font-spec))) + (xlib:display-force-output *x-display*) + (font-list-add flist font charset))) + +(defun build-simple-font-list (name font-spec) + (let ((font (xlib:open-font *x-display* font-spec))) + (xlib:display-force-output *x-display*) + (font-list-create font name))) + + +(defun build-font-list (specs) + (let* ((first (car specs)) + (flist (build-simple-font-list (car first) (cadr first))) + (specs (cdr specs))) + (dolist (spec specs) + (setf flist (font-list-add-component flist (car spec) (cadr spec)))) + flist)) + + + +;;;; Some standard useful callbacks + +(defun quit-application () + "Standard function for quitting an X Toolkit application." + (quit-server) + (close-motif-connection *motif-connection*) + (throw 'lisp::top-level-catcher nil)) + +(defun quit-application-callback (widget call-data) + "Standard callback for quitting an X Toolkit application." + (declare (ignore widget call-data)) + (quit-application)) + +(defun destroy-callback (widget call-data &rest targets) + (declare (ignore call-data)) + (if targets + (dolist (target targets) + (destroy-widget target)) + (destroy-widget widget))) + +(defun manage-callback (widget call-data &rest targets) + (declare (ignore call-data)) + (if targets + (apply #'manage-children targets) + (manage-child widget))) + +(defun unmanage-callback (widget call-data &rest targets) + (declare (ignore call-data)) + (if targets + (apply #'unmanage-children targets) + (unmanage-child widget))) + +(defun popup-callback (widget call-data kind &rest targets) + (declare (ignore call-data)) + (if targets + (dolist (target targets) + (popup target kind)) + (popup widget kind))) + +(defun popdown-callback (widget call-data &rest targets) + (declare (ignore call-data)) + (if targets + (dolist (target targets) + (popdown target)) + (popdown widget))) + + + +;;;; A convenient (and CLM compatible) way to start Motif applications + +(defun run-motif-application (init-function + &key + (init-args nil) + (application-class "Lisp") + (application-name "lisp") + (server-host *default-server-host*) + (display *default-display*) + (sync-clx *debug-mode*)) + (declare (ignore sync-clx)) + (let ((connection (open-motif-connection server-host display + application-name + application-class))) + (with-motif-connection (connection) + (apply init-function init-args)) + connection)) diff --git a/motif/lisp/prototypes.lisp b/motif/lisp/prototypes.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c6dfe8680abfbccac0d44ab28da0916808ba5606 --- /dev/null +++ b/motif/lisp/prototypes.lisp @@ -0,0 +1,800 @@ +;;;; -*- Mode: Lisp, Fill ; Package: Toolkit -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; This file contains the prototyping code for RPC requests between the +;;; Lisp client and the C server. +;;; + +(in-package "TOOLKIT") + +(declaim (vector *request-table*)) +(eval-when (compile) (setf (fill-pointer *request-table*) 0)) + + + +;;;; Macros for defining toolkit request operations + +(eval-when (compile eval) +(defmacro def-toolkit-request (string-name symbol-name options + doc-string args return &body forms) + (declare (simple-string string-name doc-string) + (list args return)) + (let ((arg-list (mapcar #'car args)) + (type-list (mapcar #'cadr args)) + (code (fill-pointer *request-table*))) + (vector-push-extend (format nil "R~a" string-name) *request-table*) + `(defun ,symbol-name ,arg-list + ,doc-string + ;; *** This generates lots of warnings at the moment + ;; (declare (inline toolkit-write-value)) + ,(cons 'declare + (mapcar #'(lambda (arg type) (list 'type type arg)) + arg-list type-list)) + (let ((message (prepare-request ,code ,options ,(length args)))) + ,(cons 'progn + (mapcar #'(lambda (arg) + (let ((name (first arg)) + (type (third arg))) + (if type + (list 'toolkit-write-value 'message name type) + (list 'toolkit-write-value 'message name)))) + args)) + (let ((reply (send-request-to-server message ,options))) + ,(if (eq options :confirm) + `(multiple-value-prog1 + ,(ecase (length return) + (0) + (1 `(let ((result (toolkit-read-value reply))) + ,@forms + result)) + (2 `(let* ((first (toolkit-read-value reply)) + (second (toolkit-read-value reply))) + ,@forms + (values first second))) + (3 `(let* ((first (toolkit-read-value reply)) + (second (toolkit-read-value reply)) + (third (toolkit-read-value reply))) + ,@forms + (values first second third))) + (4 `(let* ((first (toolkit-read-value reply)) + (second (toolkit-read-value reply)) + (third (toolkit-read-value reply)) + (fourth (toolkit-read-value reply))) + ,@forms + (values first second third fourth)))) + (destroy-message reply)) + '(declare (ignore reply)))))))) +) ;; EVAL-WHEN + +;;; This is for sending commands to the server, not requesting Motif +;;; services. These calls take no arguments and return a value indicating +;;; whether they were successful. +(eval-when (compile eval) + (defmacro def-toolkit-command (symbol-name options &body forms) + (let ((string-name (symbol-class symbol-name)) + (code (fill-pointer *request-table*))) + (vector-push-extend string-name *request-table*) + `(defun ,symbol-name () + (let* ((message (prepare-request ,code ,options 0)) + (reply (send-request-to-server message ,options))) + ,(if (eq options :confirm) + `(let ((result (toolkit-read-value reply))) + (destroy-message reply) + ,@forms + result) + '(declare (ignore reply)))))))) + + + +;;;; Direct commands to server + +(def-toolkit-command quit-server :no-confirm) + +(def-toolkit-command terminate-callback :no-confirm) + + + + +;;;; Request definitions for Xt Intrinsic functions + +(def-toolkit-request "TransportEvent" transport-event :confirm + "" + ((event-handle (unsigned-byte 32))) ((alien xevent))) + +(def-toolkit-request "XtAppCreateShell" %create-application-shell :confirm + "" + ((resources list :resource-list)) + (widget) + (setf (widget-type result) :application-shell)) + +(def-toolkit-request "XtRealizeWidget" realize-widget :no-confirm + "Realizes the given widget." + ((widget widget)) ()) + +(def-toolkit-request "XtCreateManagedWidget" %create-managed-widget :confirm + "" + ((name simple-string) (widget-class keyword) (parent widget) + (resources list :resource-list)) + (widget) + (setf (widget-type result) widget-class) + (widget-add-child parent result)) + +(def-toolkit-request "XtCreateWidget" %create-widget :confirm + "" + ((name simple-string) (widget-class keyword) (parent widget) + (resources list :resource-list)) + (widget) + (setf (widget-type result) widget-class) + (widget-add-child parent result)) + +(def-toolkit-request "XtAddCallback" %add-callback :no-confirm + "" + ((widget widget) (name simple-string)) ()) + +(def-toolkit-request "XtRemoveCallback" %remove-callback :no-confirm + "" + ((widget widget) (name simple-string)) ()) + +(def-toolkit-request "XtSetValues" %set-values :no-confirm + "" + ((widget widget) (resources list :resource-list)) ()) + +(def-toolkit-request "XtGetValues" %get-values :confirm + "" + ((widget widget) (resource-names list :resource-names)) + (list)) + +(def-toolkit-request "XtUnrealizeWidget" unrealize-widget :no-confirm + "Unrealizes the given widget." + ((widget widget)) ()) + +(def-toolkit-request "XtDestroyWidget" %destroy-widget :no-confirm + "" + ((widget widget)) ()) + +(def-toolkit-request "XtMapWidget" map-widget :no-confirm + "Maps the X window associated with the given widget." + ((widget widget)) ()) + +(def-toolkit-request "XtUnmapWidget" unmap-widget :no-confirm + "Unmaps the X window associated with the given widget." + ((widget widget)) ()) + +(def-toolkit-request "XtSetSensitive" set-sensitive :no-confirm + "Sets the event sensitivity of the given widget." + ((widget widget) (sensitivep (member t nil))) ()) + +(def-toolkit-request "XtCreatePopupShell" %create-popup-shell :confirm + "" + ((name simple-string) (class keyword) + (parent widget) (resources list :resource-list)) + (widget) + (setf (widget-type result) class) + (widget-add-child parent result)) + +(def-toolkit-request "XtPopup" popup :no-confirm + "Pops up a popup dialog shell." + ((shell widget) (grab-kind keyword)) ()) + +(def-toolkit-request "XtPopdown" popdown :no-confirm + "Pops down a popup dialog shell." + ((shell widget)) ()) + +(def-toolkit-request "XtManageChild" manage-child :no-confirm + "Manages the given child widget." + ((child widget)) ()) + +(def-toolkit-request "XtUnmanageChild" unmanage-child :no-confirm + "Unmanages the given child widget." + ((child widget)) ()) + +(def-toolkit-request "XtManageChildren" %manage-children :no-confirm + "" + ((child-list list :widget-list)) ()) + +(def-toolkit-request "XtUnmanageChildren" %unmanage-children :no-confirm + "" + ((child-list list :widget-list)) ()) + +(def-toolkit-request "XtParseTranslationTable" parse-translation-table :confirm + "Compiles a translation table string into its internal representation." + ((table simple-string)) (translations)) + +(def-toolkit-request "XtAugmentTranslations" augment-translations :no-confirm + "Augments the translation table of the specified widget with the given + translations." + ((w widget) (table translations)) ()) + +(def-toolkit-request "XtOverrideTranslations" override-translations :no-confirm + "Overrides the translation table of the specified widget with the given + translations." + ((w widget) (table translations)) ()) + +(def-toolkit-request "XtUninstallTranslations" uninstall-translations + :no-confirm + "Unintalls all translations on the given widget." + ((w widget)) ()) + +(def-toolkit-request "XtParseAcceleratorTable" parse-accelerator-table :confirm + "Parses an accelerator string into its internal representation." + ((source simple-string)) (accelerators)) + +(def-toolkit-request "XtInstallAccelerators" install-accelerators :no-confirm + "Installs accelerators from the source widget into the destination widget." + ((dest widget) (src widget)) ()) + +(def-toolkit-request "XtInstallAllAccelerators" install-all-accelerators + :no-confirm + "Installs all accelerators from the source widget into the destination + widget." + ((dest widget) (src widget)) ()) + +(def-toolkit-request "XtIsManaged" is-managed :confirm + "Returns a value indicating whether the specified widget is managed or not." + ((widget widget)) ((member t nil))) + +(def-toolkit-request "XtPopupSpringLoaded" popup-spring-loaded :no-confirm + "Pops up a spring loaded popup dialog shell." + ((shell widget)) ()) + +(def-toolkit-request "XtIsRealized" is-realized :confirm + "Returns a value indicating whether the specified widget is realized or not." + ((widget widget)) ((member t nil))) + +(def-toolkit-request "XtWindow" widget-window :confirm + "Returns the X window associated with the given widget." + ((widget widget)) (xlib:window)) + +(def-toolkit-request "XtName" widget-name :confirm + "Returns the name of the given widget." + ((widget widget)) (string)) + +(def-toolkit-request "XtIsSensitive" is-sensitive :confirm + "Returns the sensitivity state of the given widget." + ((widget widget)) ((member t nil))) + +(def-toolkit-request "XtAddEventHandler" %add-event-handler :no-confirm + "" + ((widget widget) (mask (unsigned-byte 32)) (nonmaskable_p (member t nil))) + ()) + +(def-toolkit-request "XtRemoveEventHandler" %remove-event-handler :no-confirm + "" + ((widget widget) (mask (unsigned-byte 32)) (nonmaskable_p (member t nil))) + ()) + +(def-toolkit-request "XtTranslateCoords" translate-coords :confirm + "Translates coordinates (x,y) in the window of the given widget into the + corresponding coordinates in the root window." + ((widget widget) (x fixnum) (y fixnum)) + (fixnum fixnum)) + +(def-toolkit-request "XCreateFontCursor" create-font-cursor :confirm + "Creates an X cursor from the standard cursor font." + ((shape fixnum)) + (xlib:cursor)) + + + +;;;; Request definitions for Motif functions + +;; We will ask for confirmation here just to resync things +(def-toolkit-request "XmUpdateDisplay" update-display :confirm + "Processes all pending exposure events and synchronizes with the server." + ((w widget)) ()) + +(def-toolkit-request "XmIsMotifWMRunning" is-motif-wm-running :confirm + "Specifies if the MWM window manager is running." + ((shell widget)) ((member t nil))) + +(def-toolkit-request "XmMenuPosition" %menu-position :no-confirm + "" + ((widget widget) (event-handle (unsigned-byte 32) :event)) ()) + +(def-toolkit-request "XmCreateMenuBar" %create-menu-bar :confirm + "" + ((parent widget) (name simple-string) (resources list :resource-list)) + (widget) + (setf (widget-type result) :row-column) + (widget-add-child parent result)) + +(def-toolkit-request "XmCreateOptionMenu" %create-option-menu :confirm + "" + ((parent widget) (name simple-string) (resources list :resource-list)) + (widget) + (setf (widget-type result) :row-column) + (widget-add-child parent result)) + +(def-toolkit-request "XmCreateRadioBox" %create-radio-box :confirm + "" + ((parent widget) (name simple-string) (resources list :resource-list)) + (widget) + (setf (widget-type result) :row-column) + (widget-add-child parent result)) + +(macrolet ((def-double-widget-stub (name parent-class child-class) + (let ((strname (format nil "Xm~a"(symbol-class name))) + (fn-name (read-from-string + (format nil "%~a" name)))) + `(def-toolkit-request ,strname ,fn-name :confirm + "" + ((parent widget) (name simple-string) + (resources list :resource-list)) + (widget widget) + (setf (widget-type second) ,parent-class) + (setf (widget-type first) ,child-class) + (widget-add-child parent second) + (widget-add-child second first))))) + + (def-double-widget-stub create-warning-dialog :dialog-shell :message-box) + (def-double-widget-stub create-bulletin-board-dialog :dialog-shell + :bulletin-board) + (def-double-widget-stub create-error-dialog :dialog-shell :message-box) + (def-double-widget-stub create-file-selection-dialog :dialog-shell + :file-selection-box) + (def-double-widget-stub create-form-dialog :dialog-shell :form) + (def-double-widget-stub create-information-dialog :dialog-shell + :message-box) + (def-double-widget-stub create-message-dialog :dialog-shell :message-box) + (def-double-widget-stub create-popup-menu :menu-shell :row-column) + (def-double-widget-stub create-prompt-dialog :dialog-shell :selection-box) + (def-double-widget-stub create-pulldown-menu :menu-shell :row-column) + (def-double-widget-stub create-question-dialog :dialog-shell :message-box) + (def-double-widget-stub create-scrolled-list :scrolled-window :list) + (def-double-widget-stub create-scrolled-text :scrolled-window :text) + (def-double-widget-stub create-selection-dialog :dialog-shell + :selection-box) + (def-double-widget-stub create-working-dialog :dialog-shell :message-box)) + +(def-toolkit-request "XmCommandAppendValue" command-append-value :no-confirm + "Appends the given string to the end of the string displayed in the + command area of the widget." + ((w widget) (command (or simple-string xmstring))) ()) + +(def-toolkit-request "XmCommandError" command-error :no-confirm + "Displays an error message in the Command widget." + ((w widget) (error (or simple-string xmstring))) ()) + +(def-toolkit-request "XmCommandSetValue" command-set-value :no-confirm + "Replaces the displayed string in a Command widget." + ((w widget) (c (or simple-string xmstring))) ()) + +(def-toolkit-request "XmScaleGetValue" scale-get-value :confirm + "Returns the current slider position." + ((w widget)) (fixnum)) + +(def-toolkit-request "XmScaleSetValue" scale-set-value :no-confirm + "Sets the current slider position." + ((w widget) (val fixnum)) ()) + +(def-toolkit-request "XmToggleButtonGetState" toggle-button-get-state :confirm + "Obtains the state of a ToggleButton." + ((w widget)) ((member t nil))) + +(def-toolkit-request "XmToggleButtonSetState" toggle-button-set-state + :no-confirm + "Sets the state of a ToggleButton." + ((w widget) (state (member t nil)) (notify (member t nil))) ()) + +(def-toolkit-request "XmListAddItem" list-add-item :no-confirm + "Adds an item to the given List widget." + ((w widget) (item (or simple-string xmstring)) (pos fixnum)) ()) + +(def-toolkit-request "XmListAddItemUnselected" list-add-item-unselected + :no-confirm + "Adds an item to the List widget as an unselected entry." + ((w widget) (item (or simple-string xmstring)) (pos fixnum)) ()) + +(def-toolkit-request "XmListDeleteItem" list-delete-item :no-confirm + "Deletes an item from the given List widget." + ((w widget) (item (or simple-string xmstring))) ()) + +(def-toolkit-request "XmListDeletePos" list-delete-pos :no-confirm + "Deletes and item from a List widget at the specified position." + ((w widget) (pos fixnum)) ()) + +(def-toolkit-request "XmListDeselectAllItems" list-deselect-all-items + :no-confirm + "Unhighlights and removes all items from the selected list." + ((w widget)) ()) + +(def-toolkit-request "XmListDeselectItem" list-deselect-item :no-confirm + "Deselects the specified item from the selected list." + ((w widget) (item (or simple-string xmstring))) ()) + +(def-toolkit-request "XmListDeselectPos" list-deselect-pos :no-confirm + "Deselects an item at a specified position in a List widget." + ((w widget) (pos fixnum)) ()) + +(def-toolkit-request "XmListSelectItem" list-select-item :no-confirm + "Selects an item in the List widget." + ((w widget) (item (or simple-string xmstring)) (notify (member t nil))) ()) + +(def-toolkit-request "XmListSelectPos" list-select-pos :no-confirm + "Selects an item at a specified position in the List widget." + ((w widget) (pos fixnum) (notify (member t nil))) ()) + +(def-toolkit-request "XmListSetBottomItem" list-set-bottom-item :no-confirm + "Makes an existing item the last visible in the List widget." + ((w widget) (item (or simple-string xmstring))) ()) + +(def-toolkit-request "XmListSetBottomPos" list-set-bottom-pos :no-confirm + "Makes the item at the specified position the last visible item in the + given List widget." + ((w widget) (pos fixnum)) ()) + +(def-toolkit-request "XmListSetHorizPos" list-set-horiz-pos :no-confirm + "Scrolls to the specified position in the List widget." + ((w widget) (pos fixnum)) ()) + +(def-toolkit-request "XmListSetItem" list-set-item :no-confirm + "Makes an existing item the first visible in the List widget." + ((w widget) (item (or simple-string xmstring))) ()) + +(def-toolkit-request "XmListSetPos" list-set-pos :no-confirm + "Makes the item at the given position the first visible item in the List." + ((w widget) (pos fixnum)) ()) + +(def-toolkit-request "XmListAddItems" list-add-items :no-confirm + "Adds items to the given List widget." + ((w widget) (items list :xm-string-table) (pos fixnum)) ()) + +(def-toolkit-request "XmListDeleteAllItems" list-delete-all-items :no-confirm + "Deletes all items from the List widget." + ((w widget)) ()) + +(def-toolkit-request "XmListDeleteItems" list-delete-items :no-confirm + "Deletes specified items from the List widget." + ((w widget) (items list :xm-string-table)) ()) + +(def-toolkit-request "XmListDeleteItemsPos" list-delete-items-pos :no-confirm + "Deletes items from the list starting at the given position." + ((w widget) (item-count fixnum) (pos fixnum)) ()) + +(def-toolkit-request "XmListItemExists" list-item-exists :confirm + "Checks if a specified item is in the List widget." + ((w widget) (item (or simple-string xmstring))) ((member t nil))) + +(def-toolkit-request "XmListItemPos" list-item-pos :confirm + "Returns the position of an item in the List widget." + ((w widget) (item (or simple-string xmstring))) (fixnum)) + +(def-toolkit-request "XmListReplaceItems" list-replace-items :no-confirm + "Replaces the specified elements in the list." + ((w widget) (old list :xm-string-table) (new list :xm-string-table)) ()) + +(def-toolkit-request "XmListReplaceItemsPos" list-replace-items-pos :no-confirm + "Replaces items in the list, starting at the given position." + ((w widget) (new-items list :xm-string-table) (pos fixnum)) ()) + +(def-toolkit-request "XmListSetAddMode" list-set-add-mode :no-confirm + "Sets the state of Add Mode in the list." + ((w widget) (mode (member t nil))) ()) + +(def-toolkit-request "XmListGetSelectedPos" list-get-selected-pos :confirm + "Returns the position of every selected item in the given List." + ((w widget)) + (list (member t nil))) + +(def-toolkit-request "XmAddTabGroup" add-tab-group :no-confirm + "Adds a manager or a primitive widget to the list of tab groups." + ((w widget)) ()) + +(def-toolkit-request "XmRemoveTabGroup" remove-tab-group :no-confirm + "Removes a manager or a primitive widget from the list of tab groups." + ((w widget)) ()) + +(def-toolkit-request "XmProcessTraversal" process-traversal :confirm + "Determines which component of a widget hierarchy receives keyboard + events when a widget has the keyboard focus." + ((w widget) (direction keyword)) ((member t nil))) + +(def-toolkit-request "XmFontListAdd" font-list-add :confirm + "Adds a new font to a font-list and destroys the old list." + ((flist font-list) (font xlib:font) (charset simple-string)) + (font-list)) + +(def-toolkit-request "XmFontListCreate" font-list-create :confirm + "Creates a new font-list with the specified font." + ((font xlib:font) (charset simple-string)) + (font-list)) + +(def-toolkit-request "XmFontListFree" font-list-free :no-confirm + "Destroys the given font-list." + ((flist font-list)) ()) + +(def-toolkit-request "XmStringBaseline" compound-string-basline :confirm + "Returns the number of pixels between the top of the character box and + the basline of the first line of text." + ((flist font-list) (string xmstring)) (fixnum)) + +(def-toolkit-request "XmStringByteCompare" compound-string-byte-compare + :confirm + "Indicates the result of a byte-by-byte comparison of two compound strings." + ((s1 xmstring) (s2 xmstring)) ((member t nil))) + +(def-toolkit-request "XmStringCompare" compound-string-compare :confirm + "Indicates whether two compound strings are semantically equivalent." + ((s1 xmstring) (s2 xmstring)) ((member t nil))) + +(def-toolkit-request "XmStringConcat" compound-string-concat :confirm + "Appends one compound string to another. The original strings are preserved." + ((s1 xmstring) (s2 xmstring)) (xmstring)) + +(def-toolkit-request "XmStringCopy" compound-string-copy :confirm + "Makes a copy of a compound string." + ((s xmstring)) (xmstring)) + +(def-toolkit-request "XmStringCreate" compound-string-create :confirm + "Creates a new compound string." + ((s simple-string) (charset simple-string)) (xmstring)) + +(def-toolkit-request "XmStringCreateLtoR" compound-string-create-ltor :confirm + "Creates a new compound string and translates newline characters into + line separators." + ((s simple-string) (charset simple-string)) (xmstring)) + +(def-toolkit-request "XmStringGetLtoR" compound-string-get-ltor :confirm + "Returns True if a segment can be found in the input compound string that + matches the specified character set." + ((string xmstring) (charset simple-string)) + (simple-string (member t nil))) + +(def-toolkit-request "XmStringCreateSimple" compound-string-create-simple + :confirm + "Creates a compound string in the language environment of a widget." + ((s simple-string)) (xmstring)) + +(def-toolkit-request "XmStringEmpty" compound-string-empty :confirm + "Provides information on the existence of non-zero length text components." + ((s xmstring)) ((member t nil))) + +(def-toolkit-request "XmStringExtent" compound-string-extent :confirm + "Determines the size of the smallest rectangle that will enclose the + given compound string." + ((flist font-list) (x xmstring)) (fixnum fixnum)) + +(def-toolkit-request "XmStringFree" compound-string-free :no-confirm + "Recovers memory used by a compound string." + ((s xmstring)) () + (remhash (xti::motif-object-id s) + (xti::motif-connection-id-table *motif-connection*))) + +(def-toolkit-request "XmStringHasSubstring" compound-string-has-substring + :confirm + "Indicates whether one compound string is contained within another." + ((string xmstring) (substring xmstring)) ((member t nil))) + +(def-toolkit-request "XmStringHeight" compound-string-height :confirm + "Returns the line height of the given compound string." + ((flist font-list) (string xmstring)) (fixnum)) + +(def-toolkit-request "XmStringLength" compound-string-length :confirm + "Obtains the length of a compound string." + ((string xmstring)) (fixnum)) + +(def-toolkit-request "XmStringLineCount" compound-string-line-count :confirm + "Returns the number of separators plus one in the provided compound string." + ((string xmstring)) (fixnum)) + +(def-toolkit-request "XmStringNConcat" compound-string-nconcat :confirm + "Appends a specified number of bytes to a compound string." + ((s1 xmstring) (s2 xmstring) (num_bytes fixnum)) (xmstring)) + +(def-toolkit-request "XmStringNCopy" compound-string-ncopy :confirm + "Copies a specified number of bytes into a new compound string." + ((s string) (num_bytes fixnum)) (xmstring)) + +(def-toolkit-request "XmStringSeparatorCreate" compound-string-separator-create + :confirm + "Creates a compound string with a single component, a separator." + () (xmstring)) + +(def-toolkit-request "XmStringWidth" compound-string-width :confirm + "Returns the width of the longest sequence of text components in a + compound string." + ((flist font-list) (s xmstring)) (fixnum)) + +(def-toolkit-request "XmTextClearSelection" text-clear-selection :no-confirm + "Clears the primary selection." + ((w widget)) ()) + +(def-toolkit-request "XmTextCopy" text-copy :confirm + "Copies the primary selection to the clipboard." + ((w widget)) ((member t nil))) + +(def-toolkit-request "XmTextCut" text-cut :confirm + "Copies the primary selection to the clipboard and deletes the selected text." + ((w widget)) ((member t nil))) + +(def-toolkit-request "XmTextGetBaseline" text-get-basline :confirm + "Accesses the x position of the first baseline." + ((w widget)) (fixnum)) + +(def-toolkit-request "XmTextGetEditable" text-get-editable :confirm + "Accesses the edit permission state of the Text widget." + ((w widget)) ((member t nil))) + +(def-toolkit-request "XmTextGetInsertionPosition" text-get-insertion-position + :confirm + "Accesses the positions of the insert cursor." + ((w widget)) (fixnum)) + +(def-toolkit-request "XmTextGetLastPosition" text-get-last-position :confirm + "Accesses the positio of the last text character." + ((w widget)) (fixnum)) + +(def-toolkit-request "XmTextGetMaxLength" text-get-max-length :confirm + "Accesses the value of the current maximum allowable length of a text + string entered from the keyboard." + ((w widget)) (fixnum)) + +(def-toolkit-request "XmTextGetSelection" text-get-selection :confirm + "Retrieves the value of the primary selection." + ((w widget)) (simple-string)) + +(def-toolkit-request "XmTextGetSelectionPosition" text-get-selection-position + :confirm + "Accesses the position of the primary selection." + ((w widget)) + ((member t nil) fixnum fixnum)) + +(def-toolkit-request "XmTextGetString" text-get-stringtring :confirm + "Accesses the string value of a Text widget." + ((w widget)) (simple-string)) + +(def-toolkit-request "XmTextGetTopCharacter" text-get-top-character :confirm + "Accesses the position of the first character displayed." + ((w widget)) (fixnum)) + +(def-toolkit-request "XmTextInsert" text-insert :no-confirm + "Inserts a character string into a Text widget." + ((w widget) (pos fixnum) (value simple-string)) ()) + +(def-toolkit-request "XmTextPaste" text-paste :confirm + "Inserts the clipboard selection." + ((w widget)) ((member t nil))) + +(def-toolkit-request "XmTextPosToXY" text-pos-to-xy :confirm + "Accesses the x and y position of a character position." + ((w widget) (pos fixnum)) + ((member t nil) fixnum fixnum)) + +(def-toolkit-request "XmTextRemove" text-remove :confirm + "Deletes the primary selection." + ((w widget)) ((member t nil))) + +(def-toolkit-request "XmTextReplace" text-replace :no-confirm + "Replaces part of the text of a Text widget." + ((w widget) (from-pos fixnum) (to-pos fixnum) (value simple-string)) ()) + +(def-toolkit-request "XmTextScroll" text-scroll :no-confirm + "Scrolls the text of a Text widget." + ((w widget) (lines fixnum)) ()) + +(def-toolkit-request "XmTextSetAddMode" text-set-add-mode :no-confirm + "Sets the state of Add Mode." + ((w widget) (state (member t nil))) ()) + +(def-toolkit-request "XmTextSetEditable" text-set-editable :no-confirm + "Sets the edit permission on a Text widget." + ((w widget) (editable (member t nil))) ()) + +(def-toolkit-request "XmTextSetHighlight" text-set-highlight :no-confirm + "Highlights text." + ((w widget) (left fixnum) (right fixnum) (mode keyword)) ()) + +(def-toolkit-request "XmTextSetInsertionPosition" text-set-insertion-position + :no-confirm + "Sets position of the insert cursor." + ((w widget) (pos fixnum)) ()) + +(def-toolkit-request "XmTextSetMaxLength" text-set-max-length :no-confirm + "Sets the value of the current maximum allowable length of a text string + entered from the keyboard." + ((w widget) (max-length fixnum)) ()) + +(def-toolkit-request "XmTextSetSelection" text-set-selection :no-confirm + "Sets the primary selection of the Text widget." + ((w widget) (first fixnum) (last fixnum)) ()) + +(def-toolkit-request "XmTextSetString" text-set-string :no-confirm + "Sets the string value of a Text widget." + ((w widget) (value simple-string)) ()) + +(def-toolkit-request "XmTextSetTopCharacter" text-set-top-character :no-confirm + "Sets the position of the first character displayed." + ((w widget) (top-char fixnum)) ()) + +(def-toolkit-request "XmTextShowPosition" text-show-position :no-confirm + "Forces text at a given position to be displayed." + ((w widget) (pos fixnum)) ()) + +(def-toolkit-request "XmTextXYToPos" text-xy-to-pos :confirm + "Accesses the character position nearest an x and y position." + ((w widget) (x fixnum) (y fixnum)) (fixnum)) + +(def-toolkit-request "XmAddProtocolCallback" %add-protocol-callback + :no-confirm + "" + ((w widget) (property keyword :atom) (protocol keyword :atom)) ()) + +(def-toolkit-request "XmRemoveProtocolCallback" %remove-protocol-callback + :no-confirm + "" + ((w widget) (property keyword :atom) (protocol keyword :atom)) ()) + +(def-toolkit-request "XmSelectionBoxGetChild" selection-box-get-child :confirm + "Accesses a child component of a SelectionBox widget." + ((w widget) (child keyword)) (widget) + (widget-add-child w result) + (setf (widget-type result) :unknown)) + +(def-toolkit-request "XmFileSelectionBoxGetChild" file-selection-box-get-child + :confirm + "Accesses a child component of a FileSelectionBox widget." + ((w widget) (child keyword)) (widget) + (widget-add-child w result) + (setf (widget-type result) :unknown)) + +(def-toolkit-request "XmMessageBoxGetChild" message-box-get-child :confirm + "Accesses a child component of a MessageBox widget." + ((w widget) (child keyword)) (widget) + (widget-add-child w result) + (setf (widget-type result) :unknown)) + +(def-toolkit-request "XmCommandGetChild" command-get-child :confirm + "Accesses a child component of a Command widget." + ((w widget) (child keyword)) + (widget) + (widget-add-child w result) + (setf (widget-type result) :unknown)) + +(def-toolkit-request "XmScrolledWindowSetAreas" scrolled-window-set-areas + :no-confirm + "Adds or changes a window work region and a horizontal or vertical + ScrollBar widget to the ScrolledWindow widget." + ((widget widget) (horiz-scroll (or null widget)) + (vert-scroll (or null widget)) (work-region (or null widget))) + ()) + +(def-toolkit-request "XmTrackingLocate" tracking-locate :confirm + "Provides a modal interface for the selection of a component." + ((w widget) (cursor xlib:cursor) (confine-to (member t nil))) + (widget)) + +(def-toolkit-request "XmScrollBarGetValues" scroll-bar-get-values :confirm + "Returns the ScrollBar's increment values." + ((widget widget)) + (fixnum fixnum fixnum fixnum)) + +(def-toolkit-request "XmScrollBarSetValues" scroll-bar-set-values :no-confirm + "Changes the ScrollBar's increments values and the slider's size and + position." + ((widget widget) (value fixnum) (slider-size fixnum) + (increment fixnum) (page-increment fixnum) (notify (member t nil))) + ()) + +(def-toolkit-request "SetItems" set-items :no-confirm + "Set the items of a List widget." + ((widget widget) (items list :xm-string-table)) ()) + +(def-toolkit-request "GetItems" get-items :confirm + "Get the items of a List widget." + ((widget widget)) + (list)) + +(def-toolkit-request "ReturnTextCallbackDoit" return-text-callback-doit + :no-confirm + "Return a boolean value determining whether the proposed text action will + actually be performed." + ((doit (member t nil))) + ()) diff --git a/motif/lisp/string-base.lisp b/motif/lisp/string-base.lisp new file mode 100644 index 0000000000000000000000000000000000000000..cd0dd18b971640f2fc09ae3077481a71e804533e --- /dev/null +++ b/motif/lisp/string-base.lisp @@ -0,0 +1,336 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; This is the database of strings used for tokenizing communications +;;; between Lisp and C. +;;; + +(in-package "TOOLKIT-INTERNALS") + +;;; This table MUST be *SORTED*. +(setf *toolkit-string-table* + (vector + "accelerator" + "acceleratorText" + "accelerators" + "activateCallback" + "adjustLast" + "adjustMargin" + "alignment" + "allowResize" + "allowShellResize" + "ancestorSensitive" + "applyCallback" + "applyLabelString" + "armCallback" + "armColor" + "armPixmap" + "autoShowCursorPosition" + "automaticSelection" + "background" + "backgroundPixmap" + "bitmap" + "blinkRate" + "borderColor" + "borderPixmap" + "borderWidth" + "bottomAttachment" + "bottomOffset" + "bottomPosition" + "bottomShadowColor" + "bottomShadowPixmap" + "bottomWidget" + "browseSelectionCallback" + "buttonAcceleratorText" + "buttonAccelerators" + "buttonCount" + "buttonMnemonicCharSets" + "buttonMnemonics" + "buttonSet" + "buttonType" + "buttons" + "cancelButton" + "cancelCallback" + "cancelLabelString" + "cascadePixmap" + "cascadingCallback" + "children" + "clipWindow" + "colormap" + "columns" + "commandChangedCallback" + "commandEnteredCallback" + "commandWindow" + "commandWindowLocation" + "createPopupChildProc" + "cursorPosition" + "cursorPositionVisible" + "decrementCallback" + "defaultActionCallback" + "defaultButton" + "defaultButtonShadowThickness" + "defaultFontList" + "depth" + "destroyCallback" + "dialogTitle" + "disarmCallback" + "doubleClickInterval" + "dragCallback" + "editMode" + "editType" + "editable" + "entryAlignment" + "entryBorder" + "entryCallback" + "entryClass" + "exposeCallback" + "extendedSelectionCallback" + "file" + "fillOnArm" + "fillOnSelect" + "filterLabelString" + "focusCallback" + "font" + "fontList" + "forceBars" + "foreground" + "function" + "gainPrimaryCallback" + "height" + "helpCallback" + "helpLabelString" + "highlight" + "highlightColor" + "highlightOnEnter" + "highlightPixmap" + "highlightThickness" + "horizontalScrollBar" + "iconMask" + "iconName" + "iconPixmap" + "iconWindow" + "increment" + "incrementCallback" + "index" + "indicatorOn" + "indicatorSize" + "indicatorType" + "initialDelay" + "initialResourcesPersistent" + "innerHeight" + "innerWidth" + "innerWindow" + "inputCallback" + "inputCreate" + "insertPosition" + "internalHeight" + "internalWidth" + "isAligned" + "isHomogeneous" + "itemCount" + "items" + "jumpProc" + "justify" + "labelInsensitivePixmap" + "labelPixmap" + "labelString" + "labelType" + "leftAttachment" + "leftOffset" + "leftPosition" + "leftWidget" + "length" + "listLabelString" + "listMarginHeight" + "listMarginWidth" + "listSizePolicy" + "listSpacing" + "listUpdated" + "losePrimaryCallback" + "losingFocusCallback" + "lowerRight" + "mainWindowMarginHeight" + "mainWindowMarginWidth" + "mapCallback" + "mappedWhenManaged" + "mappingDelay" + "marginBottom" + "marginHeight" + "marginLeft" + "marginRight" + "marginTop" + "marginWidth" + "maxLength" + "maximum" + "menuAccelerator" + "menuBar" + "menuCursor" + "menuEntry" + "menuHelpWidget" + "menuHistory" + "menuPost" + "messageString" + "messageWindow" + "minimum" + "mnemonic" + "mnemonicCharSet" + "modifyVerifyCallback" + "motionVerifyCallback" + "multiClick" + "multipleSelectionCallback" + "name" + "navigationType" + "noMatchCallback" + "notify" + "numChildren" + "numColumns" + "okCallback" + "okLabelString" + "optionLabel" + "optionMnemonic" + "orientation" + "outputCreate" + "overrideRedirect" + "packing" + "pageDecrementCallback" + "pageIncrement" + "pageIncrementCallback" + "paneMaximum" + "paneMinimum" + "parameter" + "pendingDelete" + "popdownCallback" + "popupCallback" + "popupEnabled" + "postFromButton" + "postFromCount" + "postFromList" + "processingDirection" + "promptString" + "radioAlwaysOne" + "radioBehavior" + "recomputeSize" + "refigureMode" + "repeatDelay" + "resizable" + "resize" + "resizeCallback" + "resizeHeight" + "resizeWidth" + "reverseVideo" + "rightAttachment" + "rightOffset" + "rightPosition" + "rightWidget" + "rowColumnType" + "rows" + "sashHeight" + "sashIndent" + "sashShadowThickness" + "sashWidth" + "saveUnder" + "scaleMultiple" + "screen" + "scrollBarDisplayPolicy" + "scrollBarPlacement" + "scrollDCursor" + "scrollHCursor" + "scrollHorizontal" + "scrollLCursor" + "scrollLeftSide" + "scrollProc" + "scrollRCursor" + "scrollTopSide" + "scrollUCursor" + "scrollVCursor" + "scrollVertical" + "scrolledWindowMarginHeight" + "scrolledWindowMarginWidth" + "scrollingPolicy" + "selectColor" + "selectInsensitivePixmap" + "selectPixmap" + "selectThreshold" + "selectedItemCount" + "selectedItems" + "selection" + "selectionArray" + "selectionArrayCount" + "selectionLabelString" + "selectionPolicy" + "sensitive" + "separatorOn" + "set" + "shadow" + "shadowThickness" + "showArrows" + "showAsDefault" + "showSeparator" + "shown" + "simpleCallback" + "singleSelectionCallback" + "sizePolicy" + "skipAdjust" + "sliderSize" + "source" + "space" + "spacing" + "string" + "stringDirection" + "subMenuId" + "symbolPixmap" + "textOptions" + "textSink" + "textSource" + "thickness" + "thumb" + "thumbProc" + "title" + "titleString" + "toBottomCallback" + "toPositionCallback" + "toTopCallback" + "top" + "topAttachment" + "topItemPosition" + "topOffset" + "topPosition" + "topShadowColor" + "topShadowPixmap" + "topWidget" + "transient" + "translations" + "traversalOn" + "traversalType" + "troughColor" + "unitType" + "unmapCallback" + "unselectPixmap" + "update" + "updateSliderSize" + "useBottom" + "useRight" + "userData" + "value" + "valueChangedCallback" + "verifyBell" + "verticalScrollBar" + "visibleItemCount" + "visibleWhenOff" + "visualPolicy" + "whichButton" + "width" + "window" + "windowGroup" + "wordWrap" + "workWindow" + "x" + "y")) diff --git a/motif/lisp/transport.lisp b/motif/lisp/transport.lisp new file mode 100644 index 0000000000000000000000000000000000000000..01f708a7e0c6b2297ffde56a8a709594a22d17fd --- /dev/null +++ b/motif/lisp/transport.lisp @@ -0,0 +1,308 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; Code for transporting packets and messages between the C toolkit server +;;; and the Lisp client. +;;; + +(in-package "TOOLKIT-INTERNALS") + + + +;;;; Data structures + +(defconstant *header-size* 12) + +(defstruct (packet + (:print-function print-packet) + (:constructor make-packet (head))) + (head nil :type system:system-area-pointer) + (fill *header-size* :type fixnum) + (next nil :type (or null packet))) + +(defstruct (message + (:print-function print-message) + (:constructor %make-message)) + (packet-count 0 :type fixnum) + (serial (the fixnum 0) :type (unsigned-byte 32)) + (fill-packet nil :type (or null packet)) + ;; + ;; NOTE: This list contains the constituent packets in REVERSE order + ;; while the message is being constructed. When it is finished, the list + ;; is reversed. + (packet-list nil :type list)) + +(defun print-packet (p stream d) + (declare (ignore p d)) + (write-string "#<X Toolkit Packet>" stream)) + +(defun print-message (r stream d) + (declare (ignore d) + (stream stream)) + (format stream "#<X Toolkit Message - serial ~d>"(message-serial r))) + +(defconstant *packet-size* 4096) + +(deftype packet-index () `(integer 0 ,*packet-size*)) + + + +;;;; Memory management and packet accessors + +(defmacro packet-serial (packet) + `(the (signed-byte 29) (system:signed-sap-ref-32 (packet-head ,packet) 0))) + +(defmacro packet-sequence-number (packet) + `(system:signed-sap-ref-16 (packet-head ,packet) 4)) + +(defmacro packet-sequence-length (packet) + `(system:signed-sap-ref-16 (packet-head ,packet) 6)) + +(defmacro packet-length (packet) + `(the packet-index (system:signed-sap-ref-32 (packet-head ,packet) 8))) + + +;;; Free-list for keeping empty packet husks around. +(defvar *free-packets* nil) + +(defun create-packet () + (if *free-packets* + (let ((packet *free-packets*)) + (setf *free-packets* (packet-next packet)) + (setf (packet-length packet) *header-size*) + (setf (packet-fill packet) *header-size*) + packet) + (let* ((buffer (system:allocate-system-memory *packet-size*)) + (packet (make-packet buffer))) + (setf (packet-length packet) *header-size*) + packet))) + +(defun destroy-packet (packet) + (setf (packet-next packet) *free-packets*) + (setf *free-packets* packet)) + +(declaim (inline make-message)) +(defun make-message (serial) + (declare (type (unsigned-byte 29) serial)) + (let ((message (%make-message))) + (setf (message-serial message) serial) + message)) + + + + +;;;; Functions to stuff things into packets + +(macrolet ((def-packet-writer (name size) + (let ((sap-ref (ecase size + (1 'system:sap-ref-8) + (2 'system:sap-ref-16) + (4 'system:sap-ref-32))) + (bits (* size 8))) + `(defun ,name (packet data) + (declare (type (signed-byte ,bits) data)) + (let ((fill (system:sap+ (packet-head packet) + (packet-fill packet)))) + (setf (,sap-ref fill 0) data) + (incf (packet-fill packet) ,size) + (incf (packet-length packet) ,size))))) + (def-packet-reader (name size) + (let ((sap-ref (ecase size + (1 'system:sap-ref-8) + (2 'system:sap-ref-16) + (4 'system:sap-ref-32))) + (bits (* size 8))) + `(defun ,name (packet) + (let* ((fill (system:sap+ (packet-head packet) + (packet-fill packet))) + (data (,sap-ref fill 0))) + (declare (type (signed-byte ,bits) data)) + (incf (packet-fill packet) ,size) + data))))) + (def-packet-writer packet-put-byte 1) + (def-packet-writer packet-put-word 2) + (def-packet-writer packet-put-dblword 4) + + (def-packet-reader packet-get-byte 1) + (def-packet-reader packet-get-word 2) + (def-packet-reader packet-get-dblword 4)) + + + +;;;; Message management and accessors + +(defun create-message (serial) + (let ((message (make-message serial))) + (message-add-packet message) + message)) + +(defun destroy-message (message) + (dolist (packet (message-packet-list message)) + (destroy-packet packet))) + +(defun message-add-packet (message) + (let ((packet (create-packet))) + (push packet (message-packet-list message)) + (setf (message-fill-packet message) packet) + (incf (message-packet-count message)) + (setf (packet-sequence-number packet) (message-packet-count message)) + ;; PACKET-SEQUENCE-LENGTH will be set when the message is sent + (setf (packet-serial packet) (message-serial message)))) + + +(macrolet ((def-message-writer (name size) + (let ((packet-ref (ecase size + (1 'packet-put-byte) + (2 'packet-put-word) + (4 'packet-put-dblword))) + (bits (* size 8))) + `(defun ,name (message data) + (declare (type (signed-byte ,bits) data)) + (when (> (packet-length (message-fill-packet message)) + (- *packet-size* ,size 1)) + (message-add-packet message)) + (,packet-ref (message-fill-packet message) data)))) + (def-message-reader (name size) + (let ((packet-ref (ecase size + (1 'packet-get-byte) + (2 'packet-get-word) + (4 'packet-get-dblword)))) + `(defun ,name (message) + (unless (< (packet-fill (message-fill-packet message)) + (- *packet-size* ,size -1)) + ;; + ;; This is REALLY gross + (setf (message-fill-packet message) + (cadr (member (message-fill-packet message) + (message-packet-list message))))) + (,packet-ref (message-fill-packet message)))))) + + (def-message-writer message-put-byte 1) + (def-message-writer message-put-word 2) + (def-message-writer message-put-dblword 4) + + ;; These accessors should only be used in deciphering complete messages. + ;; Hence, it is assumed that the message IS complete (ie. the packets are + ;; in normal order). + (def-message-reader message-get-byte 1) + (def-message-reader message-get-word 2) + (def-message-reader message-get-dblword 4)) + + + +;;;; Transmission functions + +(defun read-some-bytes (socket packet count) + (declare (type packet-index count)) + (loop + (when (zerop count) (return)) + (multiple-value-bind + (bytes-read errnum) + (unix:unix-read socket (system:sap+ (packet-head packet) + (packet-fill packet)) count) + (declare (type (or null fixnum) bytes-read)) + (unless bytes-read + (toolkit-error "Encountered error reading packet: ~a" + (unix:get-unix-error-msg errnum))) + (when (zerop bytes-read) + (error 'toolkit-eof-error :string "Hit EOF while reading packet")) + (decf count (the fixnum bytes-read)) + (incf (packet-fill packet) (the fixnum bytes-read))))) + +(defun write-some-bytes (socket packet) + (let ((fill 0) + (count (packet-length packet))) + (declare (type packet-index fill count)) + (loop + (when (zerop count) (return)) + (multiple-value-bind + (bytes-sent errnum) + (unix:unix-write socket (system:sap+ (packet-head packet) fill) + 0 count) + (declare (type (or null fixnum) bytes-sent)) + (unless bytes-sent + (toolkit-error "Encountered error writing packet: ~a" + (unix:get-unix-error-msg errnum))) + (when (zerop (the fixnum bytes-sent)) + (error 'toolkit-eof-error :string "Hit EOF while sending packet.")) + (decf count (the fixnum bytes-sent)) + (incf fill (the fixnum bytes-sent)))))) + +(defun check-packet-sanity (packet) + (format t "Packet serial is ~a~%" (packet-serial packet)) + (format t "Packet current is ~a~%" (packet-sequence-number packet)) + (format t "Packet total is ~a~%" (packet-sequence-length packet)) + (format t "Packet length is ~a~%" (packet-length packet))) + +(declaim (inline transmit-packet receive-packet)) +(defun transmit-packet (packet socket) + (write-some-bytes socket packet )) + +(defun receive-packet (socket) + (let ((packet (create-packet))) + (setf (packet-fill packet) 0) + (read-some-bytes socket packet *header-size*) + (read-some-bytes socket packet (- (packet-length packet) *header-size*)) + (setf (packet-fill packet) *header-size*) + packet)) + +(defun transmit-message (message socket) + ;; First, reverse the packet list so that the packets go out in the right + ;; order + (setf (message-packet-list message) (nreverse (message-packet-list message))) + (let ((packet-count (message-packet-count message))) + (dolist (packet (message-packet-list message)) + (setf (packet-sequence-length packet) packet-count) + (transmit-packet packet socket)))) + +;;; An a-list of (serial . incomplete message) +(defvar *pending-msgs* nil) + +(defun kill-deferred-message (packet) + (declare (ignore packet)) + (warn "Cannot yet handle killing deferred messages.")) + +(defun defer-packet (packet) + (declare (ignore packet)) + (warn "Cannot yet handle deferring packets.")) + +(defun receive-message (socket) + (let* ((first (receive-packet socket)) + (count (packet-sequence-length first))) + (cond + ((zerop count) (kill-deferred-message first)) + ((= count 1) + (let ((message (make-message (packet-serial first)))) + (setf (message-packet-count message) 1) + (push first (message-packet-list message)) + (setf (message-fill-packet message) first) + message)) + (t + (defer-packet first))))) + + + +;;;; Functions for handling requests + +(defun create-next-message () + (let ((message (create-message (motif-connection-serial + *motif-connection*)))) + (incf (motif-connection-serial *motif-connection*)) + message)) + +(defun prepare-request (request-op options arg-count) + (declare (type (unsigned-byte 16) request-op) + (type (unsigned-byte 8) arg-count)) + (let ((message (create-next-message))) + (message-put-word message request-op) + (message-put-byte message (if (eq options :confirm) 1 0)) + (message-put-byte message arg-count) + message)) diff --git a/motif/lisp/widgets.lisp b/motif/lisp/widgets.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d3131944eaa65317aa14c373590939ee7acf5145 --- /dev/null +++ b/motif/lisp/widgets.lisp @@ -0,0 +1,235 @@ +;;;; -*- Mode: Lisp ; Package: Toolkit -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; These functions provide a nice interface to the underlying primitives +;;; for manipulating widgets. +;;; + +(in-package "TOOLKIT") + + + +;;;; Functions for dealing with widget resources + +;;; The resource list arguments are of the form: +;;; ( ... :<resource-name> <resource-value> ...) +;;; eg. (:label-string "Hello world") + +;;; This function takes a resource list and converts the resource symbols +;;; into their appropriate string names +(defun convert-resource-list (resources) + (when (cdr resources) + (setf (car resources) (symbol-resource (car resources))) + (convert-resource-list (cddr resources)))) + +(defun convert-resource-names (resources) + (when resources + (setf (car resources) (symbol-resource (car resources))) + (convert-resource-names (cdr resources)))) + +(declaim (inline set-values get-values)) +(defun set-values (widget &rest resources) + "Set the resource values of the specified widget." + (declare (type widget widget)) + (convert-resource-list resources) + (%set-values widget resources)) + +(defun get-values (widget &rest names) + "Access the resource values of the specified widget." + (declare (type widget widget)) + (convert-resource-names names) + (%get-values widget names)) + +(defmacro with-resource-values ((widget names bindings) &body forms) + `(progn + (convert-resource-names ,names) + (multiple-value-bind ,bindings + (values-list (%get-values ,widget ,names)) + ,@forms))) + + + +;;;; Functions for creating/destroying widgets + +(declaim (inline create-managed-widget create-widget create-application-shell + create-popup-shell destroy-widget)) +(defun create-managed-widget (name class parent &rest resources) + "Creates a new widget and automatically manages it." + (declare (simple-string name) + (keyword class) + (type widget parent)) + (convert-resource-list resources) + (%create-managed-widget name class parent resources)) + +(defun create-widget (name class parent &rest resources) + "Creates a new widget." + (declare (simple-string name) + (keyword class) + (type widget parent)) + (convert-resource-list resources) + (%create-widget name class parent resources)) + +(defun create-application-shell (&rest resources) + "Creates an application shell." + (convert-resource-list resources) + (%create-application-shell resources)) + +(defun create-popup-shell (name class parent &rest resources) + "Creates a popup shell." + (declare (simple-string name) + (keyword class) + (type widget parent)) + (convert-resource-list resources) + (%create-popup-shell name class parent resources)) + +(defun internal-destroy-widget (widget) + (declare (type widget widget)) + (let ((id (widget-id widget))) + ;; Destroy all storage for widget's children + (dolist (child (widget-children widget)) + (internal-destroy-widget child)) + ;; Remove widget's entry in the widget table + (remhash id (motif-connection-widget-table *motif-connection*)) + ;; Destroy all callback information + (dolist (cback-name (widget-callbacks widget)) + (remhash (cons id (symbol-resource cback-name)) + (motif-connection-callback-table *motif-connection*))) + ;; Destroy all protocol callback information + (dolist (entry (widget-protocols widget)) + (let ((prop (car entry)) + (proto (cdr entry))) + (remhash (list (widget-id widget) prop proto) + (motif-connection-protocol-table *motif-connection*)))) + ;; Destroy all event handler information + (dolist (event-class (widget-events widget)) + (remhash (cons (widget-id widget) event-class) + (motif-connection-event-table *motif-connection*))))) + +(defun destroy-widget (widget) + "Destroys the specified widget and all its descendents." + (declare (type widget widget)) + (let ((parent (widget-parent widget))) + (setf (widget-children parent) + (delete widget (widget-children parent)))) + (internal-destroy-widget widget) + (%destroy-widget widget)) + +(declaim (inline manage-children unmanage-children)) +(defun manage-children (&rest widgets) + "Manage multiple children of the same parent." + (%manage-children widgets)) + +(defun unmanage-children (&rest widgets) + "Unmanage multiple children of the same parent." + (%unmanage-children widgets)) + + + +;;;; Motif widget creation convenience functions + +(defvar *convenience-auto-manage* nil + "Controls whether widget convenience functions will automatically manage the + widgets which they create.") + +(eval-when (compile eval) + (defmacro def-widget-maker (class) + (let ((fn-name (read-from-string (format nil "CREATE-~a" class)))) + `(progn + (declaim (inline ,fn-name)) + (defun ,fn-name (parent name &rest resources) + ,(format nil "Creates a new ~a widget." class) + (declare (type widget parent) + (simple-string name)) + (convert-resource-list resources) + (if *convenience-auto-manage* + (%create-managed-widget name ,class parent resources) + (%create-widget name ,class parent resources)))))) + + (defmacro def-creation-wrapper (class) + (let ((fn-name (read-from-string (format nil "CREATE-~a" class))) + (other (read-from-string (format nil "%CREATE-~a" class)))) + `(progn + (declaim (inline ,fn-name)) + (defun ,fn-name (parent name &rest resources) + ,(format nil "Creates a new ~a widget." class) + (declare (type widget parent) + (simple-string name)) + (convert-resource-list resources) + (,other parent name resources))))) + ) ;; EVAL-WHEN + + +(def-widget-maker :arrow-button) +(def-widget-maker :arrow-button-gadget) +(def-widget-maker :bulletin-board) +(def-widget-maker :cascade-button) +(def-widget-maker :cascade-button-gadget) +(def-widget-maker :command) +(def-widget-maker :dialog-shell) +(def-widget-maker :drawing-area) +(def-widget-maker :drawn-button) +(def-widget-maker :file-selection-box) +(def-widget-maker :form) +(def-widget-maker :frame) +(def-widget-maker :label) +(def-widget-maker :label-gadget) +(def-widget-maker :list) +(def-widget-maker :main-window) +(def-widget-maker :menu-shell) +(def-widget-maker :message-box) +(def-widget-maker :paned-window) +(def-widget-maker :push-button) +(def-widget-maker :push-button-gadget) +(def-widget-maker :row-column) +(def-widget-maker :scale) +(def-widget-maker :scroll-bar) +(def-widget-maker :scrolled-window) +(def-widget-maker :selection-box) +(def-widget-maker :separator) +(def-widget-maker :separator-gadget) +(def-widget-maker :text) +(def-widget-maker :toggle-button) +(def-widget-maker :toggle-button-gadget) + + +(def-creation-wrapper :menu-bar) +(def-creation-wrapper :option-menu) +(def-creation-wrapper :radio-box) +(def-creation-wrapper :warning-dialog) +(def-creation-wrapper :bulletin-board-dialog) +(def-creation-wrapper :error-dialog) +(def-creation-wrapper :file-selection-dialog) +(def-creation-wrapper :form-dialog) +(def-creation-wrapper :information-dialog) +(def-creation-wrapper :message-dialog) +(def-creation-wrapper :popup-menu) +(def-creation-wrapper :prompt-dialog) +(def-creation-wrapper :pulldown-menu) +(def-creation-wrapper :question-dialog) +(def-creation-wrapper :scrolled-list) +(def-creation-wrapper :scrolled-text) +(def-creation-wrapper :selection-dialog) +(def-creation-wrapper :working-dialog) + + + +;;;; Misc. widget management functions + +(declaim (inline menu-position)) +(defun menu-position (widget event) + "Positions a popup menu according to the position in the given XEvent." + (declare (type widget widget) + (type (or (unsigned-byte 32) toolkit-event) event)) + + (%menu-position widget + (if (typep event 'toolkit-event) + (xti:event-handle event) + event))) diff --git a/motif/lisp/xt-types.lisp b/motif/lisp/xt-types.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a16e8bee9c74e4acb296473ff2e2731c5a6044db --- /dev/null +++ b/motif/lisp/xt-types.lisp @@ -0,0 +1,278 @@ +;;;; -*- Mode: Lisp, Fill ; Package: Toolkit -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;;; ********************************************************************** +;;; +;;; Written by Michael Garland +;;; +;;; This file defines the data types allowed in communication between the +;;; Lisp client and the C server. +;;; + +(in-package "TOOLKIT") + +(declaim (vector *class-table*)) +(declaim (simple-vector *type-table*)) + +(setf (fill-pointer *class-table*) 0) +(setf next-type-tag 0) + + + +;;;; Functions for defining data types + +;;; enumeration values will have a :enum-value on the symbol plist +(defun def-toolkit-enum (type values) + ;; Values begin at zero by default and increase by one each time + (let ((current 0) + (values-alist) + (main-value)) + (declare (fixnum current)) + (dolist (value values) + (setf main-value value) + (when (listp value) + (when (numberp (car value)) + (setf current (car value)) + (setf value (cdr value))) + (setf main-value (car value)) + (dolist (synonym (cdr value)) + (setf (get synonym :enum-value) current))) + (setf (get main-value :enum-value) current) + (push (cons current main-value) values-alist) + (incf current)) + (setf (gethash type *enum-table*) values-alist))) + +(defun def-toolkit-types (types) + (dolist (type types) + (let ((name (first type)) + (kind (second type))) + (setf (get name :xtk-type-tag) next-type-tag) + (when (eq kind :enum) (setf kind name)) + (setf (svref *type-table* next-type-tag) (cons name kind)) + (incf next-type-tag)))) + + + +;;;; Defining of widget classes + +(defun def-motif-classes (shells motif-shells classes) + (flet ((register-shell (name format-arg) + (setf (get name :widget-class) (fill-pointer *class-table*)) + (vector-push-extend + (cons name (format nil format-arg (symbol-resource name))) + *class-table*)) + (register-class (name format-arg) + (setf (get name :widget-class) (fill-pointer *class-table*)) + (vector-push-extend + (cons name (format nil format-arg (symbol-class name))) + *class-table*))) + (dolist (shell shells) + (register-shell shell "~aWidgetClass")) + (dolist (motif-shell motif-shells) + (register-class motif-shell "xm~aWidgetClass")) + (dolist (thing classes) + (let ((widget (first thing)) + (gadget (second thing))) + (register-class widget "xm~aWidgetClass") + (when gadget + (register-class gadget "xm~aClass")))))) + + + +;;;; Widget classes + +(def-motif-classes + ;; These are the generic Xt shell widget classes + '(:override-shell :transient-shell :top-level-shell :application-shell) + ;; + ;; These are specific Motif shell widget classes + '(:dialog-shell :menu-shell) + ;; + ;; These are the various other widget classes (all Motif) + '((:label :label-gadget) + (:arrow-button :arrow-button-gadget) + (:push-button :push-button-gadget) + (:toggle-button :toggle-button-gadget) + (:cascade-button :cascade-button-gadget) + (:separator :separator-gadget) + (:drawn-button) + (:menu-shell) + (:drawing-area) + (:dialog-shell) + (:bulletin-board) + (:command) + (:file-selection-box) + (:form) + (:message-box) + (:selection-box) + (:scroll-bar) + (:text) + (:text-field) + (:row-column) + (:scale) + (:frame) + (:list) + (:main-window) + (:scrolled-window) + (:paned-window))) + + + +;;;; Motif data types +;;; +;;; The types MUST be listed in alphabetical order +;;; + +(def-toolkit-types + '((:accelerator-table :accelerator-table) (:alignment :enum) + (:arrow-direction :enum) (:atom :atom) (:attachment :enum) + (:bitmap :xid) (:bool :boolean) (:boolean :boolean) (:callback-reason :enum) + (:cardinal :int) (:char :short) (:color :color) (:colormap :xid) + (:command-window-location :enum) (:cursor :xid) (:default-button-type :enum) + (:dialog-style :enum) (:dialog-type :enum) (:dimension :short) + (:edit-mode :enum) (:enum :enum) (:event :event) (:file-type-mask :enum) + (:float :float) (:font :xid) (:font-list :font-list) + (:function :function) (:grab-kind :enum) (:highlight-mode :enum) + (:indicator-type :enum) (:initial-state :int) (:int :int) + (:int-list :int-list) (:keyboard-focus-policy :enum) (:label-type :enum) + (:list-size-policy :enum) (:multi-click :enum) (:navigation-type :enum) + (:packing :enum) (:pixel :int) (:pixmap :xid) (:pointer :int) + (:position :short) (:processing-direction :enum) (:resize-policy :enum) + (:resource-list :resource-list) (:resource-names :resource-names) + (:row-column-type :enum) (:scroll-bar-display-policy :enum) + (:scroll-bar-placement :enum) (:scrolling-policy :enum) + (:selection-policy :enum) (:separator-type :enum) (:shadow-type :enum) + (:short :short) (:string :string) (:string-direction :enum) + (:string-table :string-table) (:string-token :string-token) + (:translation-table :translation-table) (:traversal-direction :enum) + (:unit-type :enum) (:unsigned-char :short) (:visual-policy :enum) + (:widget :widget) (:widget-class :widget-class) + (:widget-list :widget-list) (:window :xid) (:xm-string :xm-string) + (:xm-string-table :xm-string-table))) + +(def-toolkit-enum :arrow-direction + '(:arrow-up :arrow-down :arrow-left :arrow-right)) + +(def-toolkit-enum :shadow-type + '((5 :shadow-etched-in :etched-in) (:shadow-etched-out :etched-out) + (:shadow-in :in) (:shadow-out :out))) + +(def-toolkit-enum :alignment + '((:alignment-beginning :beginning) (:alignment-center :center) + (:alignment-end :end))) + +(def-toolkit-enum :attachment + '((:attach-none :none) :attach-form + (:attach-opposite-form :opposite-form) (:attach-widget :widget) + (:attach-opposite-widget :opposite-widget) (:attach-position :position) + (:attach-self :self))) + +(def-toolkit-enum :resize-policy + '((:resize-none :none) (:resize-grow :grow) (:resize-any :any))) + +(def-toolkit-enum :separator-type + '(:no-line :single-line :double-line :single-dashed-line + :double-dashed-line :shadow-etched-in :shadow-etched-out)) + +(def-toolkit-enum :keyboard-focus-policy + '(:explicit :pointer)) + +(def-toolkit-enum :row-column-type + '(:work-area :menu-bar :menu-pulldown :menu-popup :menu-option)) + +(def-toolkit-enum :orientation + '(:no-orientation :vertical :horizontal)) + +(def-toolkit-enum :grab-kind + '(:grab-none :grab-nonexclusive :grab-exclusive)) + +(def-toolkit-enum :edit-mode + '(:multi-line-edit :single-line-edit)) + +(def-toolkit-enum :callback-reason + '(:cr-none :cr-help :cr-value-changed :cr-increment :cr-decrement + :cr-page-increment :cr-page-decrement :cr-to-top :cr-to-bottom :cr-drag + :cr-activate :cr-arm :cr-disarm (16 :cr-map) :cr-unmap :cr-focus + :cr-losing-focus :cr-modifying-text-value :cr-moving-insert-cursor + :cr-execute :cr-single-select :cr-multiple-select :cr-extended-select + :cr-browse-select :cr-default-action :cr-clipboard-data-request + :cr-clipboard-data-delete :cr-cascading :cr-ok :cr-cancel (34 :cr-apply) + :cr-no-match :cr-command-entered :cr-command-changed :cr-expose + :cr-resize :cr-input :cr-gain-primary :cr-lose-primary :cr-create + (6666 :cr-protocols))) + +(def-toolkit-enum :default-button-type + '(:dialog-none :dialog-apply-button :dialog-cancel-button + :dialog-default-button :dialog-ok-button :dialog-filter-label + :dialog-filter-text :dialog-help-button + (:dialog-list :dialog-history-list :dialog-file-list) + (:dialog-list-label :dialog-file-list-label) :dialog-message-label + (:dialog-selection-label :dialog-prompt-label) :dialog-symbol-label + (:dialog-text :dialog-value-text :dialog-command-text) + :dialog-separator :dialog-dir-list :dialog-dir-list-label)) + +(def-toolkit-enum :dialog-style + '((:dialog-modeless :dialog-work-area) + (:dialog-primary-application-modal :dialog-application-modal) + (:dialog-full-application-modal) (:dialog-system-modal))) + +(def-toolkit-enum :dialog-type + '(:dialog-work-area + (:dialog-error :dialog-prompt) + (:dialog-information :dialog-selection) + (:dialog-message :dialog-command) + (:dialog-question :dialog-file-selection) + :dialog-warning :dialog-working)) + +(def-toolkit-enum :file-type-mask + '((1 :file-directory) :file-regular :file-any-type)) + +(def-toolkit-enum :command-window-location + '(:command-above-workspace :command-below-workspace)) + +(def-toolkit-enum :multi-click '(:multiclick-discard :multiclick-keep)) + +(def-toolkit-enum :navigation-type + '(:none :tab-group :sticky-tab-group :exclusive-tab-group)) + +(def-toolkit-enum :processing-direction + '(:max-on-top :max-on-bottom :max-on-left :max-on-right)) + +(def-toolkit-enum :list-size-policy '(:variable :constant :resize-if-possible)) + +(def-toolkit-enum :unit-type + '(:pixels :100th-millimeters :1000th-inches :100th-points :100th-font-units)) + +(def-toolkit-enum :indicator-type '((1 :n-of-many) :one-of-many)) + +(def-toolkit-enum :selection-policy + '(:single-select :multiple-select :extended-select :browse-select)) + +(def-toolkit-enum :string-direction + '(:string-direction-l-to-r :string-direction-r-to-l)) + +(def-toolkit-enum :scroll-bar-display-policy '(:static :as-needed)) + +(def-toolkit-enum :scroll-bar-placement + '(:bottom-right :top-right :bottom-left :top-left)) + +(def-toolkit-enum :scrolling-policy '(:automatic :application-defined)) + +(def-toolkit-enum :visual-policy '(:variable :constant)) + +(def-toolkit-enum :label-type '((1 :pixmap) :string)) + +(def-toolkit-enum :packing + '(:no-packing :pack-tight :pack-column :pack-none)) + +(def-toolkit-enum :traversal-direction + '(:traverse-current :traverse-next :traverse-next :traverse-prev + :traverse-home :traverse-next-tab-group :traverse-prev-tab-group + :traverse-up :traverse-down :traverse-left :traverse-right)) + +(def-toolkit-enum :highlight-mode + '(:highlight-normal :highlight-selected :highlight-secondary-selected))