#! /usr/bin/scheme --script
; grep [-v] [file ...]
(define-syntax when
(syntax-rules ()
((when pred? expr ...)
(if pred? (begin expr ...)))))
(define (complement f) (lambda xs (not (apply f xs))))
(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-syntax list-match
(syntax-rules ()
((_ expr (pattern fender ... template) ...)
(let ((obj expr))
(cond ((list-match-aux obj pattern fender ...
(list template)) => car) ...
(else (error 'list-match "pattern failure")))))))
(define-syntax list-match-aux
(lambda (stx)
(define (underscore? x)
(and (identifier? x) (free-identifier=? x (syntax _))))
(syntax-case stx (quote quasiquote)
((_ obj pattern template)
(syntax (list-match-aux obj pattern #t template)))
((_ obj () fender template)
(syntax (and (null? obj) fender template)))
((_ obj underscore fender template)
(underscore? (syntax underscore))
(syntax (and fender template)))
((_ obj var fender template)
(identifier? (syntax var))
(syntax (let ((var obj)) (and fender template))))
((_ obj (quote datum) fender template)
(syntax (and (equal? obj (quote datum)) fender template)))
((_ obj (quasiquote datum) fender template)
(syntax (and (equal? obj (quasiquote datum)) fender template)))
((_ obj (kar . kdr) fender template)
(syntax (and (pair? obj)
(let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
(list-match-aux kar-obj kar
(list-match-aux kdr-obj kdr fender template))))))
((_ obj const fender template)
(syntax (and (equal? obj const) fender template))))))
(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 (rx-match? rx text)
(cond ((null? rx) #t)
((equal? (car rx) '(bol))
(match-here (cdr rx) (string->list text)))
(else (match rx (string->list text)))))
(define (match rx text)
(cond ((null? rx) #t)
((null? text) (match-here rx text))
(else (or (match-here rx text) (match rx (cdr text))))))
(define (match-here rx text)
(if (null? rx) #t
(case (caar rx)
((eol) (null? text))
((clo) (match-star rx text))
(else (and (pair? text)
(match-one (car rx) (car text))
(match-here (cdr rx) (cdr text)))))))
(define (match-star rx text)
(cond ((match-here (cdr rx) text) #t)
((and (pair? text) (match-one (cdar rx) (car text)))
(match-star rx (cdr text)))
(else #f)))
(define (match-one rx text)
(case (car rx)
((any) #t)
((lit) (char=? (cadr rx) text))
((ccl) (member text (cdr rx)))
((ncl) (not (member text (cdr rx))))))
(define (make-rx regexp)
(let loop ((first? #t) (rs (string->list regexp)) (zs '()))
(list-match rs
(() (reverse zs))
((#\$) (reverse (cons '(eol) zs)))
((#\^ . rest) first? (loop #f rest (cons '(bol) zs)))
((#\\ c \#* . rest)
(loop #f rest (cons (list 'clo 'lit
(case c ((#\n) #\newline) ((#\t) #\tab) (else c))) zs)))
((#\\ c . rest)
(loop #f rest (cons (list 'lit
(case c ((#\n) #\newline) ((#\t) #\tab) (else c))) zs)))
((#\[ #\^ . rest)
(list-match (get-class rest)
((class) (reverse (cons (cons 'ncl class) zs)))
((class rest)
(if (and (pair? rest) (char=? (car rest) #\*))
(loop #f (cdr rest) (cons (cons 'clo (cons 'ncl class)) zs))
(loop #f rest (cons (cons 'ncl class) zs))))))
((#\[ . rest)
(list-match (get-class rest)
((class) (reverse (cons (cons 'ccl class) zs)))
((class rest)
(if (and (pair? rest) (char=? (car rest) #\*))
(loop #f (cdr rest) (cons (cons 'clo (cons 'ccl class)) zs))
(loop #f rest (cons (cons 'ccl class) zs))))))
((#\. #\* . rest) (loop #f rest (cons (list 'clo 'any) zs)))
((#\. . rest) (loop #f rest (cons '(any) zs)))
((c #\* . rest) (loop #f rest (cons (list 'clo 'lit c) zs)))
((c . rest) (loop #f rest (cons (list 'lit c) zs)))
(else (error 'make-rx "unrecognized regular expression")))))
(define (get-class class)
(define (char-range a b)
(map integer->char
(range (char->integer a) (+ (char->integer b) 1))))
(let loop ((cs class) (zs '()))
(list-match cs
((#\] . rest) (pair? zs) (list zs rest))
((#\] . rest) (loop rest (cons #\] zs)))
((#\ c . rest) (loop rest (cons c zs)))
((a #\- b . rest)
(or (and (char-numeric? a) (char-numeric? b) (char<? a b))
(and (char-upper-case? a) (char-upper-case? b) (char<? a b))
(and (char-lower-case? a) (char-lower-case? b) (char<? a b)))
(loop rest (append (char-range a b) zs)))
((c . rest) (loop rest (cons c zs)))
(else (error 'get-class "unrecognized class element")))))
(define (do-input match? filename)
(do ((line (read-line) (read-line))) ((eof-object? line))
(when (match? line)
(when filename (display filename) (display ": "))
(display line) (newline))))
(define (do-args match? args)
(cond ((null? args) (do-input match? #f))
((null? (cdr args))
(with-input-from-file (car args)
(lambda () (do-input match? #f))))
(else (do ((args args (cdr args))) ((null? args))
(with-input-from-file (car args)
(lambda () (do-input match? (car args))))))))
(define (main args)
(if (string=? (car args) "-v")
(do-args
(complement (lambda (str) (rx-match? (make-rx (cadr args)) str)))
(cddr args))
(do-args (lambda (str) (rx-match? (make-rx (car args)) str)) (cdr args))))
(main (cdr (command-line)))