#! /usr/bin/scheme --script
(define (read-line . port)
(define (eat p c)
(if (and (not (eof-object? (peek-char p)))
(char=? (peek-char p) c))
(read-char p)))
(let ((p (if (null? port) (current-input-port) (car port))))
(let loop ((c (read-char p)) (line '()))
(cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
(else (loop (read-char p) (cons c line)))))))
(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 (putcol opts c str)
(when (not (member (list c) opts))
(when (char=? c #\2) (display #\tab))
(when (char=? c #\3) (display #\tab) (display #\tab))
(display str) (newline)))
(define (comm opts file1 file2)
(let ((p1 (if (string=? file1 "-") (current-input-port) (open-input-file file1)))
(p2 (if (string=? file2 "-") (current-input-port) (open-input-file file2))))
(let loop ((f1 (read-line p1)) (f2 (read-line p2)))
(cond ((and (eof-object? f1) (eof-object? f2))
(close-input-port p1) (close-input-port p2))
((eof-object? f1)
(putcol opts #\2 f2) (loop f1 (read-line p2)))
((eof-object? f2)
(putcol opts #\1 f1) (loop (read-line p1) f2))
((string<? f1 f2)
(putcol opts #\1 f1) (loop (read-line p1) f2))
((string<? f2 f1)
(putcol opts #\2 f2) (loop f1 (read-line p2)))
(else (putcol opts #\3 f1) (loop (read-line p1) (read-line p2)))))))
(let-values (((opts files)
(getopt "123" "usage: comm [-[123]] file1 file2" (cdr (command-line)))))
(comm opts (car files) (cadr files)))