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

reference to undefined identifier: command-line