;;; -*- Mode:LISP; Readtable:ZL; Base:10 -*-

(defun print-duping-stream(op &optional str &rest rest)
  (declare(special stream laststring asabove threshold))
  (selectq op
    (:printdup
     (if (string-equal str laststring)
	 (incf asabove)
       (progn
	 (cond
	   ((zerop asabove))
	   ((greaterp asabove threshold)
	    (format stream "~&<<<~d lines as above>>" asabove))
	   (t (format stream "~&~a" laststring)))
	 (setq asabove 0)
	 (if (stringp str)
	     (format stream "~&~a" str))))
     (setq laststring str))
    (:flush
     (print-duping-stream :printdup :flushing))
    (otherwise
     (stream-default-handler stream op str rest))))

(defun make-duping-stream(stream &optional (threshold 1))
  (declare(special stream threshold))
  (let((laststring "")
       (asabove 0))
    (declare(special stream laststring asabove threshold))
    (closure '(stream laststring asabove threshold)
	     'print-duping-stream)))