(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