From d979f621a8742ee93fa5603b7f2f3a0b028c08ad Mon Sep 17 00:00:00 2001 From: Richard M Kreuter Date: Thu, 23 Sep 2021 17:53:38 -0400 Subject: [PATCH] Restrict the usage of the (former) string table to resource names. Addresses bug #116. tl;dr all resource names are strings in `motifd`, but not all strings are resource names. To whatever degree it's useful to communicate resource names by index, use a different code path for that than for strings. Suggested bottom-up reading order: src/motif/lisp/string-base.lisp: change the Lisp-side global table into a table of symbols, and encapsulate that table in a couple interfaces for the rest of the system. src/motif/lisp/internals.lisp: remove the old string table variable & declare the interfaces from string-base.lisp as forward declarations for the rest of the system. src/motif/lisp/xt-types.lisp: add "toolkit type" name, :RESOURCE-NAME, and get rid of :STRING-TOKEN. src/motif/lisp/conversion.lisp: This is the heart of the matter. Add a case to TOOLKIT-WRITE-VALUE for :RESOURCE-NAME: resource names are written using MESSAGE-WRITE-RESOURCE-NAME. Change MESSAGE-WRITE-RESOURCE-LIST and MESSAGE-WRITE-RESOURCE-NAMES to call MESSAGE-WRITE-RESOURCE-NAME. Remove any "tokenization" from MESSAGE-WRITE-STRING. Add a case to TOOLKIT-READ-VALUE for :RESOURCE-NAME, & remove the case for :STRING-TOKEN. As far as Lisp is concerned above the level of this file's abstractions, there are only resource name symbols, no tokens, no strings. src/motif/server/global.h: add a custom "resource representation name" for resource names, ExtRResourceName; and a fake one for resource names' indices in the global table. Also kill the representation name for string tokens. src/motif/server/tables.h and src/motif/server/tables.c: add resource_name_tag, remove string_token_tag. Rename the string_table to resource_name_table. Remove tokenize_string (nobody needs it). src/motif/server/server.c: add resource_name_tag's initialization, remove string_token_tag. src/motif/server/datatrans.h and src/motif/server/datatrans.c: the counterparts of the changes in conversion.lisp. Add message_read_resource_name, and get toolkit_read_value to use it by supplying ExtRResourceName in message_read_resource_list and message_read_resource_names. Add error stub for writing resource names (nothing needs to write them back to Lisp). Remove "tokenizing" from the I/O path for strings. Get rid of the string_token I/O functions, but add a case in toolkit_read_value for the one code path where string_token was important (in callbacks.c, described below). src/motif/lisp/prototypes.lisp: now that there's a "toolkit type" of :RESOURCE-NAME, use it as an annotation in any DEF-TOOLKIT-REQUEST forms that need it. (%GET-VALUES and %SET-VALUES already used :RESOURCE-LIST and :RESOURCE-NAMES respectively, so the changes in conversion.lisp take care of those. src/motif/lisp/widgets.lisp: because conversion.lisp now knows how to turn resource name symbols into indices directly, CONVERT-RESOURCE-LIST and CONVERT-RESOURCE-NAMES, and any other runtime conversion of a resource name symbol into a string goes away. src/motif/lisp/callbacks.lisp: because conversion.lisp now knows how to turn resource name symbols into indices directly, runtime conversion of resource name symbols into strings goes away. (And so most of the lines of diff in this file are just renaming arguments from SYM-NAME to NAME, since there's no longer a non-symbol name.) src/motif/server/callbacks.c: this is the trickiest bit. (Context: when setting/removing/invoking callbacks, motifd uses the index of the callback list name, rather than the name itself, for the callback function's client_data. This is presumably an optimization: to avoid having to looking up a name when the callback gets invoked. This appears to have been the only reason the string_token "toolkit type" was present; since the uses of these indices is so contained, it seemed simplest to get rid of that type entirely.) In RXtAddCallback and RxtRemoveCallback, replace the use of the resource representation, ExtRStringToken, with ExtRResourceNameIndex, so that toolkit_read_value will return the index of a resource name sent from Lisp, rather than the resource name itself; and in CallbackHandler, bypass the toolkit_write/message_write layer, and instead tag and put the resource name index directly. src/motif/lisp/interface-build.lisp: use the interfaces added to string-base.lisp for building the C-side header file, which is now named ResourceNameTable.h. src/motif/server/GNUmakefile: change dependency from StringTable.h to ResourceNameTable.h. --- src/motif/lisp/callbacks.lisp | 29 +- src/motif/lisp/conversion.lisp | 89 ++-- src/motif/lisp/interface-build.lisp | 21 +- src/motif/lisp/internals.lisp | 8 +- src/motif/lisp/prototypes.lisp | 4 +- src/motif/lisp/string-base.lisp | 694 +++++++++++++++------------- src/motif/lisp/widgets.lisp | 23 +- src/motif/lisp/xt-types.lisp | 5 +- src/motif/server/GNUmakefile | 2 +- src/motif/server/callbacks.c | 28 +- src/motif/server/datatrans.c | 51 +- src/motif/server/datatrans.h | 4 +- src/motif/server/global.h | 7 +- src/motif/server/server.c | 2 +- src/motif/server/tables.c | 10 +- src/motif/server/tables.h | 5 +- 16 files changed, 523 insertions(+), 459 deletions(-) diff --git a/src/motif/lisp/callbacks.lisp b/src/motif/lisp/callbacks.lisp index 688a9c504..c3d9eac80 100644 --- a/src/motif/lisp/callbacks.lisp +++ b/src/motif/lisp/callbacks.lisp @@ -44,32 +44,30 @@ ;;; (widget-id . callback-name) ;;; The callback data is (fn . client-data) -(defun add-callback (widget sym-name fn &rest args) +(defun add-callback (widget 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*)) + (keyword name)) + (let* ((table (motif-connection-callback-table *motif-connection*)) (key (cons (widget-id widget) name)) (data (cons fn args))) - (unless (member sym-name (widget-callbacks widget)) + (unless (member name (widget-callbacks widget)) (%add-callback widget name) - (push sym-name (widget-callbacks widget))) + (push 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) +(defun remove-callback (widget 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*)) + (keyword name)) + (let* ((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))) @@ -78,19 +76,18 @@ (unless new-list (%remove-callback widget name) (setf (widget-callbacks widget) - (delete sym-name (widget-callbacks widget) :test #'eq))))) + (delete name (widget-callbacks widget) :test #'eq))))) -(defun remove-all-callbacks (widget sym-name) +(defun remove-all-callbacks (widget 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*)) + (keyword name)) + (let* ((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)))) + (delete name (widget-callbacks widget) :test #'eq)))) (defun handle-callback (reply) (unwind-protect diff --git a/src/motif/lisp/conversion.lisp b/src/motif/lisp/conversion.lisp index 8bfbe492b..f14ed6a54 100644 --- a/src/motif/lisp/conversion.lisp +++ b/src/motif/lisp/conversion.lisp @@ -95,6 +95,7 @@ (symbol (cond ((eq type :atom) (message-write-atom message value)) + ((eq type :resource-name) (message-write-resource-name 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)))) @@ -123,7 +124,9 @@ (:int (message-get-dblword message)) (:xid (get-xresource (message-get-dblword message) tag)) (:function (lookup-function data)) - (:string-token (svref *toolkit-string-table* data)) + ;; This happens in exactly one case: motifd's CallbackHandler() + ;; sends us the name of the callback list. + (:resource-name (lookup-resource-name data)) ((:resource-list :xm-string-table :string-table :int-list) (message-read-list message data)) (:widget-list (break "Shouldn't be reading WidgetList.")) @@ -220,40 +223,56 @@ (packet-get-byte packet)))) string))) +;; Only useful (if at all) for someone interested in hacking on CLM. +(defvar *warn-about-unregistered-resources* nil) + +(defun message-write-resource-name (message resource-name) + (declare (symbol resource-name)) + (let ((token-id (resource-name-id resource-name))) + (if token-id + (message-put-dblword message + (combine-type-and-data :resource-name token-id)) + ;; CLM has always implicitly transmitted the camelCase + ;; conversion of any symbol used in a resource name's position. + ;; In principle it might be nice if CLM had a more complete + ;; model of Xt/Motif classes, even if only to catch typos + ;; earlier than at runtime; that could make this branch go + ;; away. + (progn + (when *warn-about-unregistered-resources* + (warn "Writing Xt resource name ~S as a string." resource-name)) + (message-write-string message (symbol-resource resource-name)))))) + (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 - (do ((next 0) - (len (min length (- *packet-size* (packet-length packet))) - (min length (- *packet-size* (packet-length packet))))) - ((not (plusp length))) - (packet-write-string packet string next len) - (incf next len) - (decf length len) - (when (plusp length) - (message-add-packet message) - (setf packet (message-fill-packet message)))))) - (let ((pad (- 4 (mod (packet-fill packet) 4)))) - (unless (> pad 3) - (dotimes (i pad) - (packet-put-byte packet 0))))))))) + (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 + (do ((next 0) + (len (min length (- *packet-size* (packet-length packet))) + (min length (- *packet-size* (packet-length packet))))) + ((not (plusp length))) + (packet-write-string packet string next len) + (incf next len) + (decf length len) + (when (plusp length) + (message-add-packet message) + (setf packet (message-fill-packet message)))))) + (let ((pad (- 4 (mod (packet-fill packet) 4)))) + (unless (> pad 3) + (dotimes (i pad) + (packet-put-byte packet 0))))))) @@ -340,7 +359,7 @@ (message-put-dblword message (combine-type-and-data :resource-names length)) (dolist (name list) - (message-write-string message name)))) + (message-write-resource-name message name)))) (defun message-write-resource-list (message list) (declare (list list)) @@ -353,7 +372,7 @@ (let ((name (first list)) (value (second list)) (rest (cddr list))) - (message-write-string message name) + (message-write-resource-name message name) (toolkit-write-value message value) (unless rest (return)) (setf list rest))))) diff --git a/src/motif/lisp/interface-build.lisp b/src/motif/lisp/interface-build.lisp index 6497b8b59..4fcbbcd7a 100644 --- a/src/motif/lisp/interface-build.lisp +++ b/src/motif/lisp/interface-build.lisp @@ -23,7 +23,7 @@ ;;;; Files where interface information will be stored -(defconstant *string-table-file* "target:motif/server/StringTable.h") +(defconstant *resource-name-table-file* "target:motif/server/ResourceNameTable.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") @@ -71,15 +71,16 @@ (format out " ~a,~%" (aref *request-table* index))) (format out " NULL~%};~%")) -(defun build-string-table (out) +(defun build-resource-name-table (out) (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))) + (let ((initial-resources-count 0)) + (write-line "String resource_name_table[] = {" out) + (xti::map-resource-names + (lambda (resource-name) + (format out " XmN~a,~%" (symbol-resource resource-name)) + (incf initial-resources-count))) (format out " NULL~%};~%~%") - (format out "#define STRING_TABLE_SIZE ~a~%" (length table)))) + (format out "#define RESOURCE_NAME_TABLE_SIZE ~a~%" initial-resources-count))) (defun build-toolkit-interface () (with-open-file (out *class-file* @@ -94,7 +95,7 @@ :direction :output :if-exists :supersede :if-does-not-exist :create) (build-interface-file out)) - (with-open-file (out *string-table-file* + (with-open-file (out *resource-name-table-file* :direction :output :if-exists :supersede :if-does-not-exist :create) - (build-string-table out))) + (build-resource-name-table out))) diff --git a/src/motif/lisp/internals.lisp b/src/motif/lisp/internals.lisp index f80eecb02..49d799e50 100644 --- a/src/motif/lisp/internals.lisp +++ b/src/motif/lisp/internals.lisp @@ -172,9 +172,6 @@ ;;;; 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*)) @@ -219,3 +216,8 @@ (declare (type widget parent child)) (setf (widget-parent child) parent) (push child (widget-children parent))) + +;; These all get defined in string-base.lisp. +(declaim (ftype (function ((unsigned-byte 24)) symbol) lookup-resource-name) + (ftype (function (symbol) (or null (unsigned-byte 24))) + resource-name-id)) diff --git a/src/motif/lisp/prototypes.lisp b/src/motif/lisp/prototypes.lisp index fb084005b..65eecdd14 100644 --- a/src/motif/lisp/prototypes.lisp +++ b/src/motif/lisp/prototypes.lisp @@ -155,11 +155,11 @@ (def-toolkit-request "XtAddCallback" %add-callback :no-confirm "" - ((widget widget) (name simple-string)) ()) + ((widget widget) (name keyword :resource-name)) ()) (def-toolkit-request "XtRemoveCallback" %remove-callback :no-confirm "" - ((widget widget) (name simple-string)) ()) + ((widget widget) (name keyword :resource-name)) ()) (def-toolkit-request "XtSetValues" %set-values :no-confirm "" diff --git a/src/motif/lisp/string-base.lisp b/src/motif/lisp/string-base.lisp index 7e3cf2c0f..2cd6122c3 100644 --- a/src/motif/lisp/string-base.lisp +++ b/src/motif/lisp/string-base.lisp @@ -9,330 +9,380 @@ ;;; ;;; ********************************************************************** ;;; -;;; Written by Michael Garland +;;; Originally written by Michael Garland. ;;; -;;; This is the database of strings used for tokenizing communications -;;; between Lisp and C. +;;; This is the database of resource names 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")) +;; Here are the resources (i.e., slots) the in all the Xt & Motif +;; classes CLM supports. Nothing outside this file should ever +;; reference this variable or its value. (Eventually we ought to add a +;; defining form for Xt classes that can incrementally build up the +;; resource name database, possibly using some other kind of data +;; structure.). Note that the ordering of this table doesn't matter, +;; but it should not contain any duplicates. +(defvar %*resource-names* + (let* ((initial-resources + '(:accelerator + :accelerator-text + :accelerators + :activate-callback + :adjust-last + :adjust-margin + :alignment + :allow-resize + :allow-shell-resize + :ancestor-sensitive + :apply-callback + :apply-label-string + :arm-callback + :arm-color + :arm-pixmap + :auto-show-cursor-position + :auto-unmanage + :automatic-selection + :background + :background-pixmap + :bitmap + :blink-rate + :border-color + :border-pixmap + :border-width + :bottom-attachment + :bottom-offset + :bottom-position + :bottom-shadow-color + :bottom-shadow-pixmap + :bottom-widget + :browse-selection-callback + :button-accelerator-text + :button-accelerators + :button-count + :button-mnemonic-char-sets + :button-mnemonics + :button-set + :button-type + :buttons + :cancel-button + :cancel-callback + :cancel-label-string + :cascade-pixmap + :cascading-callback + :children + :clip-window + :colormap + :columns + :command-changed-callback + :command-entered-callback + :command-window + :command-window-location + :create-popup-child-proc + :cursor-position + :cursor-position-visible + :decrement-callback + :default-action-callback + :default-button + :default-button-shadow-thickness + :default-font-list + :depth + :destroy-callback + :dialog-title + :disarm-callback + :double-click-interval + :drag-callback + :edit-mode + :edit-type + :editable + :entry-alignment + :entry-border + :entry-callback + :entry-class + :expose-callback + :extended-selection-callback + :file + :fill-on-arm + :fill-on-select + :filter-label-string + :focus-callback + :font + :font-list + :force-bars + :foreground + :function + :gain-primary-callback + :height + :help-callback + :help-label-string + :highlight + :highlight-color + :highlight-on-enter + :highlight-pixmap + :highlight-thickness + :horizontal-scroll-bar + :icon-mask + :icon-name + :icon-pixmap + :icon-window + :increment + :increment-callback + :index + :indicator-on + :indicator-size + :indicator-type + :initial-delay + :initial-resources-persistent + :inner-height + :inner-width + :inner-window + :input-callback + :input-create + :insert-position + :internal-height + :internal-width + :is-aligned + :is-homogeneous + :item-count + :items + :jump-proc + :justify + :keyboard-focus-policy + :label-insensitive-pixmap + :label-pixmap + :label-string + :label-type + :left-attachment + :left-offset + :left-position + :left-widget + :length + :list-label-string + :list-margin-height + :list-margin-width + :list-size-policy + :list-spacing + :list-updated + :lose-primary-callback + :losing-focus-callback + :lower-right + :main-window-margin-height + :main-window-margin-width + :map-callback + :mapped-when-managed + :mapping-delay + :margin-bottom + :margin-height + :margin-left + :margin-right + :margin-top + :margin-width + :max-length + :maximum + :menu-accelerator + :menu-bar + :menu-cursor + :menu-entry + :menu-help-widget + :menu-history + :menu-post + :message-string + :message-window + :minimum + :mnemonic + :mnemonic-char-set + :modify-verify-callback + :motion-verify-callback + :multi-click + :multiple-selection-callback + :name + :navigation-type + :no-match-callback + :notify + :num-children + :num-columns + :ok-callback + :ok-label-string + :option-label + :option-mnemonic + :orientation + :output-create + :override-redirect + :packing + :page-decrement-callback + :page-increment + :page-increment-callback + :pane-maximum + :pane-minimum + :parameter + :pending-delete + :popdown-callback + :popup-callback + :popup-enabled + :post-from-button + :post-from-count + :post-from-list + :processing-direction + :prompt-string + :radio-always-one + :radio-behavior + :recompute-size + :refigure-mode + :repeat-delay + :resizable + :resize + :resize-callback + :resize-height + :resize-width + :reverse-video + :right-attachment + :right-offset + :right-position + :right-widget + :row-column-type + :rows + :sash-height + :sash-indent + :sash-shadow-thickness + :sash-width + :save-under + :scale-multiple + :screen + :scroll-bar-display-policy + :scroll-bar-placement + :scroll-d-cursor + :scroll-h-cursor + :scroll-horizontal + :scroll-l-cursor + :scroll-left-side + :scroll-proc + :scroll-r-cursor + :scroll-top-side + :scroll-u-cursor + :scroll-v-cursor + :scroll-vertical + :scrolled-window-margin-height + :scrolled-window-margin-width + :scrolling-policy + :select-color + :select-insensitive-pixmap + :select-pixmap + :select-threshold + :selected-item-count + :selected-items + :selection + :selection-array + :selection-array-count + :selection-label-string + :selection-policy + :sensitive + :separator-on + :set + :shadow + :shadow-thickness + :show-arrows + :show-as-default + :show-separator + :shown + :simple-callback + :single-selection-callback + :size-policy + :skip-adjust + :slider-size + :source + :space + :spacing + :string + :string-direction + :sub-menu-id + :symbol-pixmap + :text-options + :text-sink + :text-source + :thickness + :thumb + :thumb-proc + :title + :title-string + :to-bottom-callback + :to-position-callback + :to-top-callback + :top + :top-attachment + :top-item-position + :top-offset + :top-position + :top-shadow-color + :top-shadow-pixmap + :top-widget + :transient + :translations + :traversal-on + :traversal-type + :trough-color + :unit-type + :unmap-callback + :unselect-pixmap + :update + :update-slider-size + :use-bottom + :use-right + :user-data + :value + :value-changed-callback + :verify-bell + :vertical-scroll-bar + :visible-item-count + :visible-when-off + :visual-policy + :which-button + :width + :window + :window-group + :word-wrap + :work-window + :x + :y)) + (initial-resources-count (length initial-resources))) + (make-array initial-resources-count + :fill-pointer initial-resources-count + :initial-contents initial-resources + :element-type 'keyword))) + +;; The most common use of resource names is to transmit their index +;; values in motifd's resource_name_table. The (internal) +;; interface for getting the index value is RESOURCE-NAME-ID. for now +;; we'll just use the symbol's plist, but perhaps this should be a +;; hash table some day. +(defconstant +resource-name-id-property+ 'resource-name-id) + +(defun resource-name-id (resource-name) + (get resource-name +resource-name-id-property+)) + +;; Encapsulate the representation of the set of resource names. This +;; only gets used during callback invocation, and so could possibly go +;; away as a global function some day (e.g., callback handling could +;; look up the resource name in the widget handling the callback). +(defun lookup-resource-name (integer) + (elt %*resource-names* integer)) + +;; Encapsulate the representation & iteration of the set of resource +;; names. interface-build.lisp uses this to generate +;; ResourceNameTable.h. This isn't expected to be needed anywhere +;; else, or at runtime. +(defun map-resource-names (function) + "Apply FUNCTION to all defined resource name keywords in an +unspecified order." + (map nil function %*resource-names*)) + +;; Nothing outside this file should ever need this. +(defun (setf resource-name-id) (id resource-name) + (setf (get resource-name +resource-name-id-property+) id)) + +;; Allocate index numbers to all known resource names. +(let ((id 0)) + (map-resource-names + (lambda (resource-name) + (setf (resource-name-id resource-name) id) + (incf id)))) diff --git a/src/motif/lisp/widgets.lisp b/src/motif/lisp/widgets.lisp index f125a2b3e..880a3bdfc 100644 --- a/src/motif/lisp/widgets.lisp +++ b/src/motif/lisp/widgets.lisp @@ -25,34 +25,19 @@ ;;; ( ... : ...) ;;; 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))) @@ -68,7 +53,6 @@ (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) @@ -76,12 +60,10 @@ (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) @@ -89,7 +71,6 @@ (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) @@ -102,7 +83,7 @@ (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)) + (remhash (cons id cback-name) (motif-connection-callback-table *motif-connection*))) ;; Destroy all protocol callback information (dolist (entry (widget-protocols widget)) @@ -152,7 +133,6 @@ ,(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)))))) @@ -166,7 +146,6 @@ ,(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 diff --git a/src/motif/lisp/xt-types.lisp b/src/motif/lisp/xt-types.lisp index 3e151e0f3..e7b4ece6d 100644 --- a/src/motif/lisp/xt-types.lisp +++ b/src/motif/lisp/xt-types.lisp @@ -149,14 +149,15 @@ (: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) + (:resource-list :resource-list) + (:resource-name :resource-name) (: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) (:shell-horiz-dim :short) (:shell-horiz-pos :short) (:shell-vert-dim :short) (:shell-vert-pos :short) (:short :short) (:string :string) (:string-direction :enum) - (:string-table :string-table) (:string-token :string-token) + (:string-table :string-table) (:translation-table :translation-table) (:traversal-direction :enum) (:unit-type :enum) (:unsigned-char :short) (:vertical-dimension :short) (:vertical-int :int) diff --git a/src/motif/server/GNUmakefile b/src/motif/server/GNUmakefile index 1ffc86fdd..3b167336f 100644 --- a/src/motif/server/GNUmakefile +++ b/src/motif/server/GNUmakefile @@ -12,7 +12,7 @@ include Config $(TARGET) : $(OBJS) $(CC) -o $(TARGET) $(LDFLAGS) $(OBJS) $(LIBS) -tables.o : tables.c StringTable.h ClassTable.h TypeTable.h +tables.o : tables.c ResourceNameTable.h ClassTable.h TypeTable.h $(CC) $(CFLAGS) -c $< requests.o : requests.c Interface.h diff --git a/src/motif/server/callbacks.c b/src/motif/server/callbacks.c index 90f466842..eaa198be8 100644 --- a/src/motif/server/callbacks.c +++ b/src/motif/server/callbacks.c @@ -79,24 +79,32 @@ void RXtAddCallback(message_t message) { Widget w; String callback_name; - int name_token; + long name_token = 0; toolkit_read_value(message,&w,XtRWidget); - toolkit_read_value(message,&name_token,ExtRStringToken); - - callback_name = string_table[name_token]; + /* Note that ExtRResourceNameIndex isn't the name of an entry in + type_table; it's special-cased in toolkit_read_value. (In effect, + ExtRResourceNameIndex is a "pointer type" for ExtRResourceName.) + Using the index is an optimization: by saving the index as the + callback's client_data, rather than the string, there's no need + to look up the string when the callback is + invoked. RXtRemoveCallback, CallbackHandler are the only other + participants in this convention. */ + toolkit_read_value(message,&name_token,ExtRResourceNameIndex); + callback_name = resource_name_table[name_token]; XtAddCallback(w,callback_name,CallbackHandler,(caddr_t)name_token); } void RXtRemoveCallback(message_t message) { Widget w; - int name_token; + long name_token = 0; toolkit_read_value(message,&w,XtRWidget); - toolkit_read_value(message,&name_token,ExtRStringToken); + /* See the note about ExtRResourceNameIndex above. */ + toolkit_read_value(message,&name_token,ExtRResourceNameIndex); - XtRemoveCallback(w,string_table[name_token], + XtRemoveCallback(w,resource_name_table[name_token], CallbackHandler,(caddr_t)name_token); } @@ -270,7 +278,11 @@ void CallbackHandler(Widget *w, int name_token, XmAnyCallbackStruct *info) message_put_dblword(reply,CALLBACK_REPLY); message_write_widget(reply,*w,widget_tag); - message_write_string_token(reply,name_token,string_token_tag); + /* As this is the only place where we mean to write tagged resource + name index, it seemed pointless to have a separate + message_write_ function in another file for the purpose. */ + message_put_dblword(reply, + combine_type_and_data(resource_name_tag,name_token)); /* Now, we write the Reason structure into the message */ message_write_enum(reply,info?info->reason:0,callback_reason_tag); diff --git a/src/motif/server/datatrans.c b/src/motif/server/datatrans.c index e9f960eba..74d846b9a 100644 --- a/src/motif/server/datatrans.c +++ b/src/motif/server/datatrans.c @@ -33,11 +33,6 @@ void packet_write_string(packet_t packet,String string,int count) packet->length += count; } -void message_write_string_token(message_t message,int token,int tag) -{ - message_put_dblword(message,combine_type_and_data(tag,token)); -} - void really_write_string(message_t message,String string,int length) { int pad,i; @@ -63,15 +58,15 @@ void really_write_string(message_t message,String string,int length) packet_put_byte(packet,0); } +void message_write_resource_name(message_t message,String string,int type_tag) +{ + fprintf(stderr,">>>>> Warning:write_resource_name:We shouldn't be here!\n"); + fflush(stderr); +} void message_write_string(message_t message,String string,int type_tag) { - long token = tokenize_string(string); - - if( token >= 0 ) - message_put_dblword(message,combine_type_and_data(string_token_tag,token)); - else - really_write_string(message,string,strlen(string)+1); + really_write_string(message,string,strlen(string)+1); } void message_write_short(message_t message,int value,int type_tag) @@ -186,6 +181,9 @@ void message_write_resource_list(message_t message,ResourceList *list,int tag) fatal_error("Bad size."); break; } + /* This turns out to be the only caller of toolkit_write_value. + (Would it be clearer either to rename toolkit_write_value + to write_resource_value, or something?) */ toolkit_write_value(message,val,type); if( !strcmp(type,XmRXmString) ) /* All XmString's returned as resource values are garbage */ @@ -323,17 +321,14 @@ String really_read_string(message_t message,int length) return string; } -void message_read_string_token(message_t message,int *t,int tag,int data) +void message_read_resource_name(message_t message,String *s,int tag,int data) { - *t = data; + *s = resource_name_table[data]; } void message_read_string(message_t message,String *s,int tag,int data) { - if( tag == string_token_tag ) - *s = string_table[data]; - else - *s = really_read_string(message,data); + *s = really_read_string(message,data); } void message_read_xm_string(message_t message,XmString *xs,int tag,int data) @@ -415,7 +410,7 @@ void message_read_resource_names(message_t message,ResourceList *list, register_garbage(data,GarbageData); for(i=0;iargs[i].name,XtRString); + toolkit_read_value(message,&list->args[i].name,ExtRResourceName); list->args[i].value = (long)&data[i]; } } else list->args = NULL; @@ -436,7 +431,7 @@ void message_read_resource_list(message_t message,ResourceList *list, list->args = (ArgList)XtMalloc(length*sizeof(Arg)); register_garbage(list->args,GarbageData); for(i=0;iparent,name); if( !type ) warn_bogus_resource(name); @@ -557,11 +552,21 @@ void toolkit_read_value(message_t message,char *dest,String type) data &= 0x00ffffff; read_value = type_table[tag].reader; - if((tag == string_tag || tag == string_token_tag) && - !strcmp(type,XmRXmString)) + /* The CLM Lisp API says that anyplace Motif uses an XmString, a + Lisp string is to be interpreted as an XmString having the + default rendition (nee charset) tag. But Lisp doesn't know when + Motif needs XmStrings, so this implements the intended + polymorphism. */ + if((tag == string_tag) && !strcmp(type,XmRXmString)) read_value = (type_reader)message_read_xm_string; - else if( tag == string_token_tag && !strcmp(type,XtRString) ) - read_value = (type_reader)message_read_string; + /* The type value, ExtRResourceNameIndex, is an instruction from the + caller to return a resource name's index in the resource name + table rather than the resource name itself. Callback + installation & removal are currently the only user of this value. */ + if((tag == resource_name_tag) && !strcmp(type, ExtRResourceNameIndex)) { + *dest = data; + return; + } (*read_value)(message,dest,tag,data); } diff --git a/src/motif/server/datatrans.h b/src/motif/server/datatrans.h index 7411a1751..7ada40b07 100644 --- a/src/motif/server/datatrans.h +++ b/src/motif/server/datatrans.h @@ -14,6 +14,7 @@ #define combine_type_and_data(type,data) ((type<<24)|data) +extern void message_write_resource_name(); extern void message_write_string(); extern void message_write_widget(); extern void message_write_widget_class(); @@ -23,7 +24,6 @@ extern void message_write_boolean(); extern void message_write_int(); extern void message_write_xid(); extern void message_write_atom(); -extern void message_write_string_token(); extern void message_write_resource_list(); extern void message_write_xm_string(); extern void message_write_enum(); @@ -42,6 +42,7 @@ extern void message_write_float(message_t,float,int); +extern void message_read_resource_name(); extern void message_read_string(); extern void message_read_widget(); extern void message_read_widget_class(); @@ -51,7 +52,6 @@ extern void message_read_short(); extern void message_read_boolean(); extern void message_read_xid(); extern void message_read_atom(); -extern void message_read_string_token(); extern void message_read_resource_list(); extern void message_read_xm_string(); extern void message_read_enum(); diff --git a/src/motif/server/global.h b/src/motif/server/global.h index 757a533b4..9f5bdd567 100644 --- a/src/motif/server/global.h +++ b/src/motif/server/global.h @@ -11,7 +11,12 @@ #define HEADER_LENGTH 12 #define ExtRResourceList "ResourceList" -#define ExtRStringToken "StringToken" +#define ExtRResourceName "ResourceName" +/* Note: this name exists to tell toolkit_read_value to return a + resource name index verbatim, as distinct from the resource name + itself. It does not correspond to a type in the type_table, so has + no tag. The callback part of the wire protocol uses this. */ +#define ExtRResourceNameIndex "ResourceNameIndex" #define ExtRGrabKind "GrabKind" #define ExtRResourceNames "ResourceNames" #define ExtRCallbackReason "CallbackReason" diff --git a/src/motif/server/server.c b/src/motif/server/server.c index fe0b22488..df45718fa 100644 --- a/src/motif/server/server.c +++ b/src/motif/server/server.c @@ -158,7 +158,7 @@ void serve_client(int socket) LispAction.proc = LispActionProc; XtAppAddActions(app_context, &LispAction, 1); - string_token_tag = find_type_entry(ExtRStringToken); + resource_name_tag = find_type_entry(ExtRResourceName); string_tag = find_type_entry(XtRString); xm_string_tag = find_type_entry(XmRXmString); enum_tag = find_type_entry(XtREnum); diff --git a/src/motif/server/tables.c b/src/motif/server/tables.c index 2168989bd..558f135e8 100644 --- a/src/motif/server/tables.c +++ b/src/motif/server/tables.c @@ -37,7 +37,7 @@ extern WidgetClass xmLabelWidgetClass,xmLabelGadgetClass, xmScaleWidgetClass, xmFrameWidgetClass, xmListWidgetClass, xmMainWindowWidgetClass,xmScrolledWindowWidgetClass,xmPanedWindowWidgetClass; -#include "StringTable.h" +#include "ResourceNameTable.h" #include "ClassTable.h" #include "TypeTable.h" @@ -51,7 +51,7 @@ typedef struct { } class_resources; class_resources resource_table[CLASS_TABLE_SIZE]; -int string_token_tag,string_tag,xm_string_tag,enum_tag; +int resource_name_tag,string_tag,xm_string_tag,enum_tag; int int_tag,window_tag,boolean_tag,widget_tag,function_tag; int callback_reason_tag,event_tag,resource_list_tag; int translation_table_tag,accelerator_table_tag; @@ -244,12 +244,6 @@ String query_resource_type(int classid,Widget parent,String resource) else return constraints[result].type; } -long tokenize_string(String string) -{ - return binary_search((char *)string_table,STRING_TABLE_SIZE,sizeof(char *), - string,string_pred); -} - long find_type_entry(String type) { return binary_search((char *)type_table,TYPE_TABLE_SIZE,sizeof(type_entry), diff --git a/src/motif/server/tables.h b/src/motif/server/tables.h index 50678a9a6..43de4de58 100644 --- a/src/motif/server/tables.h +++ b/src/motif/server/tables.h @@ -20,12 +20,12 @@ typedef struct { int size; } type_entry; -extern String string_table[]; +extern String resource_name_table[]; extern WidgetClass *class_table[]; extern type_entry type_table[]; /* These are precomputed */ -extern int string_token_tag,string_tag,xm_string_tag,enum_tag; +extern int resource_name_tag,string_tag,xm_string_tag,enum_tag; extern int int_tag,window_tag,boolean_tag,widget_tag,function_tag; extern int callback_reason_tag,event_tag,resource_list_tag; extern int translation_table_tag,accelerator_table_tag; @@ -33,7 +33,6 @@ extern int atom_tag,font_list_tag,string_table_tag,xm_string_table_tag; extern int int_list_tag,cursor_tag; extern long binary_search(char *tbl,int len,int size,char *t,int (*p)()); -extern long tokenize_string(String s); extern long find_type_entry(String type); extern long find_widget_class_id(WidgetClass class); extern String query_resource_type(int classid,Widget Parent,String rsrc); -- GitLab