; file bundles
(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 (write-header)
(for-each (lambda (x) (display x) (newline))
'("#! /usr/bin/petite --script"
"(define (do-file f)"
" (define (write-line x) (display x) (newline))"
" (with-output-to-file (car f) (lambda ()"
" (for-each write-line (cdr f)))))"
"(for-each do-file '(")))
(define (do-file f)
(display "(") (write f) (newline)
(with-input-from-file f (lambda ()
(do ((x (read-line) (read-line)))
((eof-object? x))
(write x) (newline))))
(display ")") (newline))
(define (bundle out-file . in-files)
(with-output-to-file out-file (lambda ()
(write-header)
(for-each do-file in-files)
(display "))") (newline))))