mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 00:40:20 +02:00
Code Activity

getopt-long cleanup

Browse source 
* module/ice-9/getopt-long.scm (process-options): Use more internal
  definitions instead of let-bound functions to decrease the nesting
  depth.
This commit is contained in:
Andy Wingo 2011-02-10 11:31:30 +01:00
parent 8b9b0af445
commit cafb15e96e
1 changed files with 58 additions and 71 deletions
Download patch file Download diff file Expand all files Collapse all files

129
module/ice-9/getopt-long.scm
View file

@ -256,77 +256,64 @@
spec)) spec))
(remove-if-not option-spec->single-char specs)))) (remove-if-not option-spec->single-char specs))))
(let loop ((argument-ls argument-ls) (found '()) (etc '())) (let loop ((argument-ls argument-ls) (found '()) (etc '()))
(let ((eat! (lambda (spec ls) (define (eat! spec ls)
(let ((val!loop (lambda (val n-ls n-found n-etc) (define (val!loop val n-ls n-found n-etc)
(set-option-spec-value! (set-option-spec-value!
spec spec
;; handle multiple occurrances ;; handle multiple occurrances
(cond ((option-spec->value spec) (cond ((option-spec->value spec)
=> (lambda (cur) => (lambda (cur)
((if (list? cur) cons list) ((if (list? cur) cons list)
val cur))) val cur)))
(else val))) (else val)))
(loop n-ls n-found n-etc))) (loop n-ls n-found n-etc))
(ERR:no-arg (lambda () (define (ERR:no-arg)
(error (string-append (error "option must be specified with argument:"
"option must be specified" (option-spec->name spec)))
" with argument:") (cond
(option-spec->name spec))))) ((eq? 'optional (option-spec->value-policy spec))
(cond (if (or (null? (cdr ls))
((eq? 'optional (option-spec->value-policy spec)) (looks-like-an-option (cadr ls)))
(if (or (null? (cdr ls)) (val!loop #t (cdr ls) (cons spec found) etc)
(looks-like-an-option (cadr ls))) (val!loop (cadr ls) (cddr ls) (cons spec found) etc)))
(val!loop #t ((eq? #t (option-spec->value-policy spec))
(cdr ls) (if (or (null? (cdr ls))
(cons spec found) (looks-like-an-option (cadr ls)))
etc) (ERR:no-arg)
(val!loop (cadr ls) (val!loop (cadr ls) (cddr ls) (cons spec found) etc)))
(cddr ls) (else
(cons spec found) (val!loop #t (cdr ls) (cons spec found) etc))))
etc)))
((eq? #t (option-spec->value-policy spec)) (if (null? argument-ls)
(if (or (null? (cdr ls)) (cons found (reverse etc)) ;;; retval
(looks-like-an-option (cadr ls))) (cond ((regexp-exec short-opt-rx (car argument-ls))
(ERR:no-arg) => (lambda (match)
(val!loop (cadr ls) (let* ((c (match:substring match 1))
(cddr ls) (spec (or (assoc-ref sc-idx c)
(cons spec found) (error "no such option:" c))))
etc))) (eat! spec argument-ls))))
(else ((regexp-exec long-opt-no-value-rx (car argument-ls))
(val!loop #t => (lambda (match)
(cdr ls) (let* ((opt (match:substring match 1))
(cons spec found) (spec (or (assoc-ref idx opt)
etc))))))) (error "no such option:" opt))))
(if (null? argument-ls) (eat! spec argument-ls))))
(cons found (reverse etc)) ;;; retval ((regexp-exec long-opt-with-value-rx (car argument-ls))
(cond ((regexp-exec short-opt-rx (car argument-ls)) => (lambda (match)
=> (lambda (match) (let* ((opt (match:substring match 1))
(let* ((c (match:substring match 1)) (spec (or (assoc-ref idx opt)
(spec (or (assoc-ref sc-idx c) (error "no such option:" opt))))
(error "no such option:" c)))) (if (option-spec->value-policy spec)
(eat! spec argument-ls)))) (eat! spec (append
((regexp-exec long-opt-no-value-rx (car argument-ls)) (list 'ignored
=> (lambda (match) (match:substring match 2))
(let* ((opt (match:substring match 1)) (cdr argument-ls)))
(spec (or (assoc-ref idx opt) (error "option does not support argument:"
(error "no such option:" opt)))) opt)))))
(eat! spec argument-ls)))) (else
((regexp-exec long-opt-with-value-rx (car argument-ls)) (loop (cdr argument-ls)
=> (lambda (match) found
(let* ((opt (match:substring match 1)) (cons (car argument-ls) etc))))))))
(spec (or (assoc-ref idx opt)
(error "no such option:" opt))))
(if (option-spec->value-policy spec)
(eat! spec (append
(list 'ignored
(match:substring match 2))
(cdr argument-ls)))
(error "option does not support argument:"
opt)))))
(else
(loop (cdr argument-ls)
found
(cons (car argument-ls) etc)))))))))
(define (getopt-long program-arguments option-desc-list) (define (getopt-long program-arguments option-desc-list)
"Process options, handling both long and short options, similar to "Process options, handling both long and short options, similar to