| 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)))) |
|---|
