-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathPP-CODE-FILE
144 lines (122 loc) · 13.1 KB
/
PP-CODE-FILE
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
(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