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 (range . args) (case (length args) ((1) (range 0 (car args) (if (negative? (car args)) -1 1))) ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1))) ((3) (let ((le? (if (negative? (caddr args)) >= <=))) (let loop ((x(car args)) (xs '())) (if (le? (cadr args) x) (reverse xs) (loop (+ x (caddr args)) (cons x xs)))))) (else (error 'range "unrecognized arguments")))) (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 (string-split sep str) (define (f cs xs) (cons (list->string (reverse cs)) xs)) (let loop ((ss (string->list str)) (cs '()) (xs '())) (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs)))) ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs))) (else (loop (cdr ss) (cons (car ss) cs) xs))))) (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 (expand-ranges str) (define (make-range str) (let ((endpoints (map string->number (string-split #\- str)))) (if (null? (cdr endpoints)) (list (car endpoints)) (range (car endpoints) (+ (cadr endpoints) 1))))) (apply append (map make-range (string-split #\, str)))) (define (write-chars cs str) (do ((cs cs (cdr cs))) ((null? cs) (newline)) (display (string-ref str (- (car cs) 1))))) (define (write-fields fs str delim) (let ((fields (string-split delim str))) (do ((fs fs (cdr fs))) ((null? fs)) (display (list-ref fields (- (car fs) 1))) (display (if (pair? (cdr fs)) delim #\newline))))) (define (do-file opts) (if (assoc #\c opts) (let ((cs (expand-ranges (cdr (assoc #\c opts))))) (do ((line (read-line) (read-line))) ((eof-object? line)) (write-chars cs line))) (let ((fs (expand-ranges (cdr (assoc #\f opts)))) (delim (string-ref (cdr (assoc #\d opts)) 0))) (do ((line (read-line) (read-line))) ((eof-object? line)) (write-fields fs line delim))))) (let-values (((opts files) (getopt "c:d:f:" "usage: cut -clist [file ...] or cut -flist [-dchar] [file ...]" (cdr (command-line))))) (if (null? files) (do-file opts) (do ((files files (cdr files))) ((null? files)) (with-input-from-file (car files) (lambda () (do-file opts))))))
Private
[
?
]
Run code
Submit