;;; -*- 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)))))) (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)))) (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) (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)))))))))