;;; -*- 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 format-string = (ecase base
				   (10. "~v,' D")
				   (8. "~v,'0D")
				   (16. "~v,'0X"))
	    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 format-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))))))