source: project/release/5/srfi-37/trunk/srfi-37.scm @ 36398

Last change on this file since 36398 was 36398, checked in by Kooda, 12 months ago

Port the srfi-37 egg to CHICKEN 5

File size: 4.9 KB
Line 
1;;; srfi-37.scm - Argument option processor
2;
3; Copyright (c) 2002 Anthony Carrico
4;
5; All rights reserved.
6;
7; - ported to Chicken by felix
8
9
10(module srfi-37
11
12  (option
13   option?
14   option-names option-required-arg? option-optional-arg? option-processor
15   args-fold) 
16
17  (import scheme (chicken base))
18
19(define-record-type srfi-37:option
20  (option names required-arg? optional-arg? processor)
21  option?
22  (names option-names)
23  (required-arg? option-required-arg?)
24  (optional-arg? option-optional-arg?)
25  (processor option-processor))
26
27(define args-fold
28  (lambda (args                         ; list of args
29           options                      ; list of options
30           unrecognized-option-proc
31           ;; (lambda (non-option . seeds) <body>) -> next-seed ...
32           non-option-proc
33           . seeds)
34    (letrec
35        ((find
36          (lambda (l ?)
37            (cond ((null? l) #f)
38                  ((? (car l)) (car l))
39                  (else (find (cdr l) ?)))))
40         (find-option
41          ;; ISSUE: This is a brute force search. Could use a table.
42          (lambda (name)
43            (find
44             options
45             (lambda (option)
46               (find
47                (option-names option)
48                (lambda (test-name)
49                  (equal? name test-name)))))))
50         (scan-short-options
51          (lambda (index shorts args seeds)
52            (if (= index (string-length shorts))
53                (scan-args args seeds)
54                (let* ((name (string-ref shorts index))
55                       (option (or (find-option name)
56                                   (option (list name)
57                                           #f
58                                           #f
59                                           unrecognized-option-proc))))
60                  (cond ((and (< (+ index 1) (string-length shorts))
61                              (or (option-required-arg? option)
62                                  (option-optional-arg? option)))
63                         (receive seeds
64                             (apply (option-processor option)
65                                    option
66                                    name
67                                    (substring
68                                     shorts
69                                     (+ index 1)
70                                     (string-length shorts))
71                                    seeds)
72                           (scan-args args seeds)))
73                        ((and (option-required-arg? option)
74                              (pair? args))
75                         (receive seeds
76                             (apply (option-processor option)
77                                    option
78                                    name
79                                    (car args)
80                                    seeds)
81                           (scan-args (cdr args) seeds)))
82                        (else
83                         (receive seeds
84                             (apply (option-processor option)
85                                    option
86                                    name
87                                    #f
88                                    seeds)
89                           (scan-short-options
90                            (+ index 1)
91                            shorts
92                            args
93                            seeds))))))))
94         (scan-non-options
95          (lambda (non-options seeds)
96            (if (null? non-options)
97                (apply values seeds)
98                (receive seeds (apply non-option-proc (car non-options) seeds)
99                  (scan-non-options (cdr non-options) seeds)))))
100         (parse-long-option
101          ;; "--([^=]+)=(.*)"
102          (lambda (str len)
103            (let loop ([i 2])
104              (cond [(>= i len) #f]
105                    [(char=? #\= (string-ref str i))
106                     (cons (substring str 2 i) (substring str (add1 i) len)) ]
107                    [else (loop (add1 i))] ) ) ) )
108         (scan-args
109          (lambda (args seeds)
110            (if (null? args)
111                (apply values seeds)
112                (let* ([arg (car args)]
113                       [args (cdr args)]
114                       [len (string-length arg)] )
115                  (if (and (> len 1) (char=? #\- (string-ref arg 0)))
116                      (if (char=? #\- (string-ref arg 1))
117                          (cond [(eq? 2 len)
118                                 (scan-non-options args seeds) ]
119                                [(parse-long-option arg len)
120                                 => (lambda (name+arg)
121                                      ;; Found long option with arg:
122                                      (let* ([name (car name+arg)]
123                                             [arg (cdr name+arg)]
124                                             [option (or (find-option name)
125                                                         (option (list name)
126                                                                 #t
127                                                                 #f
128                                                                 unrecognized-option-proc)) ] )
129                                        (receive seeds
130                                            (apply (option-processor option)
131                                                   option
132                                                   name
133                                                   arg
134                                                   seeds)
135                                          (scan-args args seeds) ) ) ) ]
136                                [else
137                                 ;; Found long option:
138                                 (let* ([name (substring arg 2 len)]
139                                        [option (or (find-option name)
140                                                    (option
141                                                     (list name)
142                                                     #f
143                                                     #f
144                                                     unrecognized-option-proc)) ] )
145                                   (if (and (option-required-arg? option)
146                                            (pair? args))
147                                       (receive seeds
148                                           (apply (option-processor option)
149                                                  option
150                                                  name
151                                                  (car args)
152                                                  seeds)
153                                         (scan-args (cdr args) seeds))
154                                       (receive seeds
155                                           (apply (option-processor option)
156                                                  option
157                                                  name
158                                                  #f
159                                                  seeds)
160                                         (scan-args args seeds)))) ] )
161                          ;; Found short options
162                          (scan-short-options 0 (substring arg 1 len) args seeds) )
163                      (receive seeds (apply non-option-proc arg seeds)
164                        (scan-args args seeds) ) ) ) ) ) ) )
165      (scan-args args seeds))))
166)
Note: See TracBrowser for help on using the repository browser.