codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
#! /usr/bin/scheme --script (define (getopt defn msg args) ; => (values (list opt/arg ...) (list file ...)) (define (parse-options defn) (let loop ((options (string->list defn)) (lones '()) (args '())) (cond ((null? options) (values lones args)) ((null? (cdr options)) (values (cons (car options) lones) args)) ((char=? (cadr options) #\:) (loop (cddr options) lones (cons (car options) args))) (else (loop (cdr options) (cons (car options) lones) args))))) (let-values (((lone-options arg-options) (parse-options defn))) (let loop ((args args) (xs '())) (cond ((or (null? args) (not (char=? (string-ref (car args) 0) #\-))) (values (reverse xs) args)) ((string=? (car args) "--") (values (reverse xs) (cdr args))) ((member (string-ref (car args) 1) lone-options) (let* ((len (string-length (car args))) (arg (string-ref (car args) 1)) (rest (substring (car args) 2 len))) (if (= len 2) (loop (cdr args) (cons (list arg) xs)) (loop (cons (string-append "-" rest) (cdr args)) (cons (list arg) xs))))) ((member (string-ref (car args) 1) arg-options) (let* ((len (string-length (car args))) (arg (string-ref (car args) 1)) (rest (substring (car args) 2 len))) (cond ((and (= len 2) (null? (cdr args))) (error 'getopt msg)) ((= len 2) (loop (cddr args) (cons (cons arg (cadr args)) xs))) (else (loop (cdr args) (cons (cons arg rest) xs)))))) (else ((error 'getopt msg))))))) (define (sum-sysv) (let loop ((c (read-char)) (b 0) (s 0)) (if (eof-object? c) (values s (ceiling (/ b 512))) (loop (read-char) (+ b 1) (modulo (+ s (char->integer c)) 65535))))) (define (sum-bsd) (let loop ((c (read-char)) (b 0) (s 0)) (if (eof-object? c) (values s (ceiling (/ b 1024))) (loop (read-char) (+ b 1) (modulo (+ (quotient s 2) (if (even? s) 0 32768) (char->integer c)) 65536))))) (define sum sum-bsd) ; default BSD checksum algorithm (call-with-values (lambda () (getopt "rs" "usage: [-r | -s] [file ...]" (cdr (command-line)))) (lambda (opts files) (do ((opts opts (cdr opts))) ((null? opts)) (case (caar opts) ((#\r) (set! sum sum-bsd)) ((#\s) (set! sum sum-sysv)))) (if (null? files) (call-with-values (lambda () (sum)) (lambda (s b) (display s) (display " ") (display b) (newline))) (do ((files files (cdr files))) ((null? files)) (with-input-from-file (car files) (lambda () (call-with-values (lambda () (sum)) (lambda (s b) (display s) (display " ") (display b) (display " ") (display (car files)) (newline)))))))))
Private
[
?
]
Run code
Submit