(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.

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'.

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