#! /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)))))))))