(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