source: project/srfi-37/srfi-37.scm @ 1967

Last change on this file since 1967 was 1967, checked in by Kon Lovett, 13 years ago

Added export decl.

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