Commit d979f621 authored by Richard M Kreuter's avatar Richard M Kreuter
Browse files

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.
parent 2e3b90ff
Pipeline #4842 canceled with stages
in 0 seconds
......@@ -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
......
......@@ -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)))))
......
......@@ -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)))
......@@ -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))
......@@ -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
""
......
......@@ -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