source: project/release/3/cmk/srfi-37.scm @ 12843

Last change on this file since 12843 was 12843, checked in by Ivan Raikov, 12 years ago

Added initial version of cmk.

File size: 5.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(cond-expand
11 [paranoia]
12 [else (declare (no-bound-checks))] )
13
14(cond-expand
15 [unsafe
16  (eval-when (compile)
17    (define-macro (##sys#check-structure . _) '(##core#undefined))
18    (define-macro (##sys#check-range . _) '(##core#undefined))
19    (define-macro (##sys#check-pair . _) '(##core#undefined))
20    (define-macro (##sys#check-list . _) '(##core#undefined))
21    (define-macro (##sys#check-symbol . _) '(##core#undefined))
22    (define-macro (##sys#check-string . _) '(##core#undefined))
23    (define-macro (##sys#check-char . _) '(##core#undefined))
24    (define-macro (##sys#check-exact . _) '(##core#undefined))
25    (define-macro (##sys#check-port . _) '(##core#undefined))
26    (define-macro (##sys#check-number . _) '(##core#undefined))
27    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
28 [else] )
29
30(register-feature! 'srfi-37)
31
32(define (option names req opt pro)
33  (##sys#make-structure 'option names req opt pro) )
34
35(define (option-names opt)
36  (##sys#check-structure opt 'option 'option-names)
37  (##sys#slot opt 1) )
38
39(define (option-required-arg? opt)
40  (##sys#check-structure opt 'option 'option-required-arg?)
41  (##sys#slot opt 2) )
42
43(define (option-optional-arg? opt)
44  (##sys#check-structure opt 'option 'option-optional-arg?)
45  (##sys#slot opt 3) )
46
47(define (option-processor opt)
48  (##sys#check-structure opt 'option 'option-processor)
49  (##sys#slot opt 4) )
50
51(define (option? x) (##sys#structure? x 'option))
52
53(define args-fold
54  (lambda (args                         ; list of args
55           options                      ; list of options
56           unrecognized-option-proc
57           ;; (lambda (non-option . seeds) <body>) -> next-seed ...
58           non-option-proc
59           . seeds)
60    (letrec
61        ((find
62          (lambda (l ?)
63            (cond ((null? l) #f)
64                  ((? (car l)) (car l))
65                  (else (find (cdr l) ?)))))
66         (find-option
67          ;; ISSUE: This is a brute force search. Could use a table.
68          (lambda (name)
69            (find
70             options
71             (lambda (option)
72               (find
73                (option-names option)
74                (lambda (test-name)
75                  (equal? name test-name)))))))
76         (scan-short-options
77          (lambda (index shorts args seeds)
78            (if (= index (string-length shorts))
79                (scan-args args seeds)
80                (let* ((name (string-ref shorts index))
81                       (option (or (find-option name)
82                                   (option (list name)
83                                           #f
84                                           #f
85                                           unrecognized-option-proc))))
86                  (cond ((and (< (+ index 1) (string-length shorts))
87                              (or (option-required-arg? option)
88                                  (option-optional-arg? option)))
89                         (receive seeds
90                             (apply (option-processor option)
91                                    option
92                                    name
93                                    (substring
94                                     shorts
95                                     (+ index 1)
96                                     (string-length shorts))
97                                    seeds)
98                           (scan-args args seeds)))
99                        ((and (option-required-arg? option)
100                              (pair? args))
101                         (receive seeds
102                             (apply (option-processor option)
103                                    option
104                                    name
105                                    (car args)
106                                    seeds)
107                           (scan-args (cdr args) seeds)))
108                        (else
109                         (receive seeds
110                             (apply (option-processor option)
111                                    option
112                                    name
113                                    #f
114                                    seeds)
115                           (scan-short-options
116                            (+ index 1)
117                            shorts
118                            args
119                            seeds))))))))
120         (scan-non-options
121          (lambda (non-options seeds)
122            (if (null? non-options)
123                (apply values seeds)
124                (receive seeds (apply non-option-proc (car non-options) seeds)
125                  (scan-non-options (cdr non-options) seeds)))))
126         (parse-long-option
127          ;; "--([^=]+)=(.*)"
128          (lambda (str len)
129            (let loop ([i 2])
130              (cond [(>= i len) #f]
131                    [(char=? #\= (string-ref str i))
132                     (cons (substring str 2 i) (substring str (add1 i) len)) ]
133                    [else (loop (add1 i))] ) ) ) )
134         (scan-args
135          (lambda (args seeds)
136            (if (null? args)
137                (apply values seeds)
138                (let* ([arg (car args)]
139                       [args (cdr args)]
140                       [len (string-length arg)] )
141                  (if (and (> len 1) (char=? #\- (string-ref arg 0)))
142                      (if (char=? #\- (string-ref arg 1))
143                          (cond [(eq? 2 len)
144                                 (scan-non-options args seeds) ]
145                                [(parse-long-option arg len)
146                                 => (lambda (name+arg)
147                                      ;; Found long option with arg:
148                                      (let* ([name (car name+arg)]
149                                             [arg (cdr name+arg)]
150                                             [option (or (find-option name)
151                                                         (option (list name)
152                                                                 #t
153                                                                 #f
154                                                                 unrecognized-option-proc)) ] )
155                                        (receive seeds
156                                            (apply (option-processor option)
157                                                   option
158                                                   name
159                                                   arg
160                                                   seeds)
161                                          (scan-args args seeds) ) ) ) ]
162                                [else
163                                 ;; Found long option:
164                                 (let* ([name (substring arg 2 len)]
165                                        [option (or (find-option name)
166                                                    (option
167                                                     (list name)
168                                                     #f
169                                                     #f
170                                                     unrecognized-option-proc)) ] )
171                                   (if (and (option-required-arg? option)
172                                            (pair? args))
173                                       (receive seeds
174                                           (apply (option-processor option)
175                                                  option
176                                                  name
177                                                  (car args)
178                                                  seeds)
179                                         (scan-args (cdr args) seeds))
180                                       (receive seeds
181                                           (apply (option-processor option)
182                                                  option
183                                                  name
184                                                  #f
185                                                  seeds)
186                                         (scan-args args seeds)))) ] )
187                          ;; Found short options
188                          (scan-short-options 0 (substring arg 1 len) args seeds) )
189                      (receive seeds (apply non-option-proc arg seeds)
190                        (scan-args args seeds) ) ) ) ) ) ) )
191      (scan-args args seeds))))
Note: See TracBrowser for help on using the repository browser.