diff --git a/src/motif/lisp/callbacks.lisp b/src/motif/lisp/callbacks.lisp index 688a9c504324791085e01f60625a226bf020b250..c3d9eac80a6b99ff3575a99182aa055522e77d4a 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 8bfbe492b64879ec7679fa6b9654c9506d08d833..f14ed6a541a0e570667a7b58c22a878bde141b14 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 6497b8b5938ea8e19a4632e547019d1a2d28e1e7..4fcbbcd7a36daa31edd07ac092910dd01aefe891 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 f80eecb02a4c4339b4019a41005b98a54caa5c0e..49d799e50fa691f321a484aa4ea3842e7f145758 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 fb084005b70522e577377d431dfe4ebc2cab5886..65eecdd143cd107dfad04349bb9f7fa7e700ec86 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 7e3cf2c0f2900f7b18486a4824f4ec1df21c60d6..2cd6122c3d4c10d704aa15fe8f5d44820e214a07 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 f125a2b3ed7b19c2333a1cb9b3820fc51334fad2..880a3bdfcc4d2ce4261191317db61585621b8c07 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 3e151e0f320d88308e37a5c11f133a66c0dd7232..e7b4ece6d393e1b060f20517a6626bbf1eadd00a 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 1ffc86fdd7409a67ac65ccb2a9ef929aae4a2b06..3b167336faa9bdfab977191a1a644f45a01f4b64 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 90f466842faa6e2657e40ad61f961a7685eacad5..eaa198be8a4bf82fad656fbcb70bef848d329fa6 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 e9f960ebae56053e1ba93bdc32fee9d9989ee4ee..74d846b9a33a66adeda6265fe70dcbbcdac70bdd 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 7411a1751b1404736e37928c6e819595bf8933cc..7ada40b07baede6534563ea9754e0f2e8653bd1e 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 757a533b4280c23e8a342d79b35cd1c6576a56af..9f5bdd5673ab8cd27340a373027a5eaa45e5924d 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 fe0b22488ce38a359cd93bef8ccd44ea942102f7..df45718fa1a98a6f22c06b355efaca779dfaa75b 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 2168989bdd64ffa3b27bc05dc434cf4c0a8b27ed..558f135e8623821f421bd872a8628e1a9fda4a8d 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 50678a9a6bdd92b35b44ee589b533fb4ba773db4..43de4de58ce84ffc386d2b4ac2ab2e8f14de7556 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);