(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
(il:filecreated " 3-Nov-87 12:26:37" il:|{POGO:AISNORTH:XEROX}<CUTTING>LISP>PP-CODE-FILE.;16| 18589
il:|changes| il:|to:| (il:vars il:pp-code-filecoms)
(il:functions pp-code-file-internal pretty-listfiles1)
il:|previous| il:|date:| " 9-Sep-87 16:49:20"
il:|{POGO:AISNORTH:XEROX}<CUTTING>LISP>PP-CODE-FILE.;13|)
; Copyright (c) 1987 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? 'il:listfiles1 'il:listfiles1-original)
(il:/movd 'pretty-listfiles1 'il:listfiles1)
(il:changename 'il:fb.fastsee.onefile 'il:pfcopybytes
'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:names il:sexp declare (il:specvars il:**comment**flg il:*print-semicolon-comments*
il:*divide-long-strings*) 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)
'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 'il:fns il:coms)
(il:infilecoms? nil 'il:functions il:coms))))))
(il:* il:|;;| "pretty print the expression")
(if (eq (car il:sexp)
'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)
'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 '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 '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 'il:printoptions
(list* 'il:document.name (or (il:listget options
'il:document.name)
namestring)
'il:document.creation.date
(il:getfileinfo pathname 'il:icreationdate)
'il:heading
(or (il:listget options 'il:heading)
(il:concat namestring " " (il:getfileinfo
pathname
'il:creationdate))
)
options)))
(if (il:listget options '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? 'il:listfiles1 'il:listfiles1-original)
(il:/movd 'pretty-listfiles1 'il:listfiles1)
(il:changename 'il:fb.fastsee.onefile 'il:pfcopybytes '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))
(il:declare\: il:dontcopy
(il:filemap (nil (11491 18394 (il:superprint/comment 11504 . 18392)))))
il:stop