;;; -*- 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. 16.)
				(16. 8.)))
		  (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)
      (format outstream "~&File ~A: Characters: ~S, Byte size ~D.~%"
	      (truename instream) (send instream :get :characters) (send instream :get :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))))))

(defun dump-fasl-groups  (infile &rest arguments &key
		     (start 0) end
		     outfile (outstream *terminal-io*)
		     (base 8) (line-base base) (line-bytes 8.)
		     (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 16.)
      (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"))))
	(let* ((format-string (base-format base))
	       (lformat-string (base-format line-base))
	       (format-width (ceiling (log (lsh 1 16) base)))
	       (buffer (make-array 1024 :element-type `(unsigned-byte 16)))
	       (reread-byte nil)
	       (char-buffer (make-string (* (+ line-bytes (ceiling line-bytes mark-interval) 1)
					    2)))
	       (length (send instream :length))
	       (lformat-width (ceiling (log (1- length) base)))
	       (bpos 1024.)
	       (stop (if end (min end length) length)))
	  (macrolet ((next-byte ()
				`(if reread-byte
				     (prog1 reread-byte (setq reread-byte nil))
				   (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))))
	    (when (= start 0)
	      (let ((byte (next-byte)))
		(if (= byte #o143150)
		    (write-string "The first header nibble is OK." outstream)
		  (format outstream "The first header nibble is wrong: ~@?" format-string format-width byte))
		(terpri outstream))
	      (incf start))
	    (when (= start 1)
	      (let ((byte (next-byte)))
		(if (= byte #o71660)
		    (write-string "The second header nibble is OK." outstream)
		  (format outstream "The second header nibble is wrong: ~@?" format-string format-width byte))
		(terpri outstream))
	      (incf start))
	    (loop for group = start then (or ngroup (+ group group-length))
		  for ngroup = nil
		  until ( group stop)
		  for byte = (next-byte)
		  for group-check = (ldb-test sys:%%fasl-group-check byte)
		  for group-flag = (ldb-test sys:%%fasl-group-flag byte)
		  for group-length = (ldb sys:%%fasl-group-length byte)
		  for group-type = (aref si:fasl-group-dispatch
					 (ldb sys:%%fasl-group-type byte))
		  do
		  (when (and group-check (= group-length #o377))
		    (when ( group stop)
		      (write-string "Group ends prematurely." outstream)
		      (terpri outstream))
		    (setq group-length (next-byte)))
		  (cond (group-check
			 (format outstream "~D: ~A Flag = ~S, Length = ~D."
				 group group-type group-flag group-length)
			 (terpri outstream)
			 (when (> (+ group group-length) stop)
			   (write-string "Group ends prematurely." outstream)
			   (terpri outstream)))
			(t (write-string "Extra bytes not in any group." outstream)
			   (terpri outstream)
			   (setq reread-byte byte)
			   (decf group)))
		  (loop with group-end = (if group-check
					     (min stop (+ group group-length))
					   stop)
			with suppress = nil
			for cpos = 0			;Character position in char buffer
			until suppress
			for lpos from (1+ group) to group-end 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
			      (loop for pos from gpos below ngpos
				    for byte = (if suppress 0 (next-byte))
				    do
				    (when (and (not group-check)	;Desynched; looking for next group
					       (ldb-test sys:%%fasl-group-check byte))
				      (setq reread-byte byte)
				      (setq ngroup pos)
				      (setq suppress t))
				    (if suppress
					(write-string "                  " outstream :end (1+ format-width))
				      (progn (format outstream format-string format-width byte)
					     (write-char #\Space outstream)
					     (do-char (ldb (byte 8 0) byte))
					     (do-char (ldb (byte 8 8) byte))))
				    (setq suppress (or suppress ( pos group-end)))
				    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)))))))))