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

Refill to fit in 80 columns.

Browse source 
(process-long-option): Fix bug: Keep track of `optional' value-required
info and use this to determine whether or not the next element is to be
taken as the option arg.
This commit is contained in:
Thien-Thi Nguyen 2001-08-02 10:26:52 +00:00
parent ed9ef46202
commit 4f70d598bf
1 changed files with 212 additions and 154 deletions
Download patch file Download diff file Expand all files Collapse all files

366
ice-9/getopt-long.scm
View file

@ -1,5 +1,5 @@
;;; Author: Russ McManus ;;; Author: Russ McManus
;;; $Id: getopt-long.scm,v 1.4 2001-06-03 23:29:45 mvo Exp $ ;;; $Id: getopt-long.scm,v 1.5 2001-08-02 10:26:52 ttn Exp $
;;; ;;;
;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc. ;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
;;; ;;;
@ -190,147 +190,147 @@
(begin (define (begin (define
option-spec->name option-spec->name
(lambda (lambda
(obj) (obj)
(if (option-spec? obj) (if (option-spec? obj)
(vector-ref obj 1) (vector-ref obj 1)
(slib:error (slib:error
(quote option-spec->name) (quote option-spec->name)
": bad record" ": bad record"
obj)))) obj))))
(define (define
option-spec->value option-spec->value
(lambda (lambda
(obj) (obj)
(if (option-spec? obj) (if (option-spec? obj)
(vector-ref obj 2) (vector-ref obj 2)
(slib:error (slib:error
(quote option-spec->value) (quote option-spec->value)
": bad record" ": bad record"
obj)))) obj))))
(define (define
option-spec->value-required? option-spec->value-required?
(lambda (lambda
(obj) (obj)
(if (option-spec? obj) (if (option-spec? obj)
(vector-ref obj 3) (vector-ref obj 3)
(slib:error (slib:error
(quote option-spec->value-required?) (quote option-spec->value-required?)
": bad record" ": bad record"
obj)))) obj))))
(define (define
option-spec->single-char option-spec->single-char
(lambda (lambda
(obj) (obj)
(if (option-spec? obj) (if (option-spec? obj)
(vector-ref obj 4) (vector-ref obj 4)
(slib:error (slib:error
(quote option-spec->single-char) (quote option-spec->single-char)
": bad record" ": bad record"
obj)))) obj))))
(define (define
option-spec->predicate-ls option-spec->predicate-ls
(lambda (lambda
(obj) (obj)
(if (option-spec? obj) (if (option-spec? obj)
(vector-ref obj 5) (vector-ref obj 5)
(slib:error (slib:error
(quote option-spec->predicate-ls) (quote option-spec->predicate-ls)
": bad record" ": bad record"
obj)))) obj))))
(define (define
option-spec->parse-ls option-spec->parse-ls
(lambda (lambda
(obj) (obj)
(if (option-spec? obj) (if (option-spec? obj)
(vector-ref obj 6) (vector-ref obj 6)
(slib:error (slib:error
(quote option-spec->parse-ls) (quote option-spec->parse-ls)
": bad record" ": bad record"
obj)))) obj))))
(define (define
set-option-spec-name! set-option-spec-name!
(lambda (lambda
(obj val) (obj val)
(if (option-spec? obj) (if (option-spec? obj)
(vector-set! obj 1 val) (vector-set! obj 1 val)
(slib:error (slib:error
(quote set-option-spec-name!) (quote set-option-spec-name!)
": bad record" ": bad record"
obj)))) obj))))
(define (define
set-option-spec-value! set-option-spec-value!
(lambda (lambda
(obj val) (obj val)
(if (option-spec? obj) (if (option-spec? obj)
(vector-set! obj 2 val) (vector-set! obj 2 val)
(slib:error (slib:error
(quote set-option-spec-value!) (quote set-option-spec-value!)
": bad record" ": bad record"
obj)))) obj))))
(define (define
set-option-spec-value-required?! set-option-spec-value-required?!
(lambda (lambda
(obj val) (obj val)
(if (option-spec? obj) (if (option-spec? obj)
(vector-set! obj 3 val) (vector-set! obj 3 val)
(slib:error (slib:error
(quote set-option-spec-value-required?!) (quote set-option-spec-value-required?!)
": bad record" ": bad record"
obj)))) obj))))
(define (define
set-option-spec-single-char! set-option-spec-single-char!
(lambda (lambda
(obj val) (obj val)
(if (option-spec? obj) (if (option-spec? obj)
(vector-set! obj 4 val) (vector-set! obj 4 val)
(slib:error (slib:error
(quote set-option-spec-single-char!) (quote set-option-spec-single-char!)
": bad record" ": bad record"
obj)))) obj))))
(define (define
set-option-spec-predicate-ls! set-option-spec-predicate-ls!
(lambda (lambda
(obj val) (obj val)
(if (option-spec? obj) (if (option-spec? obj)
(vector-set! obj 5 val) (vector-set! obj 5 val)
(slib:error (slib:error
(quote set-option-spec-predicate-ls!) (quote set-option-spec-predicate-ls!)
": bad record" ": bad record"
obj)))) obj))))
(define (define
set-option-spec-parse-ls! set-option-spec-parse-ls!
(lambda (lambda
(obj val) (obj val)
(if (option-spec? obj) (if (option-spec? obj)
(vector-set! obj 6 val) (vector-set! obj 6 val)
(slib:error (slib:error
(quote set-option-spec-parse-ls!) (quote set-option-spec-parse-ls!)
": bad record" ": bad record"
obj)))) obj))))
(define (define
option-spec? option-spec?
(lambda (lambda
(obj) (obj)
(and (vector? obj) (and (vector? obj)
(= (vector-length obj) 7) (= (vector-length obj) 7)
(eq? (vector-ref obj 0) (quote option-spec))))) (eq? (vector-ref obj 0) (quote option-spec)))))
(define (define
make-option-spec make-option-spec
(lambda (lambda
(option-spec->name (option-spec->name
option-spec->value option-spec->value
option-spec->value-required? option-spec->value-required?
option-spec->single-char option-spec->single-char
option-spec->predicate-ls option-spec->predicate-ls
option-spec->parse-ls) option-spec->parse-ls)
(vector (vector
(quote option-spec) (quote option-spec)
option-spec->name option-spec->name
option-spec->value option-spec->value
option-spec->value-required? option-spec->value-required?
option-spec->single-char option-spec->single-char
option-spec->predicate-ls option-spec->predicate-ls
option-spec->parse-ls)))) option-spec->parse-ls))))
;;; ;;;
@ -394,80 +394,102 @@
(let ((key (car ls)) (let ((key (car ls))
(val (cadr ls))) (val (cadr ls)))
(cond ((and (eq? key 'required?) val) (cond ((and (eq? key 'required?) val)
;; required values are implemented as a predicate ;; required values implemented as a predicate
(parse-iter (make-option-spec (option-spec->name spec) (parse-iter
(option-spec->value spec) (make-option-spec
(option-spec->value-required? spec) (option-spec->name spec)
(option-spec->single-char spec) (option-spec->value spec)
(cons (make-option-required-predicate) (option-spec->value-required? spec)
(option-spec->predicate-ls spec)) (option-spec->single-char spec)
(cdr parse-ls)))) (cons (make-option-required-predicate)
;; if the value is not required, then don't add a predicate, (option-spec->predicate-ls spec))
(cdr parse-ls))))
;; if value not required, don't add predicate,
((eq? key 'required?) ((eq? key 'required?)
(parse-iter (make-option-spec (option-spec->name spec) (parse-iter
(option-spec->value spec) (make-option-spec
(option-spec->value-required? spec) (option-spec->name spec)
(option-spec->single-char spec) (option-spec->value spec)
(option-spec->predicate-ls spec) (option-spec->value-required? spec)
(cdr parse-ls)))) (option-spec->single-char spec)
(option-spec->predicate-ls spec)
(cdr parse-ls))))
;; handle value specification ;; handle value specification
((eq? key 'value) ((eq? key 'value)
(cond ((eq? val #t) (cond ((eq? val #t)
;; when value is required, add a predicate to that effect ;; when value is required, add a
;; and record the fact in value-required? field. ;; predicate to that effect and record
(parse-iter (make-option-spec (option-spec->name spec) ;; the fact in value-required? field.
(option-spec->value spec) (parse-iter
#t (make-option-spec
(option-spec->single-char spec) (option-spec->name spec)
(cons (make-required-value-fn) (option-spec->value spec)
(option-spec->predicate-ls spec)) #t
(cdr parse-ls)))) (option-spec->single-char spec)
(cons (make-required-value-fn)
(option-spec->predicate-ls spec))
(cdr parse-ls))))
((eq? val #f) ((eq? val #f)
;; when the value is not allowed, add a predicate to that effect. ;; when the value is not allowed, add a
;; one can detect that a value is not supplied by checking the option ;; predicate to that effect. one can
;; value against #f. ;; detect that a value is not supplied
(parse-iter (make-option-spec (option-spec->name spec) ;; by checking the option value against
(option-spec->value spec) ;; #f.
#f (parse-iter
(option-spec->single-char spec) (make-option-spec
(cons (make-not-allowed-value-fn) (option-spec->name spec)
(option-spec->predicate-ls spec)) (option-spec->value spec)
(cdr parse-ls)))) #f
(option-spec->single-char spec)
(cons (make-not-allowed-value-fn)
(option-spec->predicate-ls spec))
(cdr parse-ls))))
((eq? val 'optional) ((eq? val 'optional)
;; for optional values, don't add a predicate. do, however ;; for optional values, don't add a
;; put the value 'optional in the value-required? field. this ;; predicate. do, however put the value
;; setting checks whether optional values are 'greedy'. set ;; 'optional in the value-required?
;; to #f to make optional value clauses 'non-greedy'. ;; field. this setting checks whether
;; optional values are 'greedy'. set to
(parse-iter (make-option-spec (option-spec->name spec) ;; #f to make optional value clauses
(option-spec->value spec) ;; 'non-greedy'.
'optional (parse-iter
(option-spec->single-char spec) (make-option-spec
(option-spec->predicate-ls spec) (option-spec->name spec)
(cdr parse-ls)))) (option-spec->value spec)
'optional
(option-spec->single-char spec)
(option-spec->predicate-ls spec)
(cdr parse-ls))))
(#t (#t
;; error case ;; error case
(error "Bad value specification for option:" (cons key val))))) (error "Bad value specification for option:"
;; specify which single char is defined for this option. (cons key val)))))
;; specify single char defined for this option.
((eq? key 'single-char) ((eq? key 'single-char)
(if (not (single-char-value? val)) (if (not (single-char-value? val))
(error "Not a single-char-value:" val " for option:" key) (error "Not a single-char-value:"
(parse-iter (make-option-spec (option-spec->name spec) val " for option:" key)
(option-spec->value spec) (parse-iter
(option-spec->value-required? spec) (make-option-spec
val (option-spec->name spec)
(option-spec->predicate-ls spec) (option-spec->value spec)
(cdr parse-ls))))) (option-spec->value-required? spec)
val
(option-spec->predicate-ls spec)
(cdr parse-ls)))))
((eq? key 'predicate) ((eq? key 'predicate)
(if (procedure? val) (if (procedure? val)
(parse-iter (make-option-spec (option-spec->name spec) (parse-iter
(option-spec->value spec) (make-option-spec
(option-spec->value-required? spec) (option-spec->name spec)
(option-spec->single-char spec) (option-spec->value spec)
(cons (make-user-predicate val) (option-spec->value-required? spec)
(option-spec->predicate-ls spec)) (option-spec->single-char spec)
(cdr parse-ls))) (cons (make-user-predicate val)
(error "Bad predicate specified for option:" (cons key val)))))))))))) (option-spec->predicate-ls spec))
(cdr parse-ls)))
(error "Bad predicate specified for option:"
(cons key val))))))))))))
(if (or (not (pair? desc)) (if (or (not (pair? desc))
(string? (car desc))) (string? (car desc)))
(error "Bad option specification:" desc)) (error "Bad option specification:" desc))
@ -514,26 +536,30 @@ is the list to not process."
((is-short-opt? (car opt-ls)) ((is-short-opt? (car opt-ls))
(let* ((orig-str (car opt-ls)) (let* ((orig-str (car opt-ls))
(match-pair (vector-ref response 2)) (match-pair (vector-ref response 2))
(match-str (substring orig-str (car match-pair) (cdr match-pair)))) (match-str (substring orig-str (car match-pair)
(cdr match-pair))))
(if (= (string-length match-str) 1) (if (= (string-length match-str) 1)
(iter (cdr opt-ls) (iter (cdr opt-ls)
(cons (string-append "-" match-str) ret-ls)) (cons (string-append "-" match-str) ret-ls))
(iter (cons (string-append "-" (substring match-str 1)) (cdr opt-ls)) (iter (cons (string-append "-" (substring match-str 1))
(cons (string-append "-" (substring match-str 0 1)) ret-ls))))) (cdr opt-ls))
(cons (string-append "-" (substring match-str 0 1))
ret-ls)))))
(#t (iter (cdr opt-ls) (#t (iter (cdr opt-ls)
(cons (car opt-ls) ret-ls))))) (cons (car opt-ls) ret-ls)))))
(iter opt-ls '()))) (iter opt-ls '())))
(define (process-short-option specifications argument-ls alist) (define (process-short-option specifications argument-ls alist)
"Process a single short option that appears at the front of the ARGUMENT-LS, "Process a single short option that appears at the front of the ARGUMENT-LS,
according to SPECIFICATIONS. Returns #f is there is no such argument. Otherwise according to SPECIFICATIONS. Returns #f is there is no such argument.
returns a pair whose car is the list of remaining arguments, and whose cdr is a Otherwise returns a pair whose car is the list of remaining arguments, and
new association list, constructed by adding a pair to the supplied ALIST. whose cdr is a new association list, constructed by adding a pair to the
The pair on the front of the returned association list describes the option supplied ALIST. The pair on the front of the returned association list
found at the head of ARGUMENT-LS. The way this routine currently works, an describes the option found at the head of ARGUMENT-LS. The way this routine
option that never takes a value that is followed by a non option will cause currently works, an option that never takes a value that is followed by a non
an error, which is probably a bug. To fix the bug the option specification option will cause an error, which is probably a bug. To fix the bug the
needs to record whether the option ever can take a value." option specification needs to record whether the option ever can take a
value."
(define (short-option->char option) (define (short-option->char option)
(string-ref option 1)) (string-ref option 1))
(define (is-short-option? option) (define (is-short-option? option)
@ -543,29 +569,36 @@ needs to record whether the option ever can take a value."
(regexp-exec long-opt-no-value-rx option))) (regexp-exec long-opt-no-value-rx option)))
(define (find-matching-spec option) (define (find-matching-spec option)
(let ((key (short-option->char option))) (let ((key (short-option->char option)))
(find-if (lambda (spec) (eq? key (option-spec->single-char spec))) specifications))) (find-if (lambda (spec)
(eq? key (option-spec->single-char spec))) specifications)))
(let ((option (car argument-ls))) (let ((option (car argument-ls)))
(if (is-short-option? option) (if (is-short-option? option)
(let ((spec (find-matching-spec option))) (let ((spec (find-matching-spec option)))
(if spec (if spec
(let* ((next-value (if (null? (cdr argument-ls)) #f (cadr argument-ls))) (let* ((next-value (if (null? (cdr argument-ls))
#f
(cadr argument-ls)))
(option-value (if (and next-value (option-value (if (and next-value
(not (is-short-option? next-value)) (not (is-short-option? next-value))
(not (is-long-option? next-value)) (not (is-long-option? next-value))
(option-spec->value-required? spec)) (option-spec->value-required? spec))
next-value next-value
#t)) #t))
(new-alist (cons (cons (option-spec->name spec) option-value) alist))) (new-alist (cons (cons (option-spec->name spec)
option-value)
alist)))
(cons (if (eq? option-value #t) (cons (if (eq? option-value #t)
(cdr argument-ls) ; there was one value specified, skip just one (cdr argument-ls) ; one value, skip just one
(cddr argument-ls)) ; there must have been a value specified, skip two (cddr argument-ls)) ; must be a value, skip two
new-alist)) new-alist))
(error "No such option:" option))) (error "No such option:" option)))
#f))) #f)))
(define (process-long-option specifications argument-ls alist) (define (process-long-option specifications argument-ls alist)
(define (find-matching-spec key) (define (find-matching-spec key)
(find-if (lambda (spec) (eq? key (option-spec->name spec))) specifications)) (find-if (lambda (spec)
(eq? key (option-spec->name spec)))
specifications))
(define (split-long-option option) (define (split-long-option option)
;; returns a pair whose car is a symbol naming the option, cdr is ;; returns a pair whose car is a symbol naming the option, cdr is
;; the option value. as a special case, if the option value is ;; the option value. as a special case, if the option value is
@ -577,27 +610,50 @@ needs to record whether the option ever can take a value."
;; Maybe we need to grab a value from argument-ls. To find ;; Maybe we need to grab a value from argument-ls. To find
;; out we need to refer to the option-spec. ;; out we need to refer to the option-spec.
(let* ((key-pair (vector-ref resp 2)) (let* ((key-pair (vector-ref resp 2))
(key (string->symbol (substring option (car key-pair) (cdr key-pair)))) (key (string->symbol
(substring option (car key-pair) (cdr key-pair))))
(spec (find-matching-spec key))) (spec (find-matching-spec key)))
(cons key (if (option-spec->value-required? spec) #f #t))) (let* ((req (option-spec->value-required? spec))
(retval (cons key (if req #f #t))))
;; this is a fucking kludge, i hate it. it's necessary because
;; the protocol (return #f to indicate next element is an option
;; arg) is insufficient. needs redesign. why am i checking in
;; such ugliness? read moby dick! -ttn
(and (eq? 'optional req)
(set-object-property! retval 'optional #t))
retval))
(let ((resp (regexp-exec long-opt-with-value-rx option))) (let ((resp (regexp-exec long-opt-with-value-rx option)))
;; Aha, we've found a long option with an equal sign. The ;; Aha, we've found a long option with an equal sign. The
;; option value is simply the value to the right of the ;; option value is simply the value to the right of the
;; equal sign. ;; equal sign.
(if resp (if resp
(let* ((key-pair (vector-ref resp 2)) (let* ((key-pair (vector-ref resp 2))
(key (string->symbol (substring option (car key-pair) (cdr key-pair)))) (key (string->symbol
(substring option
(car key-pair) (cdr key-pair))))
(value-pair (vector-ref resp 3)) (value-pair (vector-ref resp 3))
(value (substring option (car value-pair) (cdr value-pair)))) (value (substring option
(car value-pair) (cdr value-pair))))
(cons key value)) (cons key value))
#f))))) #f)))))
(let* ((option (car argument-ls)) (let* ((option (car argument-ls))
(pair (split-long-option option))) (pair (split-long-option option)))
(cond ((and pair (eq? (cdr pair) #f)) (cond ((and pair (eq? (cdr pair) #f))
(if (null? (cdr argument-ls)) (cond ((and (null? (cdr argument-ls))
(error "Not enough options.") (not (object-property pair 'optional)))
(cons (cddr argument-ls) (error "Not enough options."))
(cons (cons (car pair) (cadr argument-ls)) alist)))) ((null? (cdr argument-ls))
(cons '() (cons (cons (car pair) #t) alist)))
((let* ((next (cadr argument-ls))
(m (or (regexp-exec short-opt-rx next)
(regexp-exec long-opt-with-value-rx next)
(regexp-exec long-opt-no-value-rx next))))
(and m (object-property pair 'optional)))
(cons (cdr argument-ls)
(cons (cons (car pair) #t) alist)))
(else
(cons (cddr argument-ls)
(cons (cons (car pair) (cadr argument-ls)) alist)))))
(pair (pair
(cons (cdr argument-ls) (cons pair alist))) (cons (cdr argument-ls) (cons pair alist)))
(else #f)))) (else #f))))
@ -611,7 +667,8 @@ needs to record whether the option ever can take a value."
(let ((argument-ls (car pair)) (let ((argument-ls (car pair))
(alist (cdr pair))) (alist (cdr pair)))
(iter argument-ls alist rest-ls)) (iter argument-ls alist rest-ls))
(let ((pair (process-long-option specifications argument-ls alist))) (let ((pair (process-long-option
specifications argument-ls alist)))
(if pair (if pair
(let ((argument-ls (car pair)) (let ((argument-ls (car pair))
(alist (cdr pair))) (alist (cdr pair)))
@ -659,11 +716,12 @@ to add a 'single-char' clause to the option description."
(let* ((opt-pair (process-options specifications split-ls)) (let* ((opt-pair (process-options specifications split-ls))
(alist (car opt-pair)) (alist (car opt-pair))
(rest-ls (append (cdr opt-pair) non-split-ls))) (rest-ls (append (cdr opt-pair) non-split-ls)))
;; loop through the returned alist, and set the values into the specifications ;; loop through returned alist, set values into specifications
(for-each (lambda (pair) (for-each (lambda (pair)
(let* ((key (car pair)) (let* ((key (car pair))
(val (cdr pair)) (val (cdr pair))
(spec (find-if (lambda (spec) (eq? key (option-spec->name spec))) (spec (find-if (lambda (spec)
(eq? key (option-spec->name spec)))
specifications))) specifications)))
(if spec (set-option-spec-value! spec val)))) (if spec (set-option-spec-value! spec val))))
alist) alist)