This is the mail archive of the guile@cygnus.com mailing list for the guile project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
If there's any more I'll go hide under a rock. Don't apply the last one; 1.8 is my working copy now. Also at: http://www.inetarena.com/~karlheg/get-options.scm Sorry for the clutter on the list, folks. Index: get-options.scm =================================================================== RCS file: /usr/local/cvsroot/debian/guile-core/ice-9/get-options.scm,v retrieving revision 1.6 retrieving revision 1.8 diff -u -u -r1.6 -r1.8 --- get-options.scm 1998/09/15 09:18:53 1.6 +++ get-options.scm 1998/09/15 16:25:23 1.8 @@ -1,6 +1,6 @@ ;;; get-options.scm -- Parse a command line option list. -;;; $Id: get-options.scm,v 1.6 1998/09/15 09:18:53 karlheg Exp $ +;;; $Id: get-options.scm,v 1.8 1998/09/15 16:25:23 karlheg Exp $ ;;; Written by: Karl M. Hegbloom <karlheg@debian.org> ;;; Copyright (c) 1998, Free Software Foundation @@ -208,7 +208,7 @@ ;;; ;;; `get-options' will never throw an error (barring bugs, of course) ;;; except in the case where you've tried to specify an invalid -;;; option type. +;;; option type or an invalid option specifier string. ;;; ;;; Please read the source; I'm proud of it. :-) ;;; @@ -235,7 +235,7 @@ "")) "^--[^=]+=)(.*)$")))) (let next-arg ((arg-ls arg-ls)) -;; (debug "top of next-arg, arg-ls" arg-ls) +;;; (debug "top of next-arg, arg-ls" arg-ls) (cond ;; Top of `next-arg'. ((null? arg-ls) (reverse! ret-alist)) @@ -245,28 +245,36 @@ (else (letrec ((get-arg (lambda () -;; (debug "get-arg, this-arg" this-arg) -;; (debug "get-arg, arg-ls" arg-ls) +;;; (debug "get-arg, this-arg" this-arg) +;;; (debug "get-arg, arg-ls" arg-ls) (let ((arg (match:substring (regexp-exec grab-arg-regexp this-arg) 2))) (if (not (equal? "" arg)) arg (begin (set! arg-ls (cdr arg-ls)) -;; (debug "car arg-ls" (car arg-ls)) +;;; (debug "car arg-ls" (car arg-ls)) (car arg-ls)))))) (make-key-from-option-spec (lambda (spec-string) -;; (debug "make-key-from-option-spec, spec-string" spec-string) - (if (eq? #\: (string-ref spec-string 1)) - (string->symbol (substring spec-string 2)) +;;; (debug "make-key-from-option-spec, spec-string" spec-string) +;;; (debug "string-length spec-string" (string-length spec-string)) + (if (and (> (string-length spec-string) 1) + (eq? #\: (string-ref spec-string 1))) + (if (< (string-length spec-string) 3) + (scm-error 'invalid-option-spec + "get-options, make-key-from-option-spec" + "Invalid option spec: %s" + spec-string + #f) + (string->symbol (substring spec-string 2))) (string->symbol spec-string)))) (this-arg (car arg-ls)) (this-spec #f) (key #f) (keystring "") (val #f) (single-char-flag #f)) -;; (debug "string-length this-arg" (string-length this-arg)) +;;; (debug "string-length this-arg" (string-length this-arg)) (let next-i ((i 1)) -;; (debug "top of next-i, this-arg" this-arg) -;; (debug "i" i) -;; (debug "single-char-flag" single-char-flag) +;;; (debug "top of next-i, this-arg" this-arg) +;;; (debug "i" i) +;;; (debug "single-char-flag" single-char-flag) (if (> i (- (string-length this-arg) 1)) (next-arg (cdr arg-ls)) (let next-opt ((opts-spec opts-spec)) @@ -294,12 +302,12 @@ (next-arg (cdr arg-ls)))) (begin (set! this-spec (car opts-spec)) -;; (debug "this-spec" this-spec) + (debug "this-spec" this-spec) (set! key (make-key-from-option-spec (car this-spec))) -;; (debug "key" key) + (debug "key" key) (set! keystring (symbol->string key)) -;; (debug "keystring" keystring) -;; (debug "i" i) + (debug "keystring" keystring) +;;; (debug "i" i) (if (not (or (and (eq? #\- (string-ref this-arg 0)) (eq? #\- (string-ref this-arg 1)) (begin (set! single-char-flag #f) #t) @@ -309,8 +317,8 @@ this-arg)) (and (eq? #\- (string-ref this-arg 0)) (begin (set! single-char-flag #t) #t) -;; (debug "this-arg i" (string-ref this-arg i)) -;; (debug "single-char-flag" single-char-flag) +;;; (debug "this-arg i" (string-ref this-arg i)) +;;; (debug "single-char-flag" single-char-flag) (eq? (string-ref this-arg i) (string-ref (car this-spec) 0))) (and single-char-flag (eq? (string-ref this-arg i) (string-ref (car this-spec) 0))))) @@ -352,7 +360,11 @@ (next-arg (cdr arg-ls))) (else - (scm-error 'unknown-type "get-options" "Unknown argument type: ~s" (cadr this-spec)))) + (scm-error 'unknown-type + "get-options" + "Unknown argument type: %s" + (cadr this-spec) + #f))) ))) ))