From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Neil Jerram Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 3/5] Handle short option unclumping progressively, instead of all upfront Date: Sun, 8 May 2011 23:18:15 +0100 Message-ID: <1304893097-10889-4-git-send-email-neil@ossau.uklinux.net> References: <1304893097-10889-1-git-send-email-neil@ossau.uklinux.net> NNTP-Posting-Host: lo.gmane.org X-Trace: dough.gmane.org 1304893186 27060 80.91.229.12 (8 May 2011 22:19:46 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 8 May 2011 22:19:46 +0000 (UTC) Cc: Neil Jerram To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon May 09 00:19:42 2011 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([140.186.70.17]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1QJCKD-0003oz-4P for guile-devel@m.gmane.org; Mon, 09 May 2011 00:19:41 +0200 Original-Received: from localhost ([::1]:37171 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCKC-0000Zi-K8 for guile-devel@m.gmane.org; Sun, 08 May 2011 18:19:40 -0400 Original-Received: from eggs.gnu.org ([140.186.70.92]:42002) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCK9-0000ZL-Kh for guile-devel@gnu.org; Sun, 08 May 2011 18:19:38 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1QJCK8-0002qF-G9 for guile-devel@gnu.org; Sun, 08 May 2011 18:19:37 -0400 Original-Received: from mail3.uklinux.net ([80.84.72.33]:52019) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1QJCK7-0002md-VE for guile-devel@gnu.org; Sun, 08 May 2011 18:19:36 -0400 Original-Received: from arudy (unknown [78.149.196.143]) by mail3.uklinux.net (Postfix) with ESMTP id 1119A1F6675 for ; Sun, 8 May 2011 23:18:53 +0100 (BST) Original-Received: from neil-laptop.520b.com (unknown [192.168.11.9]) by arudy (Postfix) with ESMTP id 0178B38040; Sun, 8 May 2011 23:18:46 +0100 (BST) X-Mailer: git-send-email 1.7.4.1 In-Reply-To: <1304893097-10889-1-git-send-email-neil@ossau.uklinux.net> X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.4-2.6 X-Received-From: 80.84.72.33 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:12465 Archived-At: This is needed as a prerequisite for the following don't know how far through the command line we should go with unclumping. * module/ice-9/getopt-long.scm (expand-clumped-singles): Delete. (process-options): Add a loop variable to indicate how many elements at the start of `argument-ls' are known not to be clumped. When we see a short option and this variable is <= 0, perform unclumping (using code that used to be in expand-clumped-singles) and loop with the variable > 0. (getopt-long): Don't call expand-clumped-singles upfront here. --- module/ice-9/getopt-long.scm | 57 ++++++++++++++++++----------------------- 1 files changed, 25 insertions(+), 32 deletions(-) diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm index 5c73f9a..0c2d835 100644 --- a/module/ice-9/getopt-long.scm +++ b/module/ice-9/getopt-long.scm @@ -226,27 +226,6 @@ (define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) -(define (expand-clumped-singles opt-ls) - ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d") - (let loop ((opt-ls opt-ls) (ret-ls '())) - (cond ((null? opt-ls) - (reverse ret-ls)) ;;; retval - ((regexp-exec short-opt-rx (car opt-ls)) - => (lambda (match) - (let ((singles (reverse - (map (lambda (c) - (string-append "-" (make-string 1 c))) - (string->list - (match:substring match 1))))) - (extra (match:substring match 2))) - (loop (cdr opt-ls) - (append (if (string=? "" extra) - singles - (cons extra singles)) - ret-ls))))) - (else (loop (cdr opt-ls) - (cons (car opt-ls) ret-ls)))))) - (define (looks-like-an-option string) (or (regexp-exec short-opt-rx string) (regexp-exec long-opt-with-value-rx string) @@ -264,22 +243,22 @@ (cons (make-string 1 (option-spec->single-char spec)) spec)) (remove-if-not option-spec->single-char specs)))) - (let loop ((argument-ls argument-ls) (found '()) (etc '())) + (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '())) (define (eat! spec ls) (cond ((eq? 'optional (option-spec->value-policy spec)) (if (or (null? ls) (looks-like-an-option (car ls))) - (loop ls (acons spec #t found) etc) - (loop (cdr ls) (acons spec (car ls) found) etc))) + (loop (- unclumped 1) ls (acons spec #t found) etc) + (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) ((eq? #t (option-spec->value-policy spec)) (if (or (null? ls) (looks-like-an-option (car ls))) (fatal-error "option must be specified with argument: --~a" (option-spec->name spec)) - (loop (cdr ls) (acons spec (car ls) found) etc))) + (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) (else - (loop ls (acons spec #t found) etc)))) + (loop (- unclumped 1) ls (acons spec #t found) etc)))) (match argument-ls (() @@ -288,10 +267,24 @@ (cond ((regexp-exec short-opt-rx opt) => (lambda (match) - (let* ((c (match:substring match 1)) - (spec (or (assoc-ref sc-idx c) - (fatal-error "no such option: -~a" c)))) - (eat! spec rest)))) + (if (> unclumped 0) + ;; Next option is known not to be clumped. + (let* ((c (match:substring match 1)) + (spec (or (assoc-ref sc-idx c) + (fatal-error "no such option: -~a" c)))) + (eat! spec rest)) + ;; Expand a clumped group of short options. + (let* ((extra (match:substring match 2)) + (unclumped-opts + (append (map (lambda (c) + (string-append "-" (make-string 1 c))) + (string->list + (match:substring match 1))) + (if (string=? "" extra) '() (list extra))))) + (loop (length unclumped-opts) + (append unclumped-opts rest) + found + etc))))) ((regexp-exec long-opt-no-value-rx opt) => (lambda (match) (let* ((opt (match:substring match 1)) @@ -308,7 +301,7 @@ (fatal-error "option does not support argument: --~a" opt))))) (else - (loop rest found (cons opt etc))))))))) + (loop (- unclumped 1) rest found (cons opt etc))))))))) (define (getopt-long program-arguments option-desc-list) "Process options, handling both long and short options, similar to @@ -344,7 +337,7 @@ to add a `single-char' clause to the option description." (with-fluids ((%program-name (car program-arguments))) (let* ((specifications (map parse-option-spec option-desc-list)) (pair (split-arg-list (cdr program-arguments))) - (split-ls (expand-clumped-singles (car pair))) + (split-ls (car pair)) (non-split-ls (cdr pair)) (found/etc (process-options specifications split-ls)) (found (car found/etc)) -- 1.7.4.1