Commits

Anonymous committed 25ed83f

Created

Comments (0)

Files changed (8)

+1998-01-11  SL Baur  <steve@altair.xemacs.org>
+
+	* Makefile (VERSION): Update to newer package interface.
+
+1998-01-04  SL Baur  <steve@altair.xemacs.org>
+
+	* dumped-lisp.el: New file from standard dumped-lisp.el.
+
+1997-12-21  SL Baur  <steve@altair.xemacs.org>
+
+	* Makefile: Created.
+
+# Makefile for tooltalk lisp code
+
+# This file is part of XEmacs.
+
+# XEmacs is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the
+# Free Software Foundation; either version 2, or (at your option) any
+# later version.
+
+# XEmacs is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+# for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with XEmacs; see the file COPYING.  If not, write to
+# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+
+VERSION = 1.03
+PACKAGE = tooltalk
+PKG_TYPE = regular
+REQUIRES =
+CATEGORY = libs
+
+ELCS = tooltalk-init.elc tooltalk-macros.elc tooltalk-util.elc
+
+include ../../XEmacs.rules
+
+all:: $(ELCS) auto-autoloads.elc
+
+srckit: srckit-std
+
+binkit: binkit-sourceonly
+# @(#)Makefile 1.4 94/04/19
+
+EMACS=../../src/xemacs
+
+TOOLTALK.el  = tooltalk-macros.el tooltalk-init.el tooltalk-util.el
+TOOLTALK.elc = $(TOOLTALK.el:.el=.elc)
+
+all: $(TOOLTALK.elc)
+
+.INIT: tooltalk-load.el $(TOOLTALK.el) 
+
+.SUFFIXES: .elc .el
+
+.el.elc:
+	$(EMACS) -batch -q -f batch-byte-compile $(@:.elc=.el)
+
+clean: 
+	$(RM) $(TOOLTALK.elc)
+(setq package-lisp
+      '(
+	#+tooltalk "tooltalk-macros"
+	#+tooltalk "tooltalk-util"
+	#+tooltalk "tooltalk-init"
+))
+(tooltalk
+  (version VERSION
+   description "Support for building with Tooltalk."
+   filename FILENAME
+   md5sum MD5SUM
+   size SIZE
+   provides ()
+   requires (REQUIRES)
+   type regular
+))
+;;; -*- Mode: Emacs-Lisp -*-
+;;;
+;;; Registration of the default Tooltalk patterns and handlers.
+;;;
+;;; @(#)tooltalk-init.el 1.8 94/02/22
+
+
+(defvar tooltalk-eval-pattern
+  '(category TT_HANDLE
+       scope TT_SESSION
+          op "emacs-eval"
+    callback tooltalk-eval-handler))
+
+(defvar tooltalk-load-file-pattern
+  '(category TT_HANDLE
+       scope TT_SESSION
+          op "emacs-load-file"
+	args ((TT_IN "file" "string"))
+    callback tooltalk-load-file-handler))
+
+(defvar tooltalk-make-client-frame-pattern 
+  '(category TT_HANDLE
+       scope TT_SESSION
+          op "emacs-make-client-screen"
+    callback tooltalk-make-client-frame-handler))
+
+(defvar tooltalk-status-pattern 
+  '(category TT_HANDLE
+       scope TT_SESSION
+          op "emacs-status"
+    callback tooltalk-status-handler))
+
+
+(defvar initial-tooltalk-patterns ())
+
+(defun dispatch-initial-tooltalk-message (m)
+  (let ((op (get-tooltalk-message-attribute m 'op))
+	(patterns initial-tooltalk-patterns))
+    (if (stringp op)
+        (while patterns
+          (let ((p (car patterns)))
+            (if (eq (intern op) (tooltalk-pattern-prop-get p 'opsym))
+                (let ((callback (tooltalk-pattern-prop-get p 'callback)))
+                  (if callback (funcall callback m p))
+                  (setq patterns '()))
+              (setq patterns (cdr patterns))))))))
+
+(defun make-initial-tooltalk-pattern (args)
+  (let ((opcdr (cdr (memq 'op args)))
+	(cbcdr (cdr (memq 'callback args))))
+    (if (and (consp opcdr) (consp cbcdr))
+	(let ((plist (list 'opsym (intern (car opcdr)) 'callback (car cbcdr))))
+	  (make-tooltalk-pattern (append args (list 'plist plist))))
+      (make-tooltalk-pattern args))))
+
+(defun register-initial-tooltalk-patterns ()
+  (mapcar #'register-tooltalk-pattern 
+	  (setq initial-tooltalk-patterns
+		(mapcar #'make-initial-tooltalk-pattern
+			(list tooltalk-eval-pattern
+			      tooltalk-load-file-pattern
+			      tooltalk-make-client-frame-pattern
+			      tooltalk-status-pattern))))
+  (add-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
+
+
+(defun unregister-initial-tooltalk-patterns ()
+  (mapcar 'destroy-tooltalk-pattern initial-tooltalk-patterns)
+  (setq initial-tooltalk-patterns ())
+  (remove-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
+
+
+(defun tooltalk:prin1-to-string (form)
+  "Like prin1-to-string except: if the string contains embedded nulls (unlikely
+but possible) then replace each one with \"\\000\"."
+  (let ((string (prin1-to-string form)))
+    (let ((parts '())
+	  index)
+      (while (setq index (string-match "\0" string))
+	(setq parts 
+	      (apply 'list "\\000" (substring string 0 index) parts))
+	(setq string (substring string (1+ index))))
+      (if (not parts)
+	  string
+	(setq parts (apply 'list string parts))
+	(apply 'concat (nreverse parts))))))
+
+;; Backwards compatibility
+(fset 'tooltalk::prin1-to-string-carefully 'tooltalk:prin1-to-string)
+
+
+(defun tooltalk:read-from-string (str)
+  "Like read-from-string except: an error is signalled if the entire 
+string can't be parsed."
+  (let ((res (read-from-string str)))
+    (if (< (cdr res) (length str))
+	(error "Parse of input string ended prematurely."
+	       str))
+    (car res)))
+
+
+(defun tooltalk::eval-string (str)
+  (let ((result (eval (car (read-from-string str)))))
+    (tooltalk:prin1-to-string result)))
+
+
+(defun tooltalk-eval-handler (msg pat)
+  (let ((str (get-tooltalk-message-attribute msg 'arg_val 0))
+	(result-str nil)
+	(failp t))
+    (unwind-protect
+	(cond
+	 ;; Assume That the emacs debugger will handle errors.
+	 ;; If the user throws from the debugger to the cleanup
+	 ;; form below, failp will remain t.
+	 (debug-on-error   
+	  (setq result-str (tooltalk::eval-string str)
+		failp nil))
+
+	 ;; If an error occurs as a result of evaluating
+	 ;; the string or printing the result, then we'll return 
+	 ;; a string version of error-info.
+	 (t
+	  (condition-case error-info
+	      (setq result-str (tooltalk::eval-string str)
+		    failp nil)
+	    (error 
+	     (let ((error-str (tooltalk:prin1-to-string error-info)))
+	       (setq result-str error-str
+		     failp t))))))
+
+      ;; If we get to this point and result-str is still nil, the
+      ;; user must have thrown out of the debuggger
+      (let ((reply-type (if failp 'fail 'reply))
+	    (reply-value (or result-str "(debugger exit)")))
+	(set-tooltalk-message-attribute reply-value msg 'arg_val 0)
+	(return-tooltalk-message msg reply-type)))))
+
+
+(defun tooltalk-make-client-frame-handler (m p)
+  (let ((nargs (get-tooltalk-message-attribute m 'args_count)))
+    (if (not (= 3 nargs))
+	(progn
+	  (set-tooltalk-message-attribute "wrong number of arguments" m 'status_string)
+	  (return-tooltalk-message m 'fail))))
+
+  ;; Note: relying on the fact that arg_ival is returned as a string
+
+  (let* ((name   (get-tooltalk-message-attribute m 'arg_val 0))
+	 (window (get-tooltalk-message-attribute m 'arg_ival 1))
+	 (args (list (cons 'name name) (cons 'window-id window)))
+	 (frame (make-frame args)))
+    (set-tooltalk-message-attribute (frame-name frame) m 'arg_val 2)
+    (return-tooltalk-message m 'reply)))
+
+
+
+(defun tooltalk-load-file-handler (m p)
+  (let ((path (get-tooltalk-message-attribute m 'file)))
+    (condition-case error-info 
+	(progn
+	  (load-file path)
+	  (return-tooltalk-message m 'reply))
+      (error 
+       (let ((error-string (tooltalk:prin1-to-string error-info)))
+	(set-tooltalk-message-attribute error-string m 'status_string)
+	(return-tooltalk-message m 'fail))))))
+
+
+(defun tooltalk-status-handler (m p)
+  (return-tooltalk-message m 'reply))
+
+
+;; Hack the command-line.
+
+(defun command-line-do-tooltalk (arg)
+  "Connect to the ToolTalk server."
+;  (setq command-line-args-left
+;	(cdr (tooltalk-open-connection (cons (car command-line-args)
+;					     command-line-args-left))))
+  (if (tooltalk-open-connection)
+      (register-initial-tooltalk-patterns)
+    (display-warning 'tooltalk "Warning: unable to connect to a ToolTalk server.")))
+
+(setq command-switch-alist
+      (append command-switch-alist
+	      '(("-tooltalk" . command-line-do-tooltalk))))
+
+;; Add some selection converters.
+
+(defun xselect-convert-to-ttprocid (selection type value)
+  (let* ((msg (create-tooltalk-message))
+	 (ttprocid (get-tooltalk-message-attribute msg 'sender)))
+    (destroy-tooltalk-message msg)
+    ttprocid
+    ))
+
+(defun xselect-convert-to-ttsession (selection type value)
+  (let* ((msg (create-tooltalk-message))
+	 (ttsession (get-tooltalk-message-attribute msg 'session)))
+    (destroy-tooltalk-message msg)
+    ttsession
+    ))
+
+(if (boundp 'selection-converter-alist)
+    (setq selection-converter-alist
+	  (append
+	   selection-converter-alist
+	   '((SPRO_PROCID . xselect-convert-to-ttprocid)
+	     (SPRO_SESSION . xselect-convert-to-ttsession)
+	     )))
+  (setq selection-converter-alist
+	'((SPRO_PROCID . xselect-convert-to-ttprocid)
+	  (SPRO_SESSION . xselect-convert-to-ttsession))))
+  

tooltalk-macros.el

+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Date:	Wed Dec 16 17:40:58 1992
+;;; File:	tooltalk-macros.el
+;;; Title:	Useful macros for ToolTalk/elisp interface
+;;; SCCS:	@(#)tooltalk-macros.el	1.5 21 Jan 1993 19:09:24
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro destructuring-bind-tooltalk-message (variables
+					       args-count
+					       message
+					       &rest body)
+  "
+arglist: (variables args-count message &rest body)
+
+Binds VARIABLES to the ARG_VALs and ARG_IVALs of MESSAGE, 
+starting from N = 0, and executes BODY in that context.
+Binds actual number of message args to ARGS-COUNT.  
+
+VARIABLES is a list of local variables to bind.  
+Each item in VARIABLES is either nil, a symbol, or a list of the form:
+
+	(symbol type)
+
+If the item is nil, the nth ARG_VAL or ARG_IVAL of MESSAGE is skipped.
+If the item is a symbol, the nth ARG_VAL of MESSAGE is bound.
+If the item is a list
+	If type =  \"int\" the nth ARG_IVAL of MESSAGE is bound,
+	otherwise the nth ARG_VAL of MESSAGE is bound.
+
+If there are more items than actual arguments in MESSAGE, the extra
+items are bound to nil.
+
+For example,
+
+(destructuring-bind-tooltalk-message (a (b \"int\") nil d) foo msg
+  x y z)
+
+expands to
+
+(let* ((foo (get-tooltalk-message-attribute msg 'args_count))
+       (a (if (< 0 foo)
+	      (get-tooltalk-message-attribute msg 'arg_val 0)))
+       (b (if (< 1 foo) 
+	      (get-tooltalk-message-attribute msg 'arg_val 1)))
+       (d (if (< 3 foo)
+	      (get-tooltalk-message-attribute msg 'arg_val 3))))
+  x y z)
+
+See GET-TOOLTALK-MESSAGE-ATTRIBUTE for more information.
+"
+  (let* ((var-list variables)
+	 (nargs args-count)
+	 (msg message)
+	 (n -1)
+	 var-item
+	 var
+	 type
+	 request
+	 bindings)
+    (setq bindings (cons
+		    (list nargs
+			  (list
+			   'get-tooltalk-message-attribute
+			   msg
+			   ''args_count))
+		    bindings))
+    (while var-list
+      (setq var-item (car var-list)
+	    var-list (cdr var-list))
+      (if (eq 'nil var-item)
+	  (setq n (1+ n))
+	(progn
+	  (if (listp var-item)
+	      (setq var (car var-item)
+		    type (car (cdr var-item)))
+	    (setq var var-item
+		  type "string"))
+	  (setq n (1+ n))
+	  (setq request (list
+			 'get-tooltalk-message-attribute
+			 msg
+			 (if (equal "int" type)
+			     ''arg_ival
+			   ''arg_val)
+			 n))
+	  (setq bindings (cons
+			  (list var
+				(list 'if
+				      (list '< n nargs)
+				      request))
+			  bindings)))))
+    (nconc (list 'let* (nreverse bindings)) body)))
+;;; -*- Mode: Emacs-Lisp -*-
+;;;
+;;; Emacs Tooltalk Utility Functions
+;;;
+;;; @(#)tooltalk-util.el 1.7 93/12/07
+
+
+(defun initialize-tooltalk-message-arg (msg n mode value vtype)
+  "Initialize the Nth tooltalk message argument of MSG.
+A new argument is created if necessary.  No attempt to distinguish
+between strings that contain binary data and ordinary strings is made;
+all non integer argument values are converted to a string (if not a
+string already) and loaded with tt_message_arg_val_set().
+Applications that need to put binary data into a ToolTalk message
+argument should initialize the argument with:
+
+   (set-tooltalk-message-attribute bin-string msg 'arg_bval arg-n)"
+  (let ((n-args-needed
+	 (- (1+ n) (get-tooltalk-message-attribute msg 'args_count))))
+    (while (> n-args-needed 0)
+      (add-tooltalk-message-arg msg mode vtype)
+      (setq n-args-needed (1- n-args-needed))))
+
+  (cond
+   ((integerp value) 
+    (set-tooltalk-message-attribute value msg 'arg_ival n))
+   ((stringp value)
+    (set-tooltalk-message-attribute value msg 'arg_val n))
+   (t
+    (error "The value specified for msg %s argument %d, %s, must be a string or an integer"
+	   (prin1-to-string msg)
+	   n
+	   (prin1-to-string value)))))
+
+
+
+(defconst tooltalk-arg-mode-ids 
+  (list 'TT_IN 'TT_OUT 'TT_INOUT TT_IN TT_OUT TT_INOUT))
+
+(defun initialize-tooltalk-message/pattern-args (initfn msg args)
+  "Apply INITFN to each the position mode value and type of
+each argument in the list.  The value of INITFN should be either
+'initialize-tooltalk-message-arg or 'initialize-tooltalk-pattern-arg.
+See `make-tooltalk-message' for a description of how arguments are specified.
+We distinguish the short form for arguments, e.g. \"just-a-value\", 
+from the long form by checking to see if the argument is a list whose
+car is one of the ToolTalk mode values like TT_INOUT."
+  (let ((n 0))
+    (while args
+      (let* ((arg (car args))
+	     (long-form 
+	      (and (consp arg) 
+		   (member (car arg) tooltalk-arg-mode-ids)))
+	     (mode 
+	      (if long-form (car arg) TT_IN))
+	     (value 
+	      (cond
+	       ((not long-form) arg)
+	       ((cdr arg) (car (cdr arg)))
+	       (t "")))
+	     (type
+	      (cond
+	       ((and long-form
+		     (cdr (cdr arg)) 
+		     (stringp (car (cdr (cdr arg)))))
+		(car (cdr (cdr arg))))
+	       ((integerp value) "int")
+	       (t "string"))))
+	(funcall initfn msg n mode value type))
+      (setq args (cdr args))
+      (setq n (1+ n)))))
+
+
+(defun initialize-tooltalk-message-attributes (msg attributes)
+  "Initialize the tooltalk message attributes.  The value of 
+attributes must be a property list in the same form as for 
+make-tooltalk-message.  This function can be used to reset
+an existing message or to initialize a new one.  See 
+initialize-tooltalk-message-args for a description of how
+arguments are initialized."
+  (let ((args attributes)
+	(initfn 'initialize-tooltalk-message-arg))
+    (while (and args (cdr args))
+      (let ((indicator (car args))
+	    (value (car (cdr args))))
+	(if (eq indicator 'args)
+	    (initialize-tooltalk-message/pattern-args initfn msg value)
+	  (set-tooltalk-message-attribute value msg indicator)))
+      (setq args (cdr (cdr args))))))
+
+
+(defun make-tooltalk-message (attributes &optional no-callback)
+  "Create a tooltalk message and initialize its attributes.
+The value of attributes must be a list of alternating keyword/values, 
+where keywords are symbols that name valid message attributes.  
+For example:
+
+  (make-tooltalk-message 
+    '(class TT_NOTICE
+      scope TT_SESSION
+      address TT_PROCEDURE
+      op \"do-something\"
+      args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\"))))
+
+Values must always be strings, integers, or symbols that
+represent Tooltalk constants.  Attribute names are the same as 
+those supported by set-tooltalk-message-attribute, plus 'args.
+
+The value of args should be a list of message arguments where
+each message argument has the following form:
+
+   (mode [value [type]]) or just value
+
+Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string.  
+If type isn't specified then \"int\" is used if the value is a 
+number otherwise \"string\" is used.  If only a value is specified 
+then mode defaults to TT_IN.  If mode is TT_OUT then value and 
+type don't need to be specified.  You can find out more about the 
+semantics and uses of ToolTalk message arguments in chapter 4 of the 
+Tooltalk Programmer's Guide.
+
+The no-callback arg is a hack to prevent the registration of the
+C-level callback.  This hack is needed by the current SPARCworks
+tool startup mechanism.  Yucko."
+  (let ((msg (create-tooltalk-message no-callback)))
+    (initialize-tooltalk-message-attributes msg attributes)
+    msg))
+
+
+(defun describe-tooltalk-message (msg &optional stream)
+  "Print tooltalk message MSG's attributes and arguments to STREAM.
+This is often useful for debugging."
+  (let ((attrs
+	 '(address
+	   class
+	   disposition
+	   file
+	   gid
+	   handler
+	   handler_ptype
+	   object
+	   op
+	   opnum
+	   otype
+	   scope
+	   sender
+	   sender_ptype
+	   session
+	   state
+	   status
+	   status_string
+	   uid 
+	   callback)))
+    (terpri stream)
+    (while attrs
+      (princ (car attrs) stream)
+      (princ "  " stream)
+      (prin1 (get-tooltalk-message-attribute msg (car attrs)) stream)
+      (terpri stream)
+      (setq attrs (cdr attrs))))
+
+  (let ((n (get-tooltalk-message-attribute msg 'args_count))
+	(i 0))
+    (while (< i n)
+      (princ "Argument " stream)
+      (princ i stream)
+      (princ "  " stream)
+      (let ((type (get-tooltalk-message-attribute msg 'arg_type i)))
+	(princ
+	 (prin1-to-string
+	  (list 
+	   (get-tooltalk-message-attribute msg 'arg_mode i)
+	   (if (equal type "int")
+	       (get-tooltalk-message-attribute msg 'arg_ival i)	      
+	       (get-tooltalk-message-attribute msg 'arg_val i))
+	   type))
+	 stream))
+      (terpri stream)
+      (setq i (1+ i)))))
+
+
+(defun initialize-tooltalk-pattern-arg (pat n mode value vtype)
+  "Add one argument to tooltalk pattern PAT.
+No support for specifying pattern arguments whose value is a vector
+of binary data is provided."
+  (let ((converted-value   
+	 (if (or (integerp value) (stringp value))
+	     value
+	   (prin1-to-string value))))
+    (add-tooltalk-pattern-arg pat mode vtype converted-value)))
+
+
+(defun initialize-tooltalk-pattern-attributes (pat attributes)
+  "Initialize tooltalk pattern PAT's attributes.
+ATTRIBUTES must be a property list in the same form as for
+`make-tooltalk-pattern'.  The value of each attribute (except 'category)
+can either be a single value or a list of values.  If a list of
+values is provided then the pattern will match messages with
+a corresponding attribute that matches any member of the list.
+
+This function can be used to add attribute values to an existing
+pattern or to initialize a new one.  See
+`initialize-tooltalk-message/pattern-args' for a description of how
+arguments are initialized."
+  (let ((args attributes)
+	(initfn 'initialize-tooltalk-pattern-arg))
+    (while (and args (cdr args))
+      (let ((indicator (car args))
+	    (value (car (cdr args))))
+	(cond
+	 ((eq indicator 'args)
+	  (initialize-tooltalk-message/pattern-args initfn pat value))
+	 ((eq indicator 'plist)
+	  (let ((values value))
+	    (while values
+	      (let ((prop (car values))
+		    (propval (car (cdr values))))
+		(tooltalk-pattern-prop-set pat prop propval))
+	      (setq values (cdr (cdr values))))))
+	 ((consp value)
+	  (let ((values value))
+	    (while values
+	      (add-tooltalk-pattern-attribute (car values) pat indicator)
+	      (setq values (cdr values)))))
+	 (t
+	  (add-tooltalk-pattern-attribute value pat indicator))))
+      (setq args (cdr (cdr args))))))
+
+
+
+(defun make-tooltalk-pattern (attributes)
+  "Create a tooltalk pattern and initialize its attributes.
+The value of attributes must be a list of alternating keyword/values, 
+where keywords are symbols that name valid pattern attributes
+or lists of valid attributes.  For example:
+
+  (make-tooltalk-pattern 
+    '(category TT_OBSERVE
+      scope TT_SESSION
+      op (\"operation1\" \"operation2\")
+      args (\"arg1\" 12345 (TT_INOUT \"arg3\" \"string\"))))
+
+
+Values must always be strings, integers, or symbols that
+represent Tooltalk constants or lists of same.  When a list 
+of values is provided all of the list elements are added to 
+the attribute.  In the example above, messages whose op
+attribute is \"operation1\" or \"operation2\" would match the pattern.
+
+The value of args should be a list of pattern arguments where 
+each pattern argument has the following form:
+
+   (mode [value [type]]) or just value
+
+Where mode is one of TT_IN, TT_OUT, TT_INOUT and type is a string.  
+If type isn't specified then \"int\" is used if the value is a 
+number otherwise \"string\" is used.  If only a value is specified 
+then mode defaults to TT_IN.  If mode is TT_OUT then value and type 
+don't need to be specified.  You can find out more about the semantics 
+and uses of ToolTalk pattern arguments in chapter 3 of the Tooltalk
+Programmers Guide.
+"
+  (let ((pat (create-tooltalk-pattern)))
+    (initialize-tooltalk-pattern-attributes pat attributes)
+    pat))
+
+
+