(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
(il:filecreated "23-Feb-88 11:13:23" il:{erinyes}<lispusers>lyric>pp-code-file.\;1 13344
il:|changes| il:|to:| (il:functions pp-code-file-internal)
il:|previous| il:|date:| " 3-Nov-87 12:26:37"
il:|{IE:PARC:XEROX}<LISP>LYRIC>LISPUSERS>PP-CODE-FILE.;2|)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:pp-code-filecoms)
(il:rpaqq il:pp-code-filecoms ((il:prop (il:makefile-environment il:filetype) il:pp-code-file) (il:functions pp-code-file pp-code-file-internal file-manager-file-p maybe-pp-code-file pretty-listfiles1) (il:commands "see") (il:p (il:movd? (quote il:listfiles1) (quote il:listfiles1-original)) (il:/movd (quote pretty-listfiles1) (quote il:listfiles1)) (il:changename (quote il:fb.fastsee.onefile) (quote il:pfcopybytes) (quote maybe-pp-code-file))) (il:coms (il:fns il:superprint/comment) (il:declare\: il:eval@compile il:dontcopy (il:files (il:loadcomp) il:newprintdef))))
)
(il:putprops il:pp-code-file il:makefile-environment (:readtable "XCL" :package "XCL"))
(il:putprops il:pp-code-file il:filetype :compile-file)
(defun pp-code-file (code-file &optional (output *standard-output*) (reader-env (file-manager-file-p code-file))) "Pretty print contents of file manager file" (declare (special il:*old-interlisp-read-environment*)) (if reader-env (let ((in-stream (if (streamp code-file) code-file (open code-file :direction :input)))) (unwind-protect (let ((out-stream (cond ((streamp output) output) ((il:windowp output) (il:getstream output)) (t (open output :direction :output :if-exists :new-version)))) (abort t)) (unwind-protect (il:with-reader-environment reader-env (unless (eq reader-env il:*old-interlisp-read-environment*) (il:* il:|;;| "if FILE-MANAGER-FILE-P read a IL:DEFINE-FILE-INFO expression to get the reader environment then we have to both print one to the output as well as read this one again.") (il:print-reader-environment reader-env out-stream) (terpri out-stream) (il:with-reader-environment il:*old-interlisp-read-environment* (read in-stream))) (pp-code-file-internal in-stream out-stream) (setq abort nil) (pathname out-stream)) (unless (or (streamp output) (il:windowp output)) (close out-stream :abort abort)))) (unless (streamp code-file) (close in-stream)))) (error "~S not a File Manager file" code-file)))
(defun pp-code-file-internal (il:in-stream il:out-stream) (il:* il:|;;| "presume read environment has been set up for us") (il:* il:|;;| "we just need to pretty print from IN-STREAM to OUT-STREAM ") (il:* il:|;;| "i can write this much easier in interlisp...") (il:bind (il:**comment**flg il:← nil) (il:*print-semicolon-comments* il:← t) (il:*divide-long-strings* il:← t) (il:prettyflg il:← t) il:names il:sexp declare (il:specvars il:**comment**flg il:*print-semicolon-comments* il:*divide-long-strings* il:prettyflg) il:eachtime (il:skipseprs il:in-stream *readtable*) il:until (il:eofp il:in-stream) il:do (il:* il:\; "read an expression") (il:setq il:sexp (il:read il:in-stream *readtable*)) (cond ((and (null il:names) (il:listp il:sexp) (eq (car il:sexp) (quote il:rpaqq)) (il:strequal (il:substring (cadr il:sexp) -4) "COMS")) (il:* il:|;;| "found the COMS") (let ((il:coms (caddr il:sexp))) (il:* il:|;;| "pull out the function names") (il:setq il:names (il:append (il:infilecoms? nil (quote il:fns) il:coms) (il:infilecoms? nil (quote il:functions) il:coms)))))) (il:* il:|;;| "pretty print the expression") (if (eq (car il:sexp) (quote il:defineq)) (progn (il:* il:|;;| "print blank lines between DEFINEQ defs") (format il:out-stream "(~S~%" (car il:sexp)) (dolist (il:def (cdr il:sexp)) (il:terpri il:out-stream) (il:printdef il:def nil (and (il:listp il:sexp) (eq (car il:sexp) (quote il:defineq))) nil il:names il:out-stream) (il:terpri il:out-stream)) (format il:out-stream ")~%" (car il:sexp))) (il:printdef il:sexp nil nil nil il:names il:out-stream)) (il:* il:|;;| "leave a blank line between each") (il:terpri il:out-stream)))
(defun file-manager-file-p (file) (il:* il:|;;| "Returns NIL or a reader environment.") (declare (special il:*old-interlisp-read-environment*)) (with-open-stream (stream (open file :direction :input)) (il:with-reader-environment il:*old-interlisp-read-environment* (and (eql #\( (peek-char t stream nil nil)) (let ((define-file-info (car (il:nlsetq (read stream))))) (if (consp define-file-info) (case (car define-file-info) (il:define-file-info (il:\\do-define-file-info nil (cdr define-file-info))) (il:filecreated il:*old-interlisp-read-environment*))))))))
(defun maybe-pp-code-file (input &optional (output *standard-output*)) (let ((reader-env (file-manager-file-p input))) (if reader-env (pp-code-file input output reader-env) (let ((in-stream (if (streamp input) input (open input :direction :input)))) (unwind-protect (il:copychars in-stream (il:getstream output (quote il:output))) (unless (streamp input) (close in-stream)))))))
(defun pretty-listfiles1 (file options) (il:* il:|;;| "MOVD'd onto IL:LISTFILES1.") (let ((reader-env (file-manager-file-p file))) (if reader-env (let* ((pathname (probe-file file)) (namestring (namestring pathname)) (temp-file (quote nil))) (declare (global il:defaultprintertype)) (with-open-stream (print-stream (il:openimagestream "{LPT}" il:defaultprintertype)) (pp-code-file pathname print-stream) (il:streamprop print-stream (quote il:printoptions) (list* (quote il:document.name) (or (il:listget options (quote il:document.name)) namestring) (quote il:document.creation.date) (il:getfileinfo pathname (quote il:icreationdate)) (quote il:heading) (or (il:listget options (quote il:heading)) (il:concat namestring " " (il:getfileinfo pathname (quote il:creationdate)))) options))) (if (il:listget options (quote il:delete)) (delete-file pathname))) (il:* il:|;;| "not a code file -- punt") (il:listfiles1-original file options))))
(defcommand "see" (il:file) "print the contents of FILE on the screen" (maybe-pp-code-file il:file))
(il:movd? (quote il:listfiles1) (quote il:listfiles1-original))
(il:/movd (quote pretty-listfiles1) (quote il:listfiles1))
(il:changename (quote il:fb.fastsee.onefile) (quote il:pfcopybytes) (quote maybe-pp-code-file))
(il:defineq
(il:superprint/comment
(il:lambda (il:l il:file) (il:* il:\; "Edited 2-Nov-87 14:13 by drc:")
(cond
((and il:**comment**flg (not il:fileflg)
(not il:makemap)) (il:* il:\; "If:")
(il:* il:\;
"There's a shorthand for comments, and")
(il:* il:\;
"We're not printing to a file, and")
(il:* il:\;
"Ww're not making the file map, then")
(il:* il:|;;|
"Print out the shorthand version of the comment, watching out for overflowing the current line.")
(cond
((> (+ (il:dspxposition nil il:file)
(il:stringwidth il:**comment**flg il:file))
(il:dsprightmargin nil il:file))
(il:prinendline (il:dspleftmargin nil il:file)
il:file)))
(il:prin1s il:**comment**flg nil il:file))
(t (prog (il:comment-lmargin il:comment-rmargin il:rightflg il:flush-leftp il:semip il:body)
(cond
((il:setq il:rightflg (not (or (il:superprinteq (cadr il:l)
il:commentflg)
(cond
((il:setq il:semip (il:semi-colon-comment-p
il:l))
(il:* il:\;
"Only 1-semi comments go in right margin")
(il:neq il:semip 1))
(t (il:* il:\; "use size heuristic")
(> (il:length il:l)
10))))))
(il:* il:\;
"Print comment in the righthand margin")
(il:setq il:comment-lmargin (or il:commentcol (il:superprint/comment1 il:l
il:rmargin il:file)))
(il:setq il:comment-rmargin il:rmargin))
((and (eq il:semip 3)
(not il:makemap)) (il:* il:\;
"Comment should be printed flush left. Don't do this with DEdit lest we confuse it")
(il:setq il:comment-lmargin (il:dspleftmargin nil il:file))
(il:setq il:comment-rmargin il:rmargin))
((and (eq il:semip 2)
(not il:makemap)) (il:* il:\; "indent like code")
(il:setq il:comment-lmargin (min il:left (+ (il:dspleftmargin nil il:file)
(il:iquotient (- il:rmargin
(il:dspleftmargin
nil il:file))
3))))
(il:setq il:comment-rmargin il:rmargin))
(t (il:* il:\;
"Print comment centered and wide")
(il:setq il:comment-lmargin (il:fixr (il:times 0.1 il:rmargin)))
(il:setq il:comment-rmargin (- il:rmargin il:comment-lmargin))
(cond
((eq il:comment-lmargin (il:dspxposition nil il:file))
(il:* il:|;;| "HACK: Almost certainly called from REPP, so we must supress the normal leading and trailing blank lines as they have already been done")
(il:setq il:rightflg t)))))
(cond
((null il:rightflg)
(il:prinendline il:comment-lmargin il:file))
((< il:comment-lmargin (il:dspxposition nil il:file))
(il:prinendline il:comment-lmargin il:file))
(t (il:dspxposition il:comment-lmargin il:file)))
(il:setfont (prog1 (il:setfont il:commentfont il:file)
(cond
((and il:semip (not il:makemap)
(il:stringp (il:setq il:body
(car (il:listp (cdr (il:listp (cdr il:l)))))
))
(null (cdddr il:l))
(or (il:imagestreamp il:file)
il:*print-semicolon-comments*))
(il:* il:\; "do nice semi-colon stuff")
(il:prin2-long-string il:body il:file nil nil
il:comment-lmargin il:comment-rmargin t il:semip))
(t (il:superprint/comment2 il:l il:comment-lmargin
(il:iquotient (+ il:comment-lmargin
il:comment-rmargin)
2)
il:comment-rmargin il:file))))
il:file)
(cond
((and (or (and il:semip (not il:makemap))
(not il:rightflg))
(not (= (il:dspxposition nil il:file)
(il:dspleftmargin nil il:file))))
(il:* il:|;;| "AR 8475 JDS 4/16/87: If there's a semi-colon comment on this line, and we're not making the file map (??), and RIGHTFLG is NIL (whatever that means) then force a new line.")
(il:prinendline (il:dspleftmargin nil il:file)
il:file))) (il:* il:\;
"(OR RIGHTFLG (PRINENDLINE 0 FILE))")
(return il:l))))))
)
(il:declare\: il:eval@compile il:dontcopy
(il:filesload (il:loadcomp) il:newprintdef)
)
(il:putprops il:pp-code-file il:copyright ("Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
(il:filemap (nil (6248 13151 (il:superprint/comment 6261 . 13149)))))
il:stop