ice-9/getopt-long.scm

   1 ;;; Author: Russ McManus
   2 ;;; $Id: getopt-long.scm,v 1.2 1999-02-15 12:53:10 jimb Exp $
   3 ;;;
   4 ;;; Copyright (C) 1998 FSF
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 2 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with this program; if not, write to the Free Software
  18 ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19 ;;;
  20 ;;; This module implements some complex command line option parsing, in
  21 ;;; the spirit of the GNU C library function 'getopt_long'.  Both long
  22 ;;; and short options are supported.
  23 ;;;
  24 ;;; The theory is that people should be able to constrain the set of
  25 ;;; options they want to process using a grammar, rather than some arbitrary
  26 ;;; structure.  The grammar makes the option descriptions easy to read.
  27 ;;;
  28
  29 ;;; getopt-long is a function for parsing command-line arguments in a
  30 ;;; manner consistent with other GNU programs.
  31
  32 ;;; (getopt-long ARGS GRAMMAR)
  33 ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
  34 ;;;
  35 ;;; ARGS should be a list of strings.  Its first element should be the
  36 ;;; name of the program; subsequent elements should be the arguments
  37 ;;; that were passed to the program on the command line.  The
  38 ;;; `program-arguments' procedure returns a list of this form.
  39 ;;;
  40 ;;; GRAMMAR is a list of the form:
  41 ;;; ((OPTION (PROPERTY VALUE) ...) ...)
  42 ;;;
  43 ;;; Each OPTION should be a symbol.  `getopt-long' will accept a
  44 ;;; command-line option named `--OPTION'.
  45 ;;; Each option can have the following (PROPERTY VALUE) pairs:
  46 ;;;
  47 ;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
  48 ;;;             equivalent to `--OPTION'.  This is how to specify traditional
  49 ;;;             Unix-style flags.
  50 ;;;   (required? BOOL) --- If BOOL is true, the option is required.
  51 ;;;             getopt-long will raise an error if it is not found in ARGS.
  52 ;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
  53 ;;;             it is #f, it does not; and if it is the symbol
  54 ;;;             `optional', the option may appear in ARGS with or
  55 ;;;             without a value.
  56 ;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
  57 ;;;             specified `(value #t)' for this option), then getopt
  58 ;;;             will apply FUNC to the value, and throw an exception
  59 ;;;             if it returns #f.  FUNC should be a procedure which
  60 ;;;             accepts a string and returns a boolean value; you may
  61 ;;;             need to use quasiquotes to get it into GRAMMAR.
  62 ;;;
  63 ;;; The (PROPERTY VALUE) pairs may occur in any order, but each
  64 ;;; property may occur only once.  By default, options do not have
  65 ;;; single-character equivalents, are not required, and do not take
  66 ;;; values.
  67 ;;;
  68 ;;; In ARGS, single-character options may be combined, in the usual
  69 ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
  70 ;;; accepts values, then it must be the last option in the
  71 ;;; combination; the value is the next argument.  So, for example, using
  72 ;;; the following grammar:
  73 ;;;      ((apples    (single-char #\a))
  74 ;;;       (blimps    (single-char #\b) (value #t))
  75 ;;;       (catalexis (single-char #\c) (value #t)))
  76 ;;; the following argument lists would be acceptable:
  77 ;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
  78 ;;;                                         for "blimps" and "catalexis")
  79 ;;;    ("-ab" "bang" "-c" "couth")         (same)
  80 ;;;    ("-ac" "couth" "-b" "bang")         (same)
  81 ;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
  82 ;;;                                         last option in its combination)
  83 ;;;
  84 ;;; If an option's value is optional, then `getopt-long' decides
  85 ;;; whether it has a value by looking at what follows it in ARGS.  If
  86 ;;; the next element is a string, and it does not appear to be an
  87 ;;; option itself, then that string is the option's value.
  88 ;;;
  89 ;;; The value of a long option can appear as the next element in ARGS,
  90 ;;; or it can follow the option name, separated by an `=' character.
  91 ;;; Thus, using the same grammar as above, the following argument lists
  92 ;;; are equivalent:
  93 ;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
  94 ;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
  95 ;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
  96 ;;;
  97 ;;; If the option "--" appears in ARGS, argument parsing stops there;
  98 ;;; subsequent arguments are returned as ordinary arguments, even if
  99 ;;; they resemble options.  So, in the argument list:
 100 ;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
 101 ;;; `getopt-long' will recognize the `apples' option as having the
 102 ;;; value "Granny Smith", but it will not recognize the `blimp'
 103 ;;; option; it will return the strings "--blimp" and "Goodyear" as
 104 ;;; ordinary argument strings.
 105 ;;;
 106 ;;; The `getopt-long' function returns the parsed argument list as an
 107 ;;; assocation list, mapping option names --- the symbols from GRAMMAR
 108 ;;; --- onto their values, or #t if the option does not accept a value.
 109 ;;; Unused options do not appear in the alist.
 110 ;;;
 111 ;;; All arguments that are not the value of any option are returned
 112 ;;; as a list, associated with the empty list.
 113 ;;;
 114 ;;; `getopt-long' throws an exception if:
 115 ;;; - it finds an unrecognized option in ARGS
 116 ;;; - a required option is omitted
 117 ;;; - an option that requires an argument doesn't get one
 118 ;;; - an option that doesn't accept an argument does get one (this can
 119 ;;;   only happen using the long option `--opt=value' syntax)
 120 ;;; - an option predicate fails
 121 ;;;
 122 ;;; So, for example:
 123 ;;;
 124 ;;; (define grammar
 125 ;;;   `((lockfile-dir (required? #t)
 126 ;;;                   (value #t)
 127 ;;;                   (single-char #\k)
 128 ;;;                   (predicate ,file-is-directory?))
 129 ;;;     (verbose (required? #f)
 130 ;;;              (single-char #\v)
 131 ;;;              (value #f))
 132 ;;;     (x-includes (single-char #\x))
 133 ;;;     (rnet-server (single-char #\y)
 134 ;;;                  (predicate ,string?))))
 135 ;;;
 136 ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
 137 ;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
 138 ;;;                grammar)
 139 ;;; => ((() "foo1" "-fred" "foo2" "foo3")
 140 ;;;     (rnet-server . "lamprod")
 141 ;;;     (x-includes . "/usr/include")
 142 ;;;     (lockfile-dir . "/tmp")
 143 ;;;     (verbose . #t))
 144
 145
 146 (define-module (ice-9 getopt-long)
 147   :use-module (ice-9 common-list))
 148 ;;; end-header
 149
 150 \f
 151 ;;; The code on this page was expanded by hand using the following code:
 152 ;;; (pretty-print
 153 ;;;  (macroexpand
 154 ;;;   '(define-record option-spec
 155 ;;;      (name
 156 ;;;       value
 157 ;;;       value-required?
 158 ;;;       single-char
 159 ;;;       predicate-ls
 160 ;;;       parse-ls))))
 161 ;;;
 162 ;;; This avoids the need to load slib for records.
 163 (define slib:error error)
 164 (begin (define
 165          option-spec->name
 166          (lambda
 167            (obj)
 168            (if (option-spec? obj)
 169                (vector-ref obj 1)
 170                (slib:error
 171                  (quote option-spec->name)
 172                  ": bad record"
 173                  obj))))
 174        (define
 175          option-spec->value
 176          (lambda
 177            (obj)
 178            (if (option-spec? obj)
 179                (vector-ref obj 2)
 180                (slib:error
 181                  (quote option-spec->value)
 182                  ": bad record"
 183                  obj))))
 184        (define
 185          option-spec->value-required?
 186          (lambda
 187            (obj)
 188            (if (option-spec? obj)
 189                (vector-ref obj 3)
 190                (slib:error
 191                  (quote option-spec->value-required?)
 192                  ": bad record"
 193                  obj))))
 194        (define
 195          option-spec->single-char
 196          (lambda
 197            (obj)
 198            (if (option-spec? obj)
 199                (vector-ref obj 4)
 200                (slib:error
 201                  (quote option-spec->single-char)
 202                  ": bad record"
 203                  obj))))
 204        (define
 205          option-spec->predicate-ls
 206          (lambda
 207            (obj)
 208            (if (option-spec? obj)
 209                (vector-ref obj 5)
 210                (slib:error
 211                  (quote option-spec->predicate-ls)
 212                  ": bad record"
 213                  obj))))
 214        (define
 215          option-spec->parse-ls
 216          (lambda
 217            (obj)
 218            (if (option-spec? obj)
 219                (vector-ref obj 6)
 220                (slib:error
 221                  (quote option-spec->parse-ls)
 222                  ": bad record"
 223                  obj))))
 224        (define
 225          set-option-spec-name!
 226          (lambda
 227            (obj val)
 228            (if (option-spec? obj)
 229                (vector-set! obj 1 val)
 230                (slib:error
 231                  (quote set-option-spec-name!)
 232                  ": bad record"
 233                  obj))))
 234        (define
 235          set-option-spec-value!
 236          (lambda
 237            (obj val)
 238            (if (option-spec? obj)
 239                (vector-set! obj 2 val)
 240                (slib:error
 241                  (quote set-option-spec-value!)
 242                  ": bad record"
 243                  obj))))
 244        (define
 245          set-option-spec-value-required?!
 246          (lambda
 247            (obj val)
 248            (if (option-spec? obj)
 249                (vector-set! obj 3 val)
 250                (slib:error
 251                  (quote set-option-spec-value-required?!)
 252                  ": bad record"
 253                  obj))))
 254        (define
 255          set-option-spec-single-char!
 256          (lambda
 257            (obj val)
 258            (if (option-spec? obj)
 259                (vector-set! obj 4 val)
 260                (slib:error
 261                  (quote set-option-spec-single-char!)
 262                  ": bad record"
 263                  obj))))
 264        (define
 265          set-option-spec-predicate-ls!
 266          (lambda
 267            (obj val)
 268            (if (option-spec? obj)
 269                (vector-set! obj 5 val)
 270                (slib:error
 271                  (quote set-option-spec-predicate-ls!)
 272                  ": bad record"
 273                  obj))))
 274        (define
 275          set-option-spec-parse-ls!
 276          (lambda
 277            (obj val)
 278            (if (option-spec? obj)
 279                (vector-set! obj 6 val)
 280                (slib:error
 281                  (quote set-option-spec-parse-ls!)
 282                  ": bad record"
 283                  obj))))
 284        (define
 285          option-spec?
 286          (lambda
 287            (obj)
 288            (and (vector? obj)
 289                 (= (vector-length obj) 7)
 290                 (eq? (vector-ref obj 0) (quote option-spec)))))
 291        (define
 292          make-option-spec
 293          (lambda
 294            (option-spec->name
 295              option-spec->value
 296              option-spec->value-required?
 297              option-spec->single-char
 298              option-spec->predicate-ls
 299              option-spec->parse-ls)
 300            (vector
 301              (quote option-spec)
 302              option-spec->name
 303              option-spec->value
 304              option-spec->value-required?
 305              option-spec->single-char
 306              option-spec->predicate-ls
 307              option-spec->parse-ls))))
 308
 309 \f
 310 ;;;
 311 ;;; parse functions go on this page.
 312 ;;;
 313 (define make-user-predicate
 314   (lambda (pred)
 315     (lambda (spec)
 316       (let ((val (option-spec->value spec)))
 317         (if (and val
 318                  (pred val)) #t
 319                  (error "option predicate failed:" (option-spec->name spec)))))))
 320
 321 (define make-not-allowed-value-fn
 322   (lambda ()
 323     (lambda (spec)
 324       (let ((val (option-spec->value spec)))
 325         (if (not (or (eq? val #t)
 326                      (eq? val #f)))
 327             (let ((name (option-spec->name spec)))
 328               (error "option does not support argument:" name)))))))
 329
 330 (define make-option-required-predicate
 331   (lambda ()
 332     (lambda (spec)
 333       (let ((val (option-spec->value spec)))
 334         (if (not val)
 335             (let ((name (option-spec->name spec)))
 336               (error "option must be specified:" name)))))))
 337
 338 (define make-option-value-predicate
 339   (lambda (predicate)
 340     (lambda (spec)
 341       (let ((val (option-spec->value spec)))
 342         (if (not (predicate val))
 343             (let ((name (option-spec->name spec)))
 344               (error "Bad option value:" name val)))))))
 345
 346 (define make-required-value-fn
 347   (lambda ()
 348     (lambda (spec)
 349       (let ((val (option-spec->value spec)))
 350         (if (eq? val #t)
 351             (let ((name (option-spec->name spec)))
 352               (error "option must be specified with argument:" name)))))))
 353
 354 (define single-char-value?
 355   (lambda (val)
 356     (char? val)))
 357
 358 (define (parse-option-spec desc)
 359   (letrec ((parse-iter
 360             (lambda (spec)
 361               (let ((parse-ls (option-spec->parse-ls spec)))
 362                 (if (null? parse-ls)
 363                     spec
 364                     (let ((ls (car parse-ls)))
 365                       (if (or (not (list? ls))
 366                               (not (= (length ls) 2)))
 367                           (error "Bad option specification:" ls))
 368                       (let ((key (car ls))
 369                             (val (cadr ls)))
 370                         (cond ((and (eq? key 'required?) val)
 371                                ;; required values are implemented as a predicate
 372                                (parse-iter (make-option-spec (option-spec->name spec)
 373                                                              (option-spec->value spec)
 374                                                              (option-spec->value-required? spec)
 375                                                              (option-spec->single-char spec)
 376                                                              (cons (make-option-required-predicate)
 377                                                                    (option-spec->predicate-ls spec))
 378                                                              (cdr parse-ls))))
 379                               ;; if the value is not required, then don't add a predicate,
 380                               ((eq? key 'required?)
 381                                (parse-iter (make-option-spec (option-spec->name spec)
 382                                                              (option-spec->value spec)
 383                                                              (option-spec->value-required? spec)
 384                                                              (option-spec->single-char spec)
 385                                                              (option-spec->predicate-ls spec)
 386                                                              (cdr parse-ls))))
 387                               ;; handle value specification
 388                               ((eq? key 'value)
 389                                (cond ((eq? val #t)
 390                                       ;; when value is required, add a predicate to that effect
 391                                       ;; and record the fact in value-required? field.
 392                                       (parse-iter (make-option-spec (option-spec->name spec)
 393                                                                     (option-spec->value spec)
 394                                                                     #t
 395                                                                     (option-spec->single-char spec)
 396                                                                     (cons (make-required-value-fn)
 397                                                                           (option-spec->predicate-ls spec))
 398                                                                     (cdr parse-ls))))
 399                                      ((eq? val #f)
 400                                       ;; when the value is not allowed, add a predicate to that effect.
 401                                       ;; one can detect that a value is not supplied by checking the option
 402                                       ;; value against #f.
 403                                       (parse-iter (make-option-spec (option-spec->name spec)
 404                                                                     (option-spec->value spec)
 405                                                                     #f
 406                                                                     (option-spec->single-char spec)
 407                                                                     (cons (make-not-allowed-value-fn)
 408                                                                           (option-spec->predicate-ls spec))
 409                                                                     (cdr parse-ls))))
 410                                      ((eq? val 'optional)
 411                                       ;; for optional values, don't add a predicate.  do, however
 412                                       ;; put the value 'optional in the value-required? field.  this
 413                                       ;; setting checks whether optional values are 'greedy'.  set
 414                                       ;; to #f to make optional value clauses 'non-greedy'.
 415
 416                                       (parse-iter (make-option-spec (option-spec->name spec)
 417                                                                     (option-spec->value spec)
 418                                                                     'optional
 419                                                                     (option-spec->single-char spec)
 420                                                                     (option-spec->predicate-ls spec)
 421                                                                     (cdr parse-ls))))
 422                                      (#t
 423                                       ;; error case
 424                                       (error "Bad value specification for option:" (cons key val)))))
 425                               ;; specify which single char is defined for this option.
 426                               ((eq? key 'single-char)
 427                                (if (not (single-char-value? val))
 428                                    (error "Not a single-char-value:" val " for option:" key)
 429                                    (parse-iter (make-option-spec (option-spec->name spec)
 430                                                                  (option-spec->value spec)
 431                                                                  (option-spec->value-required? spec)
 432                                                                  val
 433                                                                  (option-spec->predicate-ls spec)
 434                                                                  (cdr parse-ls)))))
 435                               ((eq? key 'predicate)
 436                                (if (procedure? val)
 437                                    (parse-iter (make-option-spec (option-spec->name spec)
 438                                                                  (option-spec->value spec)
 439                                                                  (option-spec->value-required? spec)
 440                                                                  (option-spec->single-char spec)
 441                                                                  (cons (make-user-predicate val)
 442                                                                        (option-spec->predicate-ls spec))
 443                                                                  (cdr parse-ls)))
 444                                    (error "Bad predicate specified for option:" (cons key val))))))))))))
 445     (if (or (not (pair? desc))
 446             (string? (car desc)))
 447         (error "Bad option specification:" desc))
 448     (parse-iter (make-option-spec (car desc)
 449                                   #f
 450                                   #f
 451                                   #f
 452                                   '()
 453                                   (cdr desc)))))
 454
 455 \f
 456 ;;;
 457 ;;;
 458 ;;;
 459 (define (split-arg-list argument-list)
 460   "Given an ARGUMENT-LIST, decide which part to process for options.
 461 Everything before an arg of \"--\" is fair game, everything after it
 462 should not be processed.  The \"--\" is discarded.  A cons pair is
 463 returned whose car is the list to process for options, and whose cdr
 464 is the list to not process."
 465   (let loop ((process-ls '())
 466              (not-process-ls argument-list))
 467     (cond ((null? not-process-ls)
 468            (cons (reverse process-ls) '()))
 469           ((string=? "--" (car not-process-ls))
 470            (cons (reverse process-ls) (cdr not-process-ls)))
 471           (#t
 472            (loop (cons (car not-process-ls) process-ls)
 473                  (cdr not-process-ls))))))
 474
 475 (define short-opt-rx (make-regexp "^-([a-zA-Z]+)"))
 476 (define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
 477 (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
 478
 479 (define (single-char-expander specifications opt-ls)
 480   "Expand single letter options that are mushed together."
 481   (let ((response #f))
 482     (define (is-short-opt? str)
 483       (set! response (regexp-exec short-opt-rx str))
 484       response)
 485     (define (iter opt-ls ret-ls)
 486       (cond ((null? opt-ls)
 487              (reverse ret-ls))
 488             ((is-short-opt? (car opt-ls))
 489              (let* ((orig-str (car opt-ls))
 490                     (match-pair (vector-ref response 2))
 491                     (match-str (substring orig-str (car match-pair) (cdr match-pair))))
 492                (if (= (string-length match-str) 1)
 493                    (iter (cdr opt-ls)
 494                          (cons (string-append "-" match-str) ret-ls))
 495                    (iter (cons (string-append "-" (substring match-str 1)) (cdr opt-ls))
 496                          (cons (string-append "-" (substring match-str 0 1)) ret-ls)))))
 497             (#t (iter (cdr opt-ls)
 498                       (cons (car opt-ls) ret-ls)))))
 499     (iter opt-ls '())))
 500
 501 (define (process-short-option specifications argument-ls alist)
 502   "Process a single short option that appears at the front of the ARGUMENT-LS,
 503 according to SPECIFICATIONS.  Returns #f is there is no such argument.  Otherwise
 504 returns a pair whose car is the list of remaining arguments, and whose cdr is a
 505 new association list, constructed by adding a pair to the supplied ALIST.
 506 The pair on the front of the returned association list describes the  option
 507 found at the head of ARGUMENT-LS.  The way this routine currently works, an
 508 option that never takes a value that is followed by a non option will cause
 509 an error, which is probably a bug.  To fix the bug the option specification
 510 needs to record whether the option ever can take a value."
 511   (define (short-option->char option)
 512     (string-ref option 1))
 513   (define (is-short-option? option)
 514     (regexp-exec short-opt-rx option))
 515   (define (is-long-option? option)
 516     (or (regexp-exec long-opt-with-value-rx option)
 517         (regexp-exec long-opt-no-value-rx option)))
 518   (define (find-matching-spec option)
 519     (let ((key (short-option->char option)))
 520       (find-if (lambda (spec) (eq? key (option-spec->single-char spec))) specifications)))
 521   (let ((option (car argument-ls)))
 522     (if (is-short-option? option)
 523         (let ((spec (find-matching-spec option)))
 524           (if spec
 525               (let* ((next-value (if (null? (cdr argument-ls)) #f (cadr argument-ls)))
 526                      (option-value (if (and next-value
 527                                             (not (is-short-option? next-value))
 528                                             (not (is-long-option? next-value))
 529                                             (option-spec->value-required? spec))
 530                                        next-value
 531                                        #t))
 532                      (new-alist (cons (cons (option-spec->name spec) option-value) alist)))
 533                 (cons (if (eq? option-value #t)
 534                           (cdr argument-ls)   ; there was one value specified, skip just one
 535                           (cddr argument-ls)) ; there must have been a value specified, skip two
 536                       new-alist))
 537               (error "No such option:" option)))
 538         #f)))
 539
 540 (define (process-long-option specifications argument-ls alist)
 541   (define (find-matching-spec key)
 542     (find-if (lambda (spec) (eq? key (option-spec->name spec))) specifications))
 543   (define (split-long-option option)
 544     ;; returns a pair whose car is a symbol naming the option, cdr is
 545     ;; the option value.  as a special case, if the option value is
 546     ;; #f, then the caller should use the next item in argument-ls as
 547     ;; the option value.
 548     (let ((resp (regexp-exec long-opt-no-value-rx option)))
 549       (if resp
 550           ;; Aha, we've found a long option without an equal sign.
 551           ;; Maybe we need to grab a value from argument-ls.  To find
 552           ;; out we need to refer to the option-spec.
 553           (let* ((key-pair (vector-ref resp 2))
 554                  (key (string->symbol (substring option (car key-pair) (cdr key-pair))))
 555                  (spec (find-matching-spec key)))
 556             (cons key (if (option-spec->value-required? spec) #f #t)))
 557           (let ((resp (regexp-exec long-opt-with-value-rx option)))
 558             ;; Aha, we've found a long option with an equal sign.  The
 559             ;; option value is simply the value to the right of the
 560             ;; equal sign.
 561             (if resp
 562                 (let* ((key-pair (vector-ref resp 2))
 563                        (key (string->symbol (substring option (car key-pair) (cdr key-pair))))
 564                        (value-pair (vector-ref resp 3))
 565                        (value (substring option (car value-pair) (cdr value-pair))))
 566                   (cons key value))
 567                   #f)))))
 568   (let* ((option (car argument-ls))
 569          (pair (split-long-option option)))
 570     (cond ((and pair (eq? (cdr pair) #f))
 571            (if (null? (cdr argument-ls))
 572                (error "Not enough options.")
 573                (cons (cddr argument-ls)
 574                      (cons (cons (car pair) (cadr argument-ls)) alist))))
 575           (pair
 576            (cons (cdr argument-ls) (cons pair alist)))
 577           (else #f))))
 578
 579 (define (process-options specifications argument-ls)
 580   (define (iter argument-ls alist rest-ls)
 581     (if (null? argument-ls)
 582         (cons alist (reverse rest-ls))
 583         (let ((pair (process-short-option specifications argument-ls alist)))
 584           (if pair
 585               (let ((argument-ls (car pair))
 586                     (alist (cdr pair)))
 587                 (iter argument-ls alist rest-ls))
 588               (let ((pair (process-long-option specifications argument-ls alist)))
 589                 (if pair
 590                     (let ((argument-ls (car pair))
 591                           (alist (cdr pair)))
 592                       (iter argument-ls alist rest-ls))
 593                     (iter (cdr argument-ls)
 594                           alist
 595                           (cons (car argument-ls) rest-ls))))))))
 596   (iter argument-ls '() '()))
 597
 598 (define (getopt-long program-arguments option-desc-list)
 599   "Process options, handling both long and short options, similar to
 600 the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
 601 similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
 602 list of option descriptions.  Each option description must satisfy the
 603 following grammar:
 604
 605     <option-spec>           :: (<name> . <attribute-ls>)
 606     <attribute-ls>          :: (<attribute> . <attribute-ls>)
 607                                | ()
 608     <attribute>             :: <required-attribute>
 609                                | <arg-required-attribute>
 610                                | <single-char-attribute>
 611                                | <predicate-attribute>
 612                                | <value-attribute>
 613     <required-attribute>    :: (required? <boolean>)
 614     <single-char-attribute> :: (single-char <char>)
 615     <value-attribute>       :: (value #t)
 616                                (value #f)
 617                                (value optional)
 618     <predicate-attribute>   :: (predicate <1-ary-function>)
 619
 620     The procedure returns an alist of option names and values.  Each
 621 option name is a symbol.  The option value will be '#t' if no value
 622 was specified.  There is a special item in the returned alist with a
 623 key of the empty list, (): the list of arguments that are not options
 624 or option values.
 625     By default, options are not required, and option values are not
 626 required.  By default, single character equivalents are not supported;
 627 if you want to allow the user to use single character options, you need
 628 to add a 'single-char' clause to the option description."
 629   (let* ((specifications (map parse-option-spec option-desc-list))
 630          (pair (split-arg-list (cdr program-arguments)))
 631          (split-ls (single-char-expander specifications (car pair)))
 632          (non-split-ls (cdr pair)))
 633     (let* ((opt-pair (process-options specifications split-ls))
 634            (alist (car opt-pair))
 635            (rest-ls (append (cdr opt-pair) non-split-ls)))
 636       ;; loop through the returned alist, and set the values into the specifications
 637       (for-each (lambda (pair)
 638                   (let* ((key (car pair))
 639                          (val (cdr pair))
 640                          (spec (find-if (lambda (spec) (eq? key (option-spec->name spec)))
 641                                         specifications)))
 642                     (if spec (set-option-spec-value! spec val))))
 643                 alist)
 644       ;; now fire all the predicates
 645       (for-each (lambda (spec)
 646                   (let ((predicate-ls (option-spec->predicate-ls spec)))
 647                     (for-each (lambda (predicate)
 648                                 (predicate spec))
 649                               predicate-ls)))
 650                 specifications)
 651       (cons (cons '() rest-ls) alist))))
 652
 653 (define (option-ref options key default)
 654   "Look for an option value in OPTIONS using KEY.  If no such value is
 655 found, return DEFAULT."
 656   (let ((pair (assq key options)))
 657     (if pair
 658         (cdr pair)
 659         default)))
 660
 661 (export option-ref)
 662 (export getopt-long)