;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

(defun dump-file (infile &rest arguments &key outfile (outstream *terminal-io*) (byte-size 8) (start 0) end
		  (line-bytes 16) (mark-interval 4) (base 10.))
  (if outfile
    (with-open-file (outstream (fs:merge-pathnames outfile (fs:merge-pathnames "SYS:.QFASL"))
			       :direction :output :characters t)
      (apply #'dump-file infile :outstream outstream :outfile nil arguments))
    (with-open-file (instream infile :direction :input :characters nil :byte-size byte-size)
      (unless (zerop start)
	(send instream :set-pointer start))
      (fresh-line outstream)
      (loop with buffer = (make-array 1024 :element-type `(unsigned-byte ,byte-size))
	    with char-buffer = (make-string (+ line-bytes (ceiling line-bytes mark-interval) 1))
	    with length = (send instream :length)
	    with bpos = 1024.
	    for cpos = 0			;Character position in char buffer
	    for pos from start to (if end (min end length) length) by mark-interval
	    for lpos = 0 then (if ( lpos line-bytes) 0 (1+ lpos))
	    do
	    (write pos :stream outstream :radix nil :base base :pretty nil)
	    (write-string ":  " outstream)
	    (macrolet ((next-byte ()
			`(progn (when ( bpos 1024.)
				  (send instream :string-in nil buffer)
				  (setq bpos 0))
				(aref buffer (prog1 bpos (incf bpos))))))
	      (loop ;; Until out of room in the group, the line, or the file range requested.
		    repeat (min mark-interval (- lpos line-bytes) (- length pos))
		    for byte = (next-byte)
		    for char = (if (and (< byte (char-code #\Null))
					(not (= byte (char-code #\Altmode))))
				   (code-char byte)
				 #\ )
		    do
		    (write byte :stream outstream :radix nil :base base :pretty nil)
		    (write-char #\Space outstream)
		    (setf (aref char-buffer cpos) char)
		    (incf cpos)
		    finally
		    (write-char #\| outstream)
		    (setf (aref char-buffer cpos) #\Space)
		    (incf cpos)))
	    (write-string char-buffer outstream :end cpos)
	    (terpri outstream)))))