/usr/lib/s9fes/parse-optionsb.scm is in scheme9 2010.11.13-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; See the LICENSE file of the S9fES package for terms of use
;
; (display-usage list) ==> unspecific
; (option char boolean object) ==> opt-list
; (option char symbol object) ==> opt-list
; (opt-char opt-list) ==> char
; (opt-arg? opt-list) ==> boolean
; (opt-type opt-list) ==> symbol
; (opt-val opt-list) ==> object
; (parse-options! list1 list2 procedure|#f) ==> list
;
; (load-from-library "parse-optionsb.scm")
;
; The LIST1 argument of PARSE-OPTIONS! is a list of strings
; containing option groups and their arguments, if any. LIST2
; is a list of lists describing the expected options. LIST2
; has the following format:
;
; (list (option opt-chr1 arg-type1 [default])
; ...
; (option opt-chrN arg-typeN [default]))
;
; Each OPT-CHR is a character associated with that option and
; each ARG-TYPE is the type of the option. When it is a boolean,
; it indicates whether the option expects an argument. When it
; is a symbol, it must be one of the following:
;
; 'STRING The option may have any type of argument.
; (This is in fact the same as #T.)
; 'INTEGER The option expects a numeric (integer) argument.
; 'FILE The option expects a file name. The file must
; exist and must be readable by the calling program.
; 'COUNT The option has no argument, but specifying it
; multiples times increases its value instead of
; just setting it to #T.
;
; When a default object is specified in OPTION, it constitutes
; the default value of this option when it is not specified in
; the LIST1 argument of PARSE-OPTIONS!.
;
; The OPT-CHAR and OPT-TYPE procedures access the values of an
; opt-list return by OPTION. OPT-ARG? checks whether an option
; expects an argument. The OPT-VAL procedure returns the current
; value of that option. The initial value of each option is #F.
;
; The PARSE-OPTIONS procedure parses the options passed to it
; in LIST1. Each option group (e.g.: "-abc") and argument must
; be packaged in a separate string, i.e. '("-o" "file") works,
; but '("-o file") probably does not. The SYS:COMMAND-LINE
; procedure is typically used to supply a suitable LIST1.
;
; Each option character in LIST1 must be prefixed with a #\-
; or #\+ character. A #\- will set the value of an option to
; #T, a #\+ will set it to #F. When (opt-arg? x) is true for
; an option X, it will expect an argument in the subsequent
; option group. The value of the option will be that string,
; no matter whether the option character is preceded by #\-
; or #\+ character.
;
; When PARSE-OPTIONS detects a formal error (unknown option
; character, missing argument, etc), it will invoke the given
; PROCEDURE, which should print a short synopsis (a.k.a "usage").
; When #F is privided in the place of the usage procedure, a
; default message will be passed to ERROR. After running a
; user-supplied usage procedure the program will terminate with
; (sys:exit 1).
;
; When PARSE-OPTIONS returns, it delivers a list of trailing
; option groups that do not begin with a #\- or #\+ character.
;
; The special option "--" can be used to abort option processing.
; In this case, any remaining option groups will be returned,
; not matter which characters they contain.
;
; The DISPLAY-USAGE procedure prints the strings in its LIST
; argument. Each member prints in an individual line. When
; a non-string is found in LIST, DISPLAY-USAGE will assume it
; is a null-ary usage procedure, as described above, and call
; it.
;
; Example: (option #\o 'string) ==> (#\o string (#f))
; (opt-char (option #\o 'string)) ==> #\o
; (opt-arg? (option #\o 'string)) ==> #t
; (opt-type (option #\o 'string)) ==> string
; (opt-val (option #\o 'string)) ==> #f
;
; (parse-options! '("-o" "file1" "file2")
; `(,(option #\o #t))
; #f) ==> ("file2")
(require-extension sys-unix)
(define opt-char car)
(define opt-type cadr)
(define opt-arg? (lambda (x) (and (cadr x) #t)))
(define opt-box caddr)
(define (opt-val opt) (car (opt-box opt)))
(define (option char arg? . default)
(list char
arg?
(list (cond ((null? default)
#f)
((not (null? (cdr default)))
(error "option: too many arguments" default))
(else
(car default))))))
(define (parse-options! options table usage)
(define (set-opt-val! chars box type opts usage)
(cond ((not (null? (cdr chars)))
(if usage
(begin (usage)
(sys:exit 1))
(error
(string-append
"parse-options!: blank required before argument: "
(string (car chars))))))
((null? (cdr options))
(if usage
(begin (usage)
(sys:exit 1))
(error
(string-append "parse-options!: missing argument: -"
(string (car chars))))))
((or (eq? type #t)
(eq? type 'string))
(set-car! box (if (symbol? (cadr opts))
(symbol->string (cadr opts))
(cadr opts))))
((eq? type 'integer)
(let ((v (string->number (if (symbol? (cadr opts))
(symbol->string (cadr opts))
(cadr opts)))))
(if v
(set-car! box v)
(error
(string-append "parse-options!: expected number: -"
(string (car chars)))))))
((eq? type 'file)
(let ((file (if (symbol? (cadr opts))
(symbol->string (cadr opts))
(cadr opts))))
(if (sys:access file sys:access-r-ok)
(set-car! box file)
(error
(string-append "parse-options!: expected existing file: -"
(string (car chars)))))))
(else
(error (string-append "parse-options!: invalid argument type: `"
(symbol->string type)
"'")))))
(define (gen->list x)
(string->list (if (symbol? x) (symbol->string x) x)))
(define (gen-ref x n)
(string-ref (if (symbol? x) (symbol->string x) x) n))
(let opt-loop ((options options))
(if (null? options)
'()
(let* ((opt-group (car options))
(opt-ind (gen-ref opt-group 0)))
(if (not (memv opt-ind '(#\- #\+)))
options
(let char-loop ((opt-chars (cdr (gen->list opt-group))))
(if (null? opt-chars)
(opt-loop (cdr options))
(let tbl-loop ((tbl table))
(cond ((char=? #\- (car opt-chars))
(cdr options))
((null? tbl)
(if usage
(begin (usage)
(sys:exit 1))
(error
(string-append
"parse-options!: unknown option: `"
(string (car opt-chars))
"'"))))
((char=? (car opt-chars) (opt-char (car tbl)))
(cond ((eq? 'counter (opt-type (car tbl)))
(set-car! (opt-box (car tbl))
(if (number?
(opt-val (car tbl)))
(+ 1 (opt-val (car tbl)))
1))
(char-loop (cdr opt-chars)))
((opt-arg? (car tbl))
(set-opt-val! opt-chars
(opt-box (car tbl))
(opt-type (car tbl))
options
usage)
(opt-loop (cddr options)))
(else
(set-car! (opt-box (car tbl))
(char=? opt-ind #\-))
(char-loop (cdr opt-chars)))))
(else
(tbl-loop (cdr tbl))))))))))))
(define (display-usage usage)
(for-each (lambda (line)
(cond ((string? line)
(display line)
(newline))
(else
(line))))
usage))
|