source: project/release/4/getopt-long/trunk/getopt-long.scm @ 27821

Last change on this file since 27821 was 27821, checked in by Ivan Raikov, 8 years ago

getopt-long: some tweaks in processing of options with multiple sub-arguments

File size: 23.7 KB
Line 
1;;
2;; getopt-style command-line parser
3;;
4;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
5;;
6;; Ported to Chicken Scheme and extensively modified by Ivan Raikov.
7;;
8;; Copyright 2009-2012 Ivan Raikov.
9;;
10;; Portions copyright (C) 1998, 2001, 2006 Free Software Foundation,
11;; Inc.
12;;
13;; This program is free software: you can redistribute it and/or
14;; modify it under the terms of the GNU Lesser General Public License
15;; as published by the Free Software Foundation, either version 3 of
16;; the License, or (at your option) any later version.
17;;
18;; This program is distributed in the hope that it will be useful, but
19;; WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21;; General Public License for more details.
22;;
23;; A full copy of the Lesser GPL license can be found at
24;; <http://www.gnu.org/licenses/>.
25;;
26
27;;; Commentary:
28
29;;; This module implements command line option parsing, in the spirit
30;;; of the GNU C library function `getopt_long'.  Both long and short
31;;; options are supported.
32;;;
33;;; The theory is that people should be able to constrain the set of
34;;; options they want to process using a grammar, rather than some
35;;; arbitrary structure.  The grammar makes the option descriptions
36;;; easy to read.
37;;;
38;;; `getopt-long' is a procedure for parsing command-line arguments in
39;;; a manner consistent with GNU programs.
40;;;
41;;; `usage' is a procedure that prints help strings about the
42;;; command-line arguments defined in a grammar.
43
44;;; (getopt-long ARGS GRAMMAR) Parse the arguments ARGS according to
45;;; the argument list grammar GRAMMAR.
46;;;
47;;; ARGS should be a list of strings.  Its first element should be the
48;;; name of the program; subsequent elements should be the arguments
49;;; that were passed to the program on the command line.  The
50;;; `program-arguments' procedure returns a list of this form.
51;;;
52;;; GRAMMAR is a list of the form:
53;;; ((OPTION-NAME [DOCSTRING]
54;;;               (PROPERTY VALUE) ...) ...)
55;;;
56;;; Each OPTION-NAME should be a symbol.  `getopt-long' will accept a
57;;; command-line option named `--OPTION-NAME'.
58;;;
59;;  If DOCSTRING is provided, it must be a either string a string
60;;  containing a brief description of the option.
61;;;
62;;; Each option can have the following (PROPERTY VALUE) pairs:
63;;;
64;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
65;;;             equivalent to `--OPTION'.  This is how to specify traditional
66;;;             Unix-style flags.
67;;;
68;;;   (required BOOL) --- If BOOL is true, the option is required.
69;;;             getopt-long will raise an error if it is not found in ARGS.
70;;;
71;;;   (multiple BOOL) --- If BOOL is true, this option can be specified
72;;              multiple times. The default is false.
73;;;
74;;;   (value FLAG [(PROPERTY VALUE) ...])
75;;;             --- If FLAG is #t, the option requires a value; if
76;;;             it is #f, it does not;
77;;;             if it is of the form (REQUIRED name) then the option requires
78;;;             and the name is used by the usage procedure
79;;;             if it is of the form (OPTIONAL name) the option may
80;;;             appear with or without a (named) value.
81;;;             
82;;;             In addition, the following properties can be defined
83;;;             for a value:
84;;;
85;;;            (predicate FUNC) ---
86;;;
87;;;                  If the option accepts a value, then getopt will
88;;;                  apply FUNC to the value, and throw an exception
89;;;                  if it returns #f.  FUNC should be a procedure
90;;;                  which accepts a string and returns a boolean
91;;;                  value; you may need to use quasiquotes to get it
92;;;                  into GRAMMAR.
93;;;
94;;;            (transformer FUNC) ---
95;;;
96;;;                  If the option accepts a value, then getopt will
97;;;                  apply FUNC to the string provided on the command
98;;;                  line, and put the resulting value in the list of
99;;;                  parsed options returned by getopt-long.
100;;;
101;;; The (PROPERTY VALUE) pairs may occur in any order, but each
102;;; property may occur only once.  By default, options do not have
103;;; single-character equivalents, are not required, and do not take
104;;; values.
105;;;
106;;; In ARGS, single-character options may be combined, in the usual
107;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
108;;; accepts values, then it must be the last option in the
109;;; combination; the value is the next argument.  So, for example, using
110;;; the following grammar:
111;;;
112;;;      ((apples    (single-char #\a))
113;;;       (blimps    (single-char #\b) (value #t))
114;;;       (catalexis (single-char #\c) (value #t)))
115;;;
116;;; the following argument lists would be acceptable:
117;;;
118;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
119;;;                                         for "blimps" and "catalexis")
120;;;    ("-ab" "bang" "-c" "couth")         (same)
121;;;    ("-ac" "couth" "-b" "bang")         (same)
122;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
123;;;                                         last option in its combination)
124;;;
125;;; If an option's value is optional, then `getopt-long' decides
126;;; whether it has a value by looking at what follows it in ARGS.  If
127;;; the next element is does not appear to be an option itself, then
128;;; that element is the option's value.
129;;;
130;;; The value of a long option can only follow the option name,
131;;; separated by an `=' character.
132;;;
133;;; If the option "--" appears in ARGS, argument parsing stops there;
134;;; subsequent arguments are returned as ordinary arguments, even if
135;;; they resemble options.  So, in the argument list:
136;;;
137;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
138;;;
139;;; `getopt-long' will recognize the `apples' option as having the
140;;; value "Granny Smith", but it will not recognize the `blimp'
141;;; option; it will return the strings "--blimp" and "Goodyear" as
142;;; ordinary argument strings.
143;;;
144;;; The `getopt-long' function returns the parsed argument list as an
145;;; assocation list, mapping option names --- the symbols from GRAMMAR
146;;; --- onto their values, or #t if the option does not accept a value.
147;;; Unused options do not appear in the alist.
148;;;
149;;; All arguments that are not the value of any option are returned
150;;; as a list, associated with the empty list.
151;;;
152;;; `getopt-long' throws an exception if:
153;;; - it finds an unrecognized property in GRAMMAR
154;;; - the value of the `single-char' property is not a character,
155;;;   or a single-character string/symbol
156;;; - it finds an unrecognized option in ARGS
157;;; - a required option is omitted
158;;; - an option that requires an argument doesn't get one
159;;; - an option that doesn't accept an argument does get one (this can
160;;;   only happen using the long option `--opt=value' syntax)
161;;; - an option predicate fails
162;;;
163;;; For an example, see file tests/run.scm.
164
165
166
167(module getopt-long
168
169        (getopt-long width separator indent usage make-option-dispatch)
170
171        (import scheme chicken)
172       
173        (require-extension data-structures srfi-1 srfi-13 srfi-14 matchable )
174
175(define (fetch-value kv) 
176  (match kv ((k v) v) (else (cdr kv))))
177
178(define (lookup-def k lst . rest)
179  (let-optionals rest ((default #f))
180      (let ((kv (assoc k lst)))
181        (if (not kv) default
182            (fetch-value kv)))))
183
184
185(define-record-type  unknown-option
186  (make-unknown-option name )
187  unknown-option?
188  (name        unknown-option-name)
189  )
190 
191
192(define-record-type  value-policy
193  (make-value-policy name predicate transformer optional? default )
194  value-policy?
195  (name        value-policy-name)
196  (predicate   value-policy-predicate)
197  (transformer value-policy-transformer)
198  (optional?   value-policy-optional?)
199  (default     value-policy-default))
200 
201
202(define-record-type option-spec
203  (make-option-spec name value required? single-char docstring multiple? )
204  option-spec?
205  (name         option-spec-name)
206  (value        option-spec-value)
207  (required?    option-spec-required?)
208  (single-char  option-spec-single-char)
209  (docstring    option-spec-docstring)
210  (multiple?    option-spec-multiple?))
211
212
213;;
214;; We don't auto-format the left column (the option keys) based on the
215;; length of the longest option, but you can override it manually.
216;;
217(define width (make-parameter 25))
218
219;; The separator used between options.  Default: ", "
220
221(define separator (make-parameter ", "))
222(define indent (make-parameter 1))
223
224(define (spaces n)
225  (let loop ((ls '()) (n n))
226    (if (<= n 0)
227        (list->string ls)
228        (loop (cons #\space ls)
229              (- n 1)))))
230
231;; Join together option names in spec with commas, and append the
232;; argument type and name
233
234(define-record-printer (option-spec x out)
235  (let* ((name          (option-spec-name x))
236         (value-policy  (option-spec-value x))
237         (required?     (option-spec-required? x))
238         (single-char   (option-spec-single-char x))
239         (docstring     (option-spec-docstring x))
240         (multiple?     (option-spec-multiple? x))
241         (long-option   (and (not (make-single-char name))
242                             (string-append "--" (->string name))))
243         (short-option  (or (and single-char 
244                                 (list->string (list #\- single-char)))
245                            (make-single-char name)))
246         (option-lst    (cond ((and short-option long-option)
247                               (list long-option (separator) short-option))
248                              (long-option
249                               (list long-option))
250                              (else (list short-option))))
251         (option-lst
252          (cond
253           (value-policy 
254            (if (value-policy-optional? value-policy) 
255                (cons* "]" (->string (value-policy-name value-policy) )
256                       "[" "=" option-lst)
257                (cons* (->string (value-policy-name value-policy))
258                       "=" 
259                       option-lst)))
260           (else        option-lst)))
261
262         (option-string (string-concatenate (reverse option-lst))))
263
264    (display
265     (string-append (spaces (indent))
266                    (string-pad-right option-string (width))
267                    docstring
268                    "\n")
269     out)))
270
271;; Generate a formatted list of options from OPTION-LIST, and return a
272;; string suitable for embedding into help text.  The single string
273;; consists of multiple lines, with a newline at the end of each line.
274;; Thus, a typical use would be (print (usage opts)).
275(define (usage opts) 
276  (let ((specs (map parse-option-spec opts)))
277    (apply string-append (map ->string specs))))
278
279(define update-option-spec
280  (lambda (x . key/values)
281    (apply
282     (lambda (#!key
283              (name           (option-spec-name x)) 
284              (required?      (option-spec-required? x))
285              (single-char    (option-spec-single-char x))
286              (value          (option-spec-value x))
287              (docstring      (option-spec-docstring x))
288              (multiple?      (option-spec-multiple? x))
289              )
290          (make-option-spec 
291           name
292           value
293           required?
294           single-char
295           docstring
296           multiple?
297           ))
298     key/values)))
299
300(define (make-predicate pred)
301  (lambda (name val)
302    (or (not val)
303        (pred val)
304        (error "option predicate failed" name))))
305
306(define (make-single-char x)
307  (let ((lst (string->list (->string x))))
308    (and (null? (cdr lst))
309         (car lst))))
310   
311
312(define (parse-option-spec desc)
313 
314  (let* ((name         (car desc))
315         (single-char  (make-single-char name))
316         (spec
317          (make-option-spec 
318           name
319           #f
320           #f
321           single-char
322           ""
323           #f
324           )))
325
326    (fold
327     (lambda (desc-elem spec)
328       (cond ((string? desc-elem)
329              (update-option-spec spec docstring: desc-elem))
330
331             (else
332              (let ((given (lambda () (cdr desc-elem))))
333
334                (case (car desc-elem)
335
336                  ((multiple)
337                   (update-option-spec spec multiple?: (car (given))))
338                 
339                  ((required)
340                   (update-option-spec spec required?: (car (given))))
341                 
342                  ((value)
343                   (let ((value-policy
344                          (match (given)
345
346                                 ((((and flag (or 'required 'optional))
347                                    (and name (or (? symbol?) (? string?)))) . rst)
348                                  (let ((predicate 
349                                         (cond ((lookup-def 'predicate rst) =>
350                                                make-predicate)
351                                               (else
352                                                (lambda x (identity x)))))
353
354                                        (transformer 
355                                         (or (lookup-def 'transformer rst)
356                                             identity))
357
358                                        (default (lookup-def 'default rst))
359                                        )
360
361                                    (make-value-policy 
362                                     name
363                                     predicate
364                                     transformer
365                                     (equal? flag 'optional)
366                                     (and default  (->string default))
367                                     )))
368
369                                 ((#t) (make-value-policy 
370                                      'ARG
371                                      (lambda x (identity x))
372                                      identity
373                                      #f
374                                      #f))
375
376                                 ((#f) #f)
377
378                                 (else (error "invalid value specification "
379                                              (given)))
380
381                                 )))
382                     (update-option-spec spec value: value-policy)))
383                 
384                  ((single-char)
385                   (cond
386                    ((make-single-char (car (given))) =>
387                     (lambda (c)
388                       (update-option-spec spec single-char: c)))
389                    (else
390                     (error "`single-char' value must be a single character, string, or symbol"))))
391
392                  (else
393                   (error "invalid getopt-long option property"
394                          (car desc-elem))))))))
395     spec (cdr desc))
396    ))
397
398
399
400(define (split-argument-list argument-list)
401  ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
402  ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
403  (let loop ((yes '()) (no argument-list))
404    (cond ((null? no)               (cons (reverse yes) no))
405          ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
406          (else (loop (cons (car no) yes) (cdr no))))))
407
408
409(define (check-long-option str)
410  (and (> (string-length str) 1)
411       (string=? (substring str 0 2) "--")))
412
413(define (check-short-option str)
414  (and (positive? (string-length str))
415       (string=? (substring str 0 1) "-")))
416
417(define long-option-name-cs 
418  (char-set-union char-set:letter
419                  (char-set #\-)))
420
421(define (long-option-name lst)
422  (let loop ((lst lst)  (ax (list)))
423    (cond ((null? lst)  (list (list->string (reverse ax)) lst))
424
425          ((and (char? (car lst))
426                (char-set-contains? long-option-name-cs 
427                                   (car lst))
428                (car lst) )
429           => (lambda (c) (loop (cdr lst) (cons c ax))))
430
431          ((char=? (car lst) #\=)
432           (list (list->string (reverse ax)) (cdr lst)))
433
434          (else (error 'long-option-name 
435                       "invalid list" lst)))))
436
437(define long-option-value-cs 
438  (char-set-union char-set:letter+digit 
439                  char-set:punctuation
440                  (char-set #\_ #\^ #\$ #\=)))
441
442(define (long-option-value lst)
443  (if (null? lst) (list #f lst)
444      (let loop ((lst lst)  (ax (list)))
445        (cond ((null? lst) 
446               (list (list->string (reverse ax)) lst))
447             
448              ((and (char? (car lst)) (car lst)) =>
449               (lambda (c)
450                 (cond ((char=? c #\")
451                        (let quote-loop ((lst (cdr lst)) (ax ax))
452                          (if (null? lst) (error 'long-option-value
453                                                 "unclosed option value quotation")
454                              (if (char=? (car lst) #\")
455                                  (loop (cdr lst) ax)
456                                  (quote-loop (cdr lst) (cons (car lst) ax))))))
457
458                       ((char-set-contains? char-set:blank c)
459                        (list (list->string (reverse ax)) (cdr lst)))
460
461                       ((char-set-contains? long-option-value-cs c)
462                        (loop (cdr lst) (cons c ax)))
463
464                       (else  (error 'long-option-value 
465                                     "invalid option character" c)))))
466             
467              (else (error 'long-option-value 
468                           "invalid list" lst))))))
469
470
471(define (long-option? specs a next)
472
473  (let ((l (string->list a)))
474    (match l
475           ((#\- #\-  . rst)
476            (match-let* (((n nrst)  (long-option-name rst))
477                         ((v _)     (let ((lv (long-option-value nrst)))
478                                      lv))
479                         ((next v)
480                          (begin
481                            (or (and v (list next v))
482                                (list next #f)))))
483
484                        (cond ((alist-ref (string->symbol n) (car specs)) =>
485                               (lambda (spec)
486                                 (cond
487                                 
488                                  ((and v (option-spec-value spec)) =>
489                                   (lambda (value-policy)
490                                     (or
491                                      (and ((or (value-policy-predicate value-policy)
492                                                (lambda x (identity x))) n v)
493                                           (let ((transformer
494                                                  (or (value-policy-transformer value-policy)
495                                                      identity)))
496                                             (list next (cons (option-spec-name spec) (transformer v)))))
497                                      (error 'long-option? 
498                                             "predicate error on option value" n))))
499                                 
500                                  ((and v (not (option-spec-value spec)))
501                                   (error 'long-option? 
502                                          "superfluous argument given to option" n))
503                                 
504                                  ((and (not v) (option-spec-value spec)
505                                        (value-policy-optional? 
506                                         (option-spec-value spec)))
507                                   (let* ((vp (option-spec-value spec))
508                                          (dflt  (value-policy-default vp))
509                                          (transformer (or (value-policy-transformer vp)
510                                                           identity))
511                                          (v (and dflt (transformer dflt))))
512                                       (list next (cons (option-spec-name spec) (or v #t)))))
513                                 
514                                  ((and (not v) (option-spec-value spec))
515                                   (error 'long-option? "option requires value" n))
516                                 
517                                  (else
518                                   (list next (cons (option-spec-name spec) #t)))
519                                 
520                                  )))
521                              (else
522                               (list next (make-unknown-option n))))))
523           (else #f))))
524
525
526(define short-option-name-cs 
527  char-set:letter)
528
529(define (short-option-names lst)
530  (if (null? lst) (list #f lst)
531      (let loop ((lst lst)  (ax (list)))
532        (cond ((null? lst)  (list ax lst))
533
534              ((and (char? (car lst))
535                    (char-set-contains? short-option-name-cs (car lst)) 
536                    (car lst)) =>
537                    (lambda (c) (loop (cdr lst) (cons c ax))))
538
539              (else (list ax lst))))))
540
541(define (short-options? specs a next)
542
543  (let ((l (string->list a)))
544    (match l
545           ((#\-  . rst)
546            (match-let ((((n1 . ns) _)  (short-option-names rst)))
547              (match-let
548               ;; special case: check if the last single-letter option
549               ;; has an argument
550               (((next opt1)
551                 (cond
552                  ((alist-ref n1 (cadr specs) ) =>
553                   (lambda (spec)
554                     (let ((name (option-spec-name spec)))
555
556                       (cond
557                        ((option-spec-value spec) =>
558                         (lambda (value-policy)
559                           (let ((v (and (pair? next)
560                                         (not (check-long-option (car next) ))
561                                         (not (check-short-option (car next) ))
562                                         (car next))))
563                                       
564                             (if (and (not v) (not (value-policy-optional? value-policy)))
565                                 (error 'short-options?  "option requires value" name))
566                             
567                             (if (not v) 
568                                 (list next (cons name (or (value-policy-default value-policy) #t)))
569                                 (or (and ((or (value-policy-predicate value-policy) 
570                                               (lambda x (identity x))) name v)
571                                          (let ((transformer
572                                                 (or (value-policy-transformer value-policy) 
573                                                     identity)))
574                                            (list (cdr next) (cons name (transformer v)))))
575                                 
576                                  (error 'short-options? 
577                                         "predicate error on option value" 
578                                         name))))))
579                                 
580                        (else
581                         (list next (cons name #t)))))))
582                  (else
583                   (list next (make-unknown-option (->string n1)))))))
584               (list next 
585                     (cons opt1 
586                           (map (lambda (n)
587                                  (cond
588                                   ((alist-ref n (cadr specs) ) =>
589                                    (lambda (spec)
590                                      (cond
591                                       ((option-spec-value spec)
592                                        (error 'short-options?
593                                               "option requires value" n))
594                                       
595                                       (else
596                                        (cons (option-spec-name spec) #t)))))
597                                   
598                                   (else
599                                    (make-unknown-option (->string n)))))
600                                ns)))))
601              )
602           (else #f))))
603           
604 
605 
606
607(define (process-options specs argument-ls)
608
609  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
610  ;; FOUND is an unordered list of option specs for found options, while ETC
611  ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
612  ;; options nor their values.
613
614  (let loop ((ls argument-ls)  (found (list)) (etc (list)) (unknown (list)))
615
616    (if (null? ls) 
617
618        (list found (reverse etc) (reverse unknown))
619
620        (let ((arg (car ls)) (rest (cdr ls)))
621
622          (cond ((long-option? specs arg rest) =>
623                 (lambda (next.val)
624                   (let ((optval (cadr next.val)))
625                     (if (unknown-option? optval)
626                         (loop (car next.val) found etc (cons optval unknown))
627                         (loop (car next.val) (cons optval found) etc unknown)))))
628               
629                ((short-options? specs arg rest) =>
630                 (lambda (next.vals)
631                   (let-values (((unknowns optvals) (partition unknown-option? (cadr next.vals))))
632                     (loop (car next.vals) (append optvals found) etc (append unknowns unknown)))))
633
634                (else
635                 (loop (cdr ls) found (cons (car ls) etc) unknown)))))))
636                                 
637
638
639(define (getopt-long program-arguments option-desc-list 
640                     #!key (unknown-option-handler (lambda (x) (error 'getopt-long "unknown options" x))))
641
642;;
643;; Process options, handling both long and short options, similar to
644;; the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a
645;; value similar to what (program-arguments) returns.
646;;
647;; OPTION-DESC-LIST is a list of option descriptions.  Each option
648;; description must satisfy the following grammar:
649;;
650;;     <option-spec>           :: (<name> . <attribute-ls>)
651;;     <attribute-ls>          :: (<attribute> . <attribute-ls>)
652;;                                | ()
653;;     <attribute>             :: <required-attribute>
654;;                                | <arg-required-attribute>
655;;                                | <single-char-attribute>
656;;                                | <value-attribute>
657;;     <required-attribute>    :: (required? <boolean>)
658;;     <single-char-attribute> :: (single-char <char>)
659;;     <value-attribute>       :: (value #t)
660;;                                (value #f)
661;;                                (value (required <name>))
662;;                                (value (optional <name>))
663;;                                (<value-attribute>
664;;                                 <predicate-attribute>)
665;;     <predicate-attribute>   :: (predicate <1-ary-function>)
666;;
667;;     The procedure returns an alist of option names and values.
668;; Each option name is a symbol.  The option value will be '#t' if no
669;; value was specified.  There is a special item in the returned alist
670;; with a key @: the list of arguments that are not options or option
671;; values.
672;;
673;;     By default, options are not required, and option values are not
674;; required.  By default, single character equivalents are not
675;; supported; if you want to allow the user to use single character
676;; options, you need to add a `single-char' clause to the option
677;; description.
678
679  (let* ((specifications (map parse-option-spec option-desc-list))
680         (spec-long      (map (lambda (spec)
681                                (cons (option-spec-name spec) spec))
682                              specifications))
683         (spec-short     (filter-map
684                          (lambda (spec)
685                            (and (option-spec-single-char spec)
686                                 (cons (option-spec-single-char spec) 
687                                       spec)))
688                          specifications))
689
690         (pair            (split-argument-list program-arguments))
691         (split-ls        (car pair))
692         (non-split-ls    (cdr pair)))
693
694    (match-let (((found etc unknown)
695                 (process-options (list spec-long spec-short) split-ls)))
696
697
698       (let ((rest-ls (append etc non-split-ls)))
699   
700         (for-each (lambda (spec)
701                     (let ((name (option-spec-name spec)))
702                       
703                       (and (option-spec-required? spec)
704                            (or (assoc name found )
705                                (error "option must be specified" name)))
706                       
707                       (and (assoc name found)
708                           
709                            (and (option-spec-value spec)
710                                 (not (value-policy-optional?
711                                       (option-spec-value spec))))
712                           
713                            (or (cdr (assoc name found))
714                                (error "option must be specified with argument"
715                                       name)))))
716                   specifications)
717
718
719
720       (values
721        (cons (cons '@ rest-ls) found)
722        (or (and (not (null? unknown)) 
723                 (unknown-option-handler (map unknown-option-name unknown)))
724            '()))
725       ))
726    ))
727
728(define (make-option-dispatch opts options-desc-list)
729  (let* ((specifications (map parse-option-spec options-desc-list))
730         (defaults
731           (filter-map
732            (lambda (spec) 
733              (let* ((name (option-spec-name spec))
734                     (value-policy (option-spec-value spec))
735                     (default (and value-policy 
736                                   (value-policy-default value-policy)))
737                     )
738                (cond ((and value-policy 
739                            (value-policy-predicate value-policy)) =>
740                            (lambda (pred)
741                              (or (pred name default) 
742                                  (error 'make-option-dispatch
743                                         "predicate error in default value"
744                                         default)))))
745                (let ((transformer
746                       (or (and value-policy 
747                                (value-policy-transformer value-policy))
748                           identity)))
749                  (and default (list name (transformer default))))
750                ))
751            specifications)))
752
753    (lambda (name)
754      (case name 
755        ((@)  (alist-ref '@ opts))
756        (else
757         (let* ((spec (find (lambda (x) (eq? (option-spec-name x) name)) specifications))
758                (v (filter-map (lambda (x) (and (eq? (car x) name) (cdr x))) (cdr opts))))
759           (if (option-spec-multiple? spec) v (and (pair? v) (car v)))
760           ))
761         ))
762    ))
763           
764         
765
766)
767;;; getopt-long.scm ends here
Note: See TracBrowser for help on using the repository browser.