source: project/release/4/getopt-long/tags/1.17/getopt-long.scm @ 34160

Last change on this file since 34160 was 34160, checked in by Ivan Raikov, 3 years ago

getopt-long release 1.17

File size: 25.0 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-2013 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                     default-long-option-value-cset 
171                     long-option-value-quoting)
172
173        (import scheme chicken)
174       
175        (require-extension data-structures srfi-1 srfi-13 srfi-14 matchable )
176
177
178(define (fetch-value kv) 
179  (match kv ((k v) v) (else (cdr kv))))
180
181
182(define (lookup-def k lst . rest)
183  (let-optionals rest ((default #f))
184      (let ((kv (assoc k lst)))
185        (if (not kv) default
186            (fetch-value kv)))))
187
188
189(define-record-type  unknown-option
190  (make-unknown-option name )
191  unknown-option?
192  (name        unknown-option-name)
193  )
194 
195
196(define-record-type  value-policy
197  (make-value-policy name predicate transformer optional? default )
198  value-policy?
199  (name        value-policy-name)
200  (predicate   value-policy-predicate)
201  (transformer value-policy-transformer)
202  (optional?   value-policy-optional?)
203  (default     value-policy-default))
204 
205
206(define-record-type option-spec
207  (make-option-spec name value required? single-char docstring multiple? )
208  option-spec?
209  (name         option-spec-name)
210  (value        option-spec-value)
211  (required?    option-spec-required?)
212  (single-char  option-spec-single-char)
213  (docstring    option-spec-docstring)
214  (multiple?    option-spec-multiple?))
215
216
217;; Valid characters for option names and values
218
219(define long-option-name-cset
220   (char-set-union char-set:letter
221                   (char-set #\-)))
222
223
224(define short-option-name-cset
225  char-set:letter)
226
227(define default-long-option-value-cset
228  (char-set-union char-set:letter+digit 
229                  char-set:punctuation
230                  (char-set #\_ #\^ #\$ #\= #\space)))
231
232(define long-option-value-quoting (make-parameter #f))
233
234
235;;
236;; We don't auto-format the left column (the option keys) based on the
237;; length of the longest option, but you can override it manually.
238;;
239(define width (make-parameter 25))
240
241;; The separator used between options.  Default: ", "
242
243(define separator (make-parameter ", "))
244(define indent (make-parameter 1))
245
246(define (spaces n)
247  (let loop ((ls '()) (n n))
248    (if (<= n 0)
249        (list->string ls)
250        (loop (cons #\space ls)
251              (- n 1)))))
252
253;; Join together option names in spec with commas, and append the
254;; argument type and name
255
256(define-record-printer (option-spec x out)
257  (let* ((name          (option-spec-name x))
258         (value-policy  (option-spec-value x))
259         (required?     (option-spec-required? x))
260         (single-char   (option-spec-single-char x))
261         (docstring     (option-spec-docstring x))
262         (multiple?     (option-spec-multiple? x))
263         (long-option   (and (not (make-single-char name))
264                             (string-append "--" (->string name))))
265         (short-option  (or (and single-char 
266                                 (list->string (list #\- single-char)))
267                            (make-single-char name)))
268         (option-lst    (cond ((and short-option long-option)
269                               (list long-option (separator) short-option))
270                              (long-option
271                               (list long-option))
272                              (else (list short-option))))
273         (option-lst
274          (cond
275           (value-policy 
276            (if (value-policy-optional? value-policy) 
277                (cons* "]" (->string (value-policy-name value-policy) )
278                       "=" "[" option-lst)
279                (cons* (->string (value-policy-name value-policy))
280                       "=" 
281                       option-lst)))
282           (else        option-lst)))
283
284         (option-string (string-concatenate (reverse option-lst))))
285
286    (display
287     (string-append (spaces (indent))
288                    (string-pad-right option-string (width))
289                    docstring
290                    "\n")
291     out)))
292
293;; Generate a formatted list of options from OPTION-LIST, and return a
294;; string suitable for embedding into help text.  The single string
295;; consists of multiple lines, with a newline at the end of each line.
296;; Thus, a typical use would be (print (usage opts)).
297(define (usage opts) 
298  (let ((specs (map parse-option-spec opts)))
299    (apply string-append (map ->string specs))))
300
301
302(define update-option-spec
303  (lambda (x . key/values)
304    (apply
305     (lambda (#!key
306              (name           (option-spec-name x)) 
307              (required?      (option-spec-required? x))
308              (single-char    (option-spec-single-char x))
309              (value          (option-spec-value x))
310              (docstring      (option-spec-docstring x))
311              (multiple?      (option-spec-multiple? x))
312              )
313          (make-option-spec 
314           name
315           value
316           required?
317           single-char
318           docstring
319           multiple?
320           ))
321     key/values)))
322
323
324(define (make-predicate pred)
325  (lambda (name val)
326    (or (not val)
327        (pred val)
328        (error "option predicate failed" name))))
329
330
331(define (make-single-char x)
332  (let ((lst (string->list (->string x))))
333    (and (null? (cdr lst))
334         (car lst))))
335   
336
337(define (parse-option-spec desc)
338 
339  (let* ((name         (car desc))
340         (single-char  (make-single-char name))
341         (spec
342          (make-option-spec 
343           name
344           #f
345           #f
346           single-char
347           ""
348           #f
349           )))
350
351    (fold
352     (lambda (desc-elem spec)
353       (cond ((string? desc-elem)
354              (update-option-spec spec docstring: desc-elem))
355
356             (else
357              (let ((given (lambda () (cdr desc-elem))))
358
359                (case (car desc-elem)
360
361                  ((multiple)
362                   (update-option-spec spec multiple?: (car (given))))
363                 
364                  ((required)
365                   (update-option-spec spec required?: (car (given))))
366                 
367                  ((value)
368                   (let ((value-policy
369                          (match (given)
370
371                                 ((((and flag (or 'required 'optional))
372                                    (and name (or (? symbol?) (? string?)))) . rst)
373                                  (let ((predicate 
374                                         (cond ((lookup-def 'predicate rst) =>
375                                                make-predicate)
376                                               (else
377                                                (lambda x (identity x)))))
378
379                                        (transformer 
380                                         (or (lookup-def 'transformer rst)
381                                             identity))
382
383                                        (default (lookup-def 'default rst))
384                                        )
385
386                                    (make-value-policy 
387                                     name
388                                     predicate
389                                     transformer
390                                     (equal? flag 'optional)
391                                     (and default  (->string default))
392                                     )))
393
394                                 ((#t) (make-value-policy 
395                                      'ARG
396                                      (lambda x (identity x))
397                                      identity
398                                      #f
399                                      #f))
400
401                                 ((#f) #f)
402
403                                 (else (error "invalid value specification "
404                                              (given)))
405
406                                 )))
407                     (update-option-spec spec value: value-policy)))
408                 
409                  ((single-char)
410                   (cond
411                    ((make-single-char (car (given))) =>
412                     (lambda (c)
413                       (update-option-spec spec single-char: c)))
414                    (else
415                     (error "`single-char' value must be a single character, string, or symbol"))))
416
417                  (else
418                   (error "invalid getopt-long option property"
419                          (car desc-elem))))))))
420     spec (cdr desc))
421    ))
422
423
424
425(define (split-argument-list argument-list)
426  ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
427  ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
428  (let loop ((yes '()) (no argument-list))
429    (cond ((null? no)               (cons (reverse yes) no))
430          ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
431          (else (loop (cons (car no) yes) (cdr no))))))
432
433
434(define (check-long-option str)
435  (and (> (string-length str) 1)
436       (string=? (substring str 0 2) "--")))
437
438(define (check-short-option str)
439  (and (positive? (string-length str))
440       (string=? (substring str 0 1) "-")))
441
442(define (long-option-name lst)
443  (let loop ((lst lst)  (ax (list)))
444    (cond ((null? lst)  (list (list->string (reverse ax)) lst))
445
446          ((and (char? (car lst))
447                (char-set-contains? long-option-name-cset
448                                    (car lst))
449                (car lst))
450           => (lambda (c) (loop (cdr lst) (cons c ax))))
451
452          ((char=? (car lst) #\=)
453           (list (list->string (reverse ax)) (cdr lst)))
454
455          (else (error 'long-option-name 
456                       "invalid list" lst)))))
457
458
459(define (long-option-value lst value-cset)
460  (if (null? lst) (list #f lst)
461      (let loop ((lst lst)  (ax (list)))
462        (cond ((null? lst) 
463               (list (list->string (reverse ax)) lst))
464             
465              ((and (char? (car lst)) (car lst)) =>
466
467               (lambda (c)
468
469                 (cond ((and (long-option-value-quoting) (char=? c #\"))
470                        (let quote-loop ((lst (cdr lst)) (ax ax))
471                          (if (null? lst) (error 'long-option-value
472                                                 "unclosed option value quotation")
473                              (cond ((char=? (car lst) #\")
474                                     (loop (cdr lst) ax))
475                                    ((char=? (car lst) #\\)
476                                     (cond ((char=? (cadr lst) #\\)
477                                            (quote-loop (cddr lst) (cons #\\ ax)))
478                                           ((char=? (cadr lst) #\")
479                                            (quote-loop (cddr lst) (cons #\" ax)))
480                                           (else
481                                            (quote-loop (cddr lst) (cons (cadr lst) (cons (car lst) ax))))
482                                           ))
483                                    (else
484                                     (quote-loop (cdr lst) (cons (car lst) ax))))
485                              ))
486                        )
487
488                       ((char-set-contains? value-cset c)
489                        (loop (cdr lst) (cons c ax)))
490
491                       (else  (error 'long-option-value 
492                                     "invalid option character" c)))))
493             
494              (else (error 'long-option-value 
495                           "invalid list" lst))))))
496
497
498(define (long-option? specs a next value-cset)
499
500  (let ((l (string->list a)))
501    (match l
502           ((#\- #\-  . rst)
503            (match-let* (((n nrst)  (long-option-name rst))
504
505                         ((v _)     (let ((lv (long-option-value nrst value-cset)))
506                                      lv))
507                         ((next v)
508                          (begin
509                            (or (and v (list next v))
510                                (list next #f)))))
511
512                        (cond ((alist-ref (string->symbol n) (car specs)) =>
513                               (lambda (spec)
514                                 (cond
515                                 
516                                  ((and v (option-spec-value spec)) =>
517                                   (lambda (value-policy)
518                                     (or
519                                      (and ((or (value-policy-predicate value-policy)
520                                                (lambda x (identity x))) n v)
521                                           (let ((transformer
522                                                  (or (value-policy-transformer value-policy)
523                                                      identity)))
524                                             (list next (cons (option-spec-name spec) (transformer v)))))
525                                      (error 'long-option? 
526                                             "predicate error on option value" n))))
527                                 
528                                  ((and v (not (option-spec-value spec)))
529                                   (error 'long-option? 
530                                          "superfluous argument given to option" n))
531                                 
532                                  ((and (not v) (option-spec-value spec)
533                                        (value-policy-optional? 
534                                         (option-spec-value spec)))
535
536                                   (let* ((vp (option-spec-value spec))
537                                          (dflt  (value-policy-default vp))
538                                          (transformer (or (value-policy-transformer vp)
539                                                           identity))
540                                          (v (and dflt (transformer dflt))))
541                                       (list next (cons (option-spec-name spec) (or v #t)))))
542                                 
543                                  ((and (not v) (option-spec-value spec))
544                                   (error 'long-option? "option requires value" n))
545                                 
546                                  (else
547                                   (list next (cons (option-spec-name spec) #t)))
548                                 
549                                  )))
550                              (else
551                               (list next (make-unknown-option n))))))
552           (else #f))))
553
554
555(define (short-option-names lst)
556  (if (null? lst) (list #f lst)
557      (let loop ((lst lst)  (ax (list)))
558        (cond ((null? lst)  (list ax lst))
559
560              ((and (char? (car lst))
561                    (char-set-contains? short-option-name-cset (car lst)) 
562                    (car lst)) =>
563                    (lambda (c) (loop (cdr lst) (cons c ax))))
564
565              (else (list ax lst))))))
566
567(define (short-options? specs a next)
568
569  (let ((l (string->list a)))
570    (match l
571           ((#\-  . rst)
572            (match-let ((((n1 . ns) _)  (short-option-names rst)))
573              (match-let
574               ;; special case: check if the last single-letter option
575               ;; has an argument
576               (((next opt1)
577                 (cond
578                  ((alist-ref n1 (cadr specs) ) =>
579                   (lambda (spec)
580                     (let ((name (option-spec-name spec)))
581
582                       (cond
583                        ((option-spec-value spec) =>
584                         (lambda (value-policy)
585                           (let ((v (and (pair? next)
586                                         (not (check-long-option (car next) ))
587                                         (not (check-short-option (car next) ))
588                                         (car next))))
589                                       
590                             (if (and (not v) (not (value-policy-optional? value-policy)))
591                                 (error 'short-options?  "option requires value" name))
592                             
593                             (if (not v) 
594                                 (list next (cons name (or (value-policy-default value-policy) #t)))
595                                 (or (and ((or (value-policy-predicate value-policy) 
596                                               (lambda x (identity x))) name v)
597                                          (let ((transformer
598                                                 (or (value-policy-transformer value-policy) 
599                                                     identity)))
600                                            (list (cdr next) (cons name (transformer v)))))
601                                 
602                                  (error 'short-options? 
603                                         "predicate error on option value" 
604                                         name))))))
605                                 
606                        (else
607                         (list next (cons name #t)))))))
608                  (else
609                   (list next (make-unknown-option (->string n1)))))))
610               (list next 
611                     (cons opt1 
612                           (map (lambda (n)
613                                  (cond
614                                   ((alist-ref n (cadr specs) ) =>
615                                    (lambda (spec)
616                                      (cond
617                                       ((option-spec-value spec)
618                                        (error 'short-options?
619                                               "option requires value" n))
620                                       
621                                       (else
622                                        (cons (option-spec-name spec) #t)))))
623                                   
624                                   (else
625                                    (make-unknown-option (->string n)))))
626                                ns)))))
627              )
628           (else #f))))
629           
630 
631 
632
633(define (process-options specs argument-ls value-cset)
634
635  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
636  ;; FOUND is an unordered list of option specs for found options, while ETC
637  ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
638  ;; options nor their values.
639  ;;
640  ;; Argument VALUE-CSET specifies the set of characters allowed in
641  ;; option values.
642
643  (let loop ((ls argument-ls)  (found (list)) (etc (list)) (unknown (list)))
644
645    (if (null? ls) 
646
647        (list found (reverse etc) (reverse unknown))
648
649        (let ((arg (car ls)) (rest (cdr ls)))
650
651          (cond ((long-option? specs arg rest value-cset) =>
652                 (lambda (next.val)
653                   (let ((optval (cadr next.val)))
654                     (if (unknown-option? optval)
655                         (loop (car next.val) found etc (cons optval unknown))
656                         (loop (car next.val) (cons optval found) etc unknown)))))
657               
658                ((short-options? specs arg rest) =>
659                 (lambda (next.vals)
660                   (let-values (((unknowns optvals) (partition unknown-option? (cadr next.vals))))
661                     (loop (car next.vals) (append optvals found) etc (append unknowns unknown)))))
662
663                (else
664                 (loop (cdr ls) found (cons (car ls) etc) unknown)))))))
665                                 
666
667
668(define (getopt-long program-arguments option-desc-list 
669                     #!key 
670                     (unknown-option-handler (lambda (x) (error 'getopt-long "unknown options" x)))
671                     (long-option-value-cset default-long-option-value-cset)
672                     )
673
674;;
675;; Process options, handling both long and short options, similar to
676;; the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a
677;; value similar to what (program-arguments) returns.
678;;
679;; OPTION-DESC-LIST is a list of option descriptions.  Each option
680;; description must satisfy the following grammar:
681;;
682;;     <option-spec>           :: (<name> . <attribute-ls>)
683;;     <attribute-ls>          :: (<attribute> . <attribute-ls>)
684;;                                | ()
685;;     <attribute>             :: <required-attribute>
686;;                                | <arg-required-attribute>
687;;                                | <single-char-attribute>
688;;                                | <value-attribute>
689;;     <required-attribute>    :: (required? <boolean>)
690;;     <single-char-attribute> :: (single-char <char>)
691;;     <value-attribute>       :: (value #t)
692;;                                (value #f)
693;;                                (value (required <name>))
694;;                                (value (optional <name>))
695;;                                (<value-attribute>
696;;                                 <predicate-attribute>)
697;;     <predicate-attribute>   :: (predicate <1-ary-function>)
698;;
699;;     The procedure returns an alist of option names and values.
700;; Each option name is a symbol.  The option value will be '#t' if no
701;; value was specified.  There is a special item in the returned alist
702;; with a key @: the list of arguments that are not options or option
703;; values.
704;;
705;;     By default, options are not required, and option values are not
706;; required.  By default, single character equivalents are not
707;; supported; if you want to allow the user to use single character
708;; options, you need to add a `single-char' clause to the option
709;; description.
710
711  (let* ((specifications (map parse-option-spec option-desc-list))
712         (spec-long      (map (lambda (spec)
713                                (cons (option-spec-name spec) spec))
714                              specifications))
715         (spec-short     (filter-map
716                          (lambda (spec)
717                            (and (option-spec-single-char spec)
718                                 (cons (option-spec-single-char spec) 
719                                       spec)))
720                          specifications))
721
722         (pair            (split-argument-list program-arguments))
723         (split-ls        (car pair))
724         (non-split-ls    (cdr pair)))
725
726    (match-let (((found etc unknown)
727                 (process-options (list spec-long spec-short) split-ls
728                                  long-option-value-cset)))
729
730
731       (let ((rest-ls (append etc non-split-ls)))
732   
733         (for-each (lambda (spec)
734                     (let ((name (option-spec-name spec)))
735                       
736                       (and (option-spec-required? spec)
737                            (or (assoc name found )
738                                (error "option must be specified" name)))
739                       
740                       (and (assoc name found)
741                           
742                            (and (option-spec-value spec)
743                                 (not (value-policy-optional?
744                                       (option-spec-value spec))))
745                           
746                            (or (cdr (assoc name found))
747                                (error "option must be specified with argument"
748                                       name)))))
749                   specifications)
750
751
752
753       (values
754        (cons (cons '@ rest-ls) found)
755        (or (and (not (null? unknown)) 
756                 (unknown-option-handler (map unknown-option-name unknown)))
757            '()))
758       ))
759    ))
760
761(define (make-option-dispatch opts options-desc-list)
762  (let* ((specifications (map parse-option-spec options-desc-list))
763         (defaults
764           (filter-map
765            (lambda (spec) 
766              (let* ((name (option-spec-name spec))
767                     (value-policy (option-spec-value spec))
768                     (default (and value-policy 
769                                   (value-policy-default value-policy)))
770                     )
771                (cond ((and value-policy 
772                            (value-policy-predicate value-policy)) =>
773                            (lambda (pred)
774                              (or (pred name default) 
775                                  (error 'make-option-dispatch
776                                         "predicate error in default value"
777                                         default)))))
778                (let ((transformer
779                       (or (and value-policy 
780                                (value-policy-transformer value-policy))
781                           identity)))
782                  (and default (list name (transformer default))))
783                ))
784            specifications)))
785
786    (lambda (name)
787      (case name 
788        ((@)  (alist-ref '@ opts))
789        (else
790         (let* ((spec (find (lambda (x) (eq? (option-spec-name x) name)) specifications))
791                (v (filter-map (lambda (x) (and (eq? (car x) name) (cdr x))) (cdr opts))))
792           (if (option-spec-multiple? spec) v (and (pair? v) (car v)))
793           ))
794         ))
795    ))
796           
797         
798
799)
800;;; getopt-long.scm ends here
Note: See TracBrowser for help on using the repository browser.