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]

`get-options.scm': from the don't patch before coffee department.



 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)))
 			    )))
 		  ))