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

(defun dump-file (infile &rest arguments &key
		  (byte-size 8) (start 0) end
		  outfile (outstream *terminal-io*)
		  (base 10.) (line-base base)
		  (line-bytes (ecase byte-size
				(8. 8.)
				(16. 16.)))
		  (mark-interval 4))
  (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)
      (labels ((base-format (base)
		 (ecase base
		   (10. "~v,' D")
		   (8. "~v,'0O")
		   (16. "~v,'0X"))))
	(loop with format-string = (base-format base)
	      with lformat-string = (base-format line-base)
	      with format-width = (ceiling (log (lsh 1 byte-size) base))
	      with buffer = (make-array 1024 :element-type `(unsigned-byte ,byte-size))
	      with char-buffer = (make-string (* (+ line-bytes (ceiling line-bytes mark-interval) 1)
						 (ecase byte-size
						   (8. 1)
						   (16. 2))))
	      with length = (send instream :length)
	      with lformat-width = (ceiling (log (1- length) base))
	      with bpos = 1024.
	      for cpos = 0			;Character position in char buffer
	      for lpos from start to (if end (min end length) length) by line-bytes
	      for nlpos = (+ lpos line-bytes)
	      do
	      (format outstream lformat-string lformat-width lpos)
	      (write-string ": " outstream)
	      (loop for gpos from lpos below nlpos by mark-interval
		    for ngpos = (+ gpos mark-interval)
		    do
		    (macrolet ((next-byte ()
					  `(progn (when ( bpos 1024.)
						    (send instream :string-in nil buffer)
						    (setq bpos 0))
						  (aref buffer (prog1 bpos (incf bpos)))))
			       (do-char (byte)
					`(let* ((bb ,byte)
						(char (if (and (< bb (char-code #\Null))
							       (not (= bb (char-code #\Altmode))))
							  (code-char bb)
							#\ )))
					   (setf (aref char-buffer cpos) char)
					   (incf cpos))))
		      (loop for pos from gpos below ngpos
			    for suppress = ( pos length)
			    for byte = (if suppress 0 (next-byte))
			    do
			    (if suppress
				(write-string "                  " outstream :end (1+ format-width))
			      (progn (format outstream format-string format-width byte)
				     (write-char #\Space outstream)
				     (ecase byte-size
				       (8. (do-char byte))
				       (16. (do-char (ldb (byte 8 0) byte))
					    (do-char (ldb (byte 8 8) byte))))))
			    finally
			    (if suppress
				(write-string "  " outstream)
			      (write-string "| " outstream))
			    (unless suppress
			      (setf (aref char-buffer cpos) #\Space)
			      (incf cpos)))))
	      (write-string char-buffer outstream :end cpos)
	      (terpri outstream)))))))