1 "MUDDLE PRETTY-PRINT, FRAME-SCANNER, AND OTHER ROUTINES"
2 <PRINC "/PPRINT/FRAMES">
5 "These atoms are placed in the ROOT oblist to allow general
6 access to their functions"
8 <COND (<NOT <GASSIGNED? NULL!->> <SETG NULL <INTERN <ATOM <ASCII 127>> <GET INITIAL OBLIST>>>)>
28 \f<BLOCK (<MOBLIST PP 37> <ROOT>)>
31 <SETG FRAMES ;"Prints FUNCT and ARGS for -n- frames down"
32 <FUNCTION ("OPTIONAL" (HOW-MANY 999) (FIRST 1))
35 <SET SPECAFT 0> ;"To make compatible with MEDDLE."
36 <REPEAT ((F <FRM .FIRST>) M (COMELE ,COMPONENTS))
37 <COND (<0? .HOW-MANY> <RETURN "FUNCT---ARGS">)
38 (<==? <FUNCT .F> TOPLEVEL> <RETURN TOPLEVEL>)>
39 <AND <==? <TYPE <VALUE <FUNCT .F>>> FSUBR>
40 <==? <FUNCT <FRAME .F>> EVAL>
41 <==? <TYPE <1 <ARGS <FRAME .F>>>> FORM>
42 <==? <FUNCT .F> <1 <1 <ARGS <FRAME .F>>>>>
48 <FORMS ;"Calling an internal PPRINT routine" <ARGS .F>>
49 SKIPIT <SET F <FRAME .F>>
50 <SET HOW-MANY <- .HOW-MANY 1>>
51 <SET FIRST <+ .FIRST 1>>
54 <DEFINE FRATM!- ("OPTIONAL" (HOW-MANY 9999) (FIRST 1))
55 <REPEAT ((F <FRM .FIRST>) (DEPTH!-FR 1) AF)
56 <COND (<L? .HOW-MANY .DEPTH!-FR> <RETURN "FRAME---FUNCTION">)
57 (<==? <FUNCT .F> TOPLEVEL> <RETURN TOPLEVEL>)>
58 <AND <==? <FUNCT .F> EVAL>
59 <1? <LENGTH <ARGS .F>>>
60 <==? <TYPE <SET AF <1 <ARGS .F>>>> FORM>
61 <==? <TYPE <1 .AF>> ATOM>
62 <==? <TYPE <OR <AND <GASSIGNED? <1 .AF>> ,<1 .AF>>
63 <AND <ASSIGNED? <1 .AF> .F> <LVAL <1 .AF> .F>>>>
69 <SET DEPTH!-FR <+ .DEPTH!-FR 1>> >>
71 <SETG FRM <FUNCTION (I)
73 <COND (<0? .I> <RETURN .F>)
74 (<==? <FUNCT .F> TOPLEVEL>
76 <PRINC "FRAMES FROM ">
81 <SETG LINPOS ;"Line position selector" 14>
82 <SETG LINLNT ;"Line length selector" 13>
83 <SETG PAGPOS ;"Page position selector" 16>
84 <SETG PAGLNT ;"Page length selector" 15>
85 <SET QUICKPRINT ;"Speed selector." T>
86 \f<SETG TABS ;"The n'th element is a string of n-1 tab characters"
101 <SETG SPACES ;"The n'th element is a string of n-1 space characters"
102 ["" " " " " " " " " " " " " " "]>
109 <SETG INDENT-TO <FUNCTION ( N "EXTRA" (NOW <LINPOS .OUTCHAN>))
110 ;"Print tabs and spaces to get to column -n-"
112 <PRINC <<- </ .N 8> </ .NOW 8 > -1> ,TABS>>
113 <PRINC <<- .N <LINPOS .OUTCHAN> -1> ,SPACES>>)>>>
114 \f<SETG COMPONENTS ;"Print the components of a structure in a column"
115 <FUNCTION (L "OPTIONAL" (OM <+ .M 1>) (STOP 0))
116 <REPEAT ((N <LINPOS .OUTCHAN>) (M 0))
117 <AND <EMPTY? <REST .L>> <SET M .OM>>
120 <COND (<EMPTY? <SET L <REST .L>>><RETURN DONE>)>
121 <AND <==? .STOP .L> <RETURN DONE>>
125 <SETG ELEMENTS ;"Print the components of a structure in a line."
126 <FUNCTION (L "OPTIONAL" (M <+ .M 1>) (STOP 0))
131 <AND <OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN T>>
134 <REPEAT ((N <LINPOS .OUTCHAN>) COM)
137 <COND (<OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN DONE>)>
138 <COND (.COM <TERPRI> <INDENT-TO .N>)>
143 <SETG SLOWFORMS <FUNCTION (L "AUX" (COMELE ,COMPONENTS)) ;"Pprint an object."
144 <COND (<MONAD? .L> <PRIN1 .L>) ;"If its a MONAD, just print it."
146 <COND (<FLATSIZE .L <MIN 59 <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>>>
147 <SET COMELE ,ELEMENTS>)> ;"If it fits, use ELEMENTS, else COMPONENTS."
148 <<GET <TYPE .L> PPRINT ;"Snarfed from BKD."
152 <SLOWFORMS <CHTYPE .L <PRIMTYPE .L>>>)>>)>>>
155 <SETG FASTFORMS ;"Pprint one item at the current page location"
157 <COND (<MONAD? .L> <PRIN1 .L>)
158 (<FLATSIZE .L <MIN 59 <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>>>
160 (ELSE <<GET <TYPE .L> PPRINT
164 <FASTFORMS <CHTYPE .L <PRIMTYPE .L>>>)>>)>>>
166 \f<SETG COMMENTS <FUNCTION ("AUX" MARG CMNT) ;"Prints comments. If no comment, returns false"
167 <COND (<SET CMNT <GET <REST .L 0> COMMENT>>
168 <SET MARG <COND (<EMPTY? <REST .L>> .M) (0)>>
169 <COND (<NOT <FLATSIZE .CMNT <- <LINLNT .OUTCHAN>
174 <INDENT-TO <- <MAX 2 <- <LINLNT .OUTCHAN>
175 <FLATSIZE .CMNT 9999>
182 <SETG SPEEDSEL <FUNCTION () ;"Check QUICKPRINT and select speed."
183 <OR <ASSIGNED? QUICKPRINT> <SET QUICKPRINT T>>
184 <SETG FORMS <COND (.QUICKPRINT ,FASTFORMS)
185 (ELSE ,SLOWFORMS)>>>>
186 \f"The following functions define the way to pprint a given data type"
187 "They are PUT on the appropriate type name"
188 "FORM is a special case - see next page."
191 <FUNCTION () <PRINC "("> <.COMELE .L > <PRINC ")">>>
194 <FUNCTION () <PRINC "["> <.COMELE .L > :L<PRINC "]">>>
197 <FUNCTION () <PRINC "#FUNCTION (" >
198 <FUNCBODY .L <LINPOS .OUTCHAN>>
203 <FUNCTION () <PRINC %<STRING !"! !"[>>
204 <.COMELE .L <+ .M 2>>
205 <PRINC %<STRING !"! !"]>>>>
208 <FUNCTION () <PRINC !"! > <FORMS <CHTYPE .L FORM>>>>
211 <FUNCTION () <PRIN1 .L>>>
213 <PUT TUPLE PPRINT <GET VECTOR PPRINT>>
215 <PUT ARGUMENTS PPRINT <GET VECTOR PPRINT>>
217 <PUT LOCD PPRINT <FUNCTION () <PRINC "#LOCD "> <FORMS <IN .L>>>>
219 <PUT RSUBR PPRINT <FUNCTION ()
222 <<GET VECTOR PPRINT>>
224 \f<DEFINE FUNCBODY FBA (L P "AUX" (M <+ .M 1>) (TEM %<>))
227 <COND (<==? <TYPE <1 .L>> ATOM>
228 <OR <CHECK <1 .L> -1> <TERPRI> <INDENT-TO .P>>
229 <PRIN1 <1 .L>> <PRINC !" >
230 <AND <EMPTY? <SET L <REST .L>>> <EXIT .FBA T>>)>
231 <COND (<==? <TYPE <1 .L>> LIST> <SET TEM <PRINARGL <1 .L> .P>> <SET L <REST .L>>)>
232 <COND (.TEM <COMPONENTS .L .M>)
233 (<CHECK .L -1> <PRINC !" > <ELEMENTS .L .M>)
234 (ELSE <TERPRI> <INDENT-TO .P> <COMPONENTS .L .M>)>)>>
236 <DEFINE CHECK (IT FUDGE) <FLATSIZE .IT <MIN <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M .FUDGE>>>>
238 <DEFINE PRINARGL (L PB "AUX" POS Q (OL .L))
239 <COND (<CHECK .L -2> <PRINC "("> <ELEMENTS .L> <PRINC ")"> %<>)
241 <OR <CHECK <SET Q <ABUNCH L>> -1> <TERPRI> <INDENT-TO .PB>>
243 <SET POS <LINPOS .OUTCHAN>>
244 <REPEAT ((NOTFIRST %<>) (N <+ .M 1>))
246 <COND (<==? <TYPE .Q> STRING>
247 <COND (.NOTFIRST <TERPRI> <INDENT-TO .POS>)>
250 (<CHECK .Q -2> <ELEMENTS .OL .N .L>)
251 (ELSE <COMPONENTS .OL .N .L>)>
259 <DEFINE ABUNCH (ATM "AUX" T)
260 <COND (<EMPTY? ..ATM> %<>)
261 (<==? <TYPE <1 ..ATM>> STRING>
263 <SET .ATM <REST ..ATM>>
267 <COND (<EMPTY? ..ATM> %<>)
268 (<==? <TYPE <1 ..ATM>> STRING> %<>)
269 (ELSE <SET T <1 ..ATM>> <SET .ATM <REST ..ATM>>)>>)>>
270 \f"How to print FORM and its special cases."
271 "Special cases for FORM are PUT on the appropriate function."
273 <PUT FORM PPRINT <FUNCTION () <<GET <1 .L> SPECFORM ',NORMFORM>>>>
275 <DEFINE NORMFORM ("AUX" (PN <+ 1 <LINPOS .OUTCHAN>>))
278 <COND (<==? .COMELE ,ELEMENTS> <COMEND>)
279 (<FORMAHEAD .L> <COMMENTS> <TERPRI> <INDENT-TO .PN>
280 <COND (<FLATSIZE <REST .L> <- <LINLNT .OUTCHAN>
283 <ELEMENTS <REST .L>>)
284 (T <COMPONENTS <REST .L>>)>)
289 <SETG COMEND <FUNCTION ("AUX" (PPN <LINPOS .OUTCHAN>))
290 <COND (<COMMENTS> <TERPRI> <INDENT-TO .PPN>)>
291 <COND (<EMPTY? <REST .L>>)
292 (<PRINC !" > <.COMELE <REST .L>>)> >>
295 <DEFINE FORMAHEAD (ML "AUX" (AVSP <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>))
296 <COND (<AND <==? <TYPE <1 .ML>> FORM>
297 <NOT <EMPTY? <REST .ML>>>
298 <NOT <FLATSIZE <1 .ML> <MIN 59 .AVSP>>>>
302 <COND (<L? <LENGTH .ML> 2> <RETURN #FALSE ()>)
303 (<NOT <==? <TYPE <2 .ML>> FORM>> <RETURN #FALSE ()>)
304 (<FLATSIZE <1 <2 .ML>>
308 <FLATSIZE <1 .ML> 99999999>>>
311 (ELSE <RETURN T>)>>)>>
314 <PUT LVAL SPECFORM <FUNCTION () <DAMMIT !".>>>
316 <PUT GVAL SPECFORM <FUNCTION () <DAMMIT !",>>>
318 <PUT QUOTE SPECFORM <FUNCTION () <DAMMIT !"'>>>
321 <COND (<==? 2 <LENGTH .L>>
322 <PRINC .Q> ;"No fucking comments printed on . , or ' "
323 <COND (<EMPTY? <REST .L>>)
324 (<.COMELE <REST .L>>)>)
327 <PUT FUNCTION SPECFORM <FUNCTION ()
329 <FUNCBODY <REST .L> <- <LINPOS .OUTCHAN> 2>>
332 <PUT DEFINE SPECFORM <FUNCTION ()
334 <SET POS <LINPOS .OUTCHAN>>
335 <COND (<EMPTY? <SET L <REST .L>>>)
339 <FUNCBODY <REST .L> .POS>)>
342 <PUT REPEAT SPECFORM <FUNCTION ("AUX" (CPOS <+ <LINPOS .OUTCHAN> 3>))
347 <.COMELE <REST .L 2>>
349 \f<SETG PPRINT <FUNCTION PPRINT (L "OPTIONAL" (OUTCHAN .OUTCHAN))
350 <COND (<NOT <==? <TYPE .L> ATOM>> <EPRINT .L>)
352 <COND (<==? <TYPE ,.L> FUNCTION>
353 <EPRINT <FORM DEFINE .L !,.L>>)
354 (<==? <TYPE ,.L> RSUBR>
355 <EPRINT <FORM SETG .L <FORM RSUBR <FORM QUOTE <CHTYPE ,.L VECTOR>>>>>)
356 (ELSE <EPRINT <FORM SETG .L <FORM QUOTE ,.L>>>)>)
357 (<AND <BOUND? .L> <ASSIGNED? .L>>
360 <COND (<==? <TYPE ..L> FUNCTION>
361 <FORM FUNCTION !..L>)
362 (<==? <TYPE ..L> RSUBR>
363 <FORM RSUBR <CHTYPE ..L VECTOR>>)
364 (ELSE <FORM QUOTE ..L>)>>>)
365 (ELSE <PRINT .L> #FALSE ("NAKED ATOM?"))>>>
367 <SETG EPRINT <FUNCTION (L "EXTRA" (M 0) (COMELE ,COMPONENTS))
372 ,NULL ;"Null atom returned" >>
374 <DEFINE PPRINF FACT (INF "OPTIONAL" (OUTF ("" "" "TPL"))
375 "AUX" (INCH <OPEN "READ" !.INF>)
377 <OR .INCH <EXIT .FACT "BAD FILE NAME?">>
378 <PUT <SET OUTCH <OPEN "PRINT" !.OUTF>> 13 100>
379 <PUT <SET NULLO <OPEN "PRINT" "" "" "NUL">> 13 100>
380 <REPEAT ((BOTH (<PUT .OUTCH 15 99999> <PUT .NULLO 15 99999>))
382 <PPRINT <SET Q <READ '<RETURN T> .INCH>>
383 <PUT .NULLO 16 <16 .OUTCH>>>
384 <AND <G? <16 .NULLO> 58> <PRINC <ASCII 12> .BOTH>>
397 <COND (<LOOKUP "PPRINT" <1 .OBLIST>> <SETG PPRINT ,PPRINT!-> <REMOVE PPRINT>)>
398 <COND (<LOOKUP "FRAMES" <1 .OBLIST>> <SETG FRAMES ,FRAMES!-> <REMOVE FRAMES>)>
399 <COND (<LOOKUP "FRM" <1 .OBLIST>> <SETG FRM ,FRM!-> <REMOVE FRM>)>
400 <COND (<LOOKUP "PPRINF" <1 .OBLIST>> <SETG PPRINF ,PPRINF!-> <REMOVE PPRINF>)>
401 \f\f\f\f\ 3\fð`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\að`Á
\83\a