(connect-to-gds): Break generation of client name

into ...
(client-name): New procedure.
(client-name): Put something from (program-arguments) in the
client name that GDS displays in Emacs.
(connect-to-gds, client-name): Add application-name arg to allow
caller to specify client name.

diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index 0db6fcb..f3848f1 100644 (file)
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,13 @@
+2007-02-18  Neil Jerram  <neil@ossau.uklinux.net>
+
+       * gds-client.scm (connect-to-gds): Break generation of client name
+       into ...
+       (client-name): New procedure.
+       (client-name): Put something from (program-arguments) in the
+       client name that GDS displays in Emacs.
+       (connect-to-gds, client-name): Add application-name arg to allow
+       caller to specify client name.
+
 2007-02-09  Ludovic Courtès  <ludovic.courtes@laas.fr>
 
        * Makefile.am (ice9_sources): Added `i18n.scm'.

diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm
index 8c7bdc7..7e6e524 100755 (executable)
--- a/ice-9/gds-client.scm
+++ b/ice-9/gds-client.scm
@@ -170,7 +170,7 @@
                       (safely-handle-nondebug-protocol protocol)
                       (loop (gds-debug-read))))))))
 
-(define (connect-to-gds)
+(define (connect-to-gds . application-name)
   (or gds-port
       (begin
         (set! gds-port
@@ -190,7 +190,19 @@
                             s)
                           (lambda _ #f)))
                  (error "Couldn't connect to GDS by TCP or Unix domain socket")))
-        (write-form (list 'name (getpid) (format #f "PID ~A" (getpid)))))))
+        (write-form (list 'name (getpid) (apply client-name application-name))))))
+
+(define (client-name . application-name)
+  (let loop ((args (append application-name (program-arguments))))
+    (if (null? args)
+       (format #f "PID ~A" (getpid))
+       (let ((arg (car args)))
+         (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
+                (loop (cdr args)))
+               ((string-match "^-" arg)
+                (loop (cdr args)))
+               (else
+                (format #f "~A (PID ~A)" arg (getpid))))))))
 
 (if (not (defined? 'make-mutex))
     (begin