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 (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)))
Private
[
?
]
Run code
Submit