From 169ccff576c7c7d6e9c4b77deb65241ebaa3ee71 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 18 Feb 2007 23:03:35 +0000 Subject: [PATCH] (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 | 10 ++++++++++ ice-9/gds-client.scm | 16 ++++++++++++++-- 2 files changed, 24 insertions(+), 2 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 0db6fcb84..f3848f1e0 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2007-02-18 Neil Jerram + + * 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 * Makefile.am (ice9_sources): Added `i18n.scm'. diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index 8c7bdc742..7e6e524e5 100755 --- 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