"MUDDLE PRETTY-PRINT, FRAME-SCANNER, AND OTHER ROUTINES"
<PRINC "/PPRINT/FRAMES">
<BLOCK (<ROOT>)>

"These atoms are placed in the ROOT oblist to allow general
	access to their functions" 
M
<COND (<NOT <GASSIGNED? NULL!->> <SETG NULL <INTERN <ATOM <ASCII 127>> <GET INITIAL OBLIST>>>)>
PPRINF
SPECBEF
SPECAFT
FORMS
PPRINT
EPRINT
FRAMES
FRATM
FRM
INDENT-TO
LINPOS
LINLNT
PAGPOS
PAGLNT
QUICKPRINT
PP	;"OBLIST"

<ENDBLOCK>

<BLOCK (<MOBLIST PP 37> <ROOT>)>


<SETG FRAMES	;"Prints FUNCT and ARGS for -n- frames down" 
    <FUNCTION ("OPTIONAL" (HOW-MANY 999) (FIRST 1))
	<SPEEDSEL>
	<SET SPECBEF 0>
	<SET SPECAFT 0>	;"To make compatible with MEDDLE."
	<REPEAT ((F <FRM .FIRST>) M (COMELE ,COMPONENTS))
		<COND (<0? .HOW-MANY>  <RETURN "FUNCT---ARGS">)
			(<==? <FUNCT .F> TOPLEVEL> <RETURN TOPLEVEL>)>
		<AND <==? <TYPE <VALUE <FUNCT .F>>> FSUBR>
			<==? <FUNCT <FRAME .F>> EVAL>
			<==? <TYPE <1 <ARGS <FRAME .F>>>> FORM>
			<==? <FUNCT .F> <1 <1 <ARGS <FRAME .F>>>>>
				<GO SKIPIT>>
		<PRINT .FIRST>
		<PRINC <FUNCT .F>>
		<PRINC "	">
		<SET M 0>
		<FORMS	;"Calling an internal PPRINT routine"	<ARGS .F>>
	SKIPIT	<SET F <FRAME .F>>
		<SET HOW-MANY <- .HOW-MANY 1>>
		<SET FIRST <+ .FIRST 1>>
	>>>

<DEFINE FRATM!- ("OPTIONAL" (HOW-MANY 9999) (FIRST 1))
	<REPEAT ((F <FRM .FIRST>) (DEPTH!-FR 1) AF)
		<COND (<L? .HOW-MANY .DEPTH!-FR> <RETURN "FRAME---FUNCTION">)
		      (<==? <FUNCT .F> TOPLEVEL> <RETURN TOPLEVEL>)>
		<AND	<==? <FUNCT .F> EVAL>
			<1? <LENGTH <ARGS .F>>>
			<==? <TYPE <SET AF <1 <ARGS .F>>>> FORM>
			<==? <TYPE <1 .AF>> ATOM>
			<==? <TYPE <OR <AND <GASSIGNED? <1 .AF>> ,<1 .AF>>
					<AND <ASSIGNED? <1 .AF> .F> <LVAL <1 .AF> .F>>>>
				FUNCTION>
			<PRINT .DEPTH!-FR>
			<PRINC !"	>
			<PRIN1 <1 .AF>>>
		<SET F <FRAME .F>>
		<SET DEPTH!-FR <+ .DEPTH!-FR 1>> >>

<SETG FRM <FUNCTION (I)
	<REPEAT ((F <FRAME>))
		<COND	(<0? .I> <RETURN .F>)
			(<==? <FUNCT .F> TOPLEVEL>
			 <PRINT .I>
			 <PRINC "FRAMES FROM ">
			 <RETURN .F>)>
		<SET F <FRAME .F>>
		<SET I <- .I 1>>>>>

<SETG LINPOS	;"Line position selector"	14>
<SETG LINLNT	;"Line length selector"		13>
<SETG PAGPOS	;"Page position selector"	16>
<SETG PAGLNT	;"Page length selector"		15>
<SET QUICKPRINT	;"Speed selector."		T>
<SETG TABS	;"The n'th element is a string of n-1 tab characters"
     ["" "	" "		" "			"
"				"
"					"
"						"
"							"
"								"
"									"
"										"
"											"
"												"]>




<SETG SPACES	;"The n'th element is a string of n-1 space characters"
     ["" " " "  " "   " "    " "     " "      " "       "]>






<SETG INDENT-TO <FUNCTION ( N "EXTRA" (NOW <LINPOS .OUTCHAN>))
			;"Print tabs and spaces to get to column -n-"
	<COND (<G? .N .NOW>
		<PRINC <<- </ .N 8> </ .NOW 8 > -1> ,TABS>>
		<PRINC <<- .N <LINPOS .OUTCHAN> -1> ,SPACES>>)>>>
<SETG COMPONENTS	;"Print the components of a structure in a column" 
      <FUNCTION (L "OPTIONAL" (OM <+ .M 1>) (STOP 0))
	<REPEAT ((N <LINPOS .OUTCHAN>) (M 0))
		<AND <EMPTY? <REST .L>> <SET M .OM>>
		<FORMS <1 .L>>
		<COMMENTS>
		<COND (<EMPTY? <SET L <REST .L>>><RETURN DONE>)>
		<AND <==? .STOP .L> <RETURN DONE>>
		<TERPRI>
		<INDENT-TO .N>>>>

<SETG ELEMENTS	;"Print the components of a structure in a line."
     <FUNCTION (L "OPTIONAL" (M <+ .M 1>) (STOP 0))
	<COND (<EMPTY? .L>)
	      (.QUICKPRINT
		<REPEAT ()
			<PRIN1 <1 .L>>
			<AND <OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN T>>
			<PRINC !" >>)
	      (ELSE
		<REPEAT ((N <LINPOS .OUTCHAN>) COM)
			<FORMS <1 .L>>
			<SET COM <COMMENTS>>
			<COND (<OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN DONE>)>
			<COND (.COM <TERPRI> <INDENT-TO .N>)>
			<PRINC !" >>)>>>



<SETG SLOWFORMS <FUNCTION (L "AUX" (COMELE ,COMPONENTS))	;"Pprint an object."
	<COND	(<MONAD? .L> <PRIN1 .L>)			;"If its a MONAD, just print it."
		(ELSE
		 <COND	(<FLATSIZE .L <MIN 59 <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>>>
			  <SET COMELE ,ELEMENTS>)> ;"If it fits, use ELEMENTS, else COMPONENTS."
		 <<GET <TYPE .L> PPRINT ;"Snarfed from BKD."
			'#FUNCTION (()
				<PRINC "#">
				<PRIN1 <TYPE .L>>
				<SLOWFORMS <CHTYPE .L <PRIMTYPE .L>>>)>>)>>>


<SETG FASTFORMS	;"Pprint one item at the current page location"
      <FUNCTION (L)
	<COND (<MONAD? .L> <PRIN1 .L>)
	      (<FLATSIZE .L <MIN 59 <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>>>
		<PRIN1 .L>)
	      (ELSE <<GET <TYPE .L> PPRINT

		   '#FUNCTION ( ()
				<PRINC "#">
				<PRIN1 <TYPE .L>>
				<FASTFORMS <CHTYPE .L <PRIMTYPE .L>>>)>>)>>>

<SETG COMMENTS <FUNCTION ("AUX" MARG CMNT) ;"Prints comments.  If no comment, returns false"
	<COND (<SET CMNT <GET <REST .L 0> COMMENT>>
		<SET MARG <COND (<EMPTY? <REST .L>> .M) (0)>>
		<COND (<NOT <FLATSIZE .CMNT <- <LINLNT .OUTCHAN>
						<LINPOS .OUTCHAN>
						.MARG
						2>>>
				<TERPRI>)>
		<INDENT-TO <- <MAX 2 <-	<LINLNT .OUTCHAN>
					<FLATSIZE .CMNT 9999>
					.MARG>>
				2>>
		<PRINC " ;">
		<PRIN1 .CMNT>)>>>


<SETG SPEEDSEL <FUNCTION ()	;"Check QUICKPRINT and select speed."
	<OR <ASSIGNED? QUICKPRINT> <SET QUICKPRINT T>>
	<SETG FORMS <COND (.QUICKPRINT ,FASTFORMS)
			  (ELSE ,SLOWFORMS)>>>>
"The following functions define the way to pprint a given data type"
"They are PUT on the appropriate type name"
"FORM is a special case - see next page."

<PUT LIST PPRINT
	<FUNCTION () <PRINC "("> <.COMELE .L > <PRINC ")">>>

<PUT VECTOR PPRINT
	<FUNCTION () <PRINC "[">  <.COMELE .L > :L<PRINC "]">>>

<PUT FUNCTION PPRINT
	<FUNCTION () <PRINC "#FUNCTION (" >
		     <FUNCBODY .L <LINPOS .OUTCHAN>>
		     <PRINC ")">>>


<PUT UVECTOR PPRINT
	<FUNCTION ()	<PRINC %<STRING !"! !"[>>
			<.COMELE .L <+ .M 2>>
			<PRINC %<STRING !"! !"]>>>>

<PUT SEGMENT PPRINT
	<FUNCTION () <PRINC !"! > <FORMS <CHTYPE .L FORM>>>>

<PUT STRING PPRINT
	<FUNCTION () <PRIN1 .L>>>

<PUT TUPLE PPRINT <GET VECTOR PPRINT>>

<PUT ARGUMENTS PPRINT <GET VECTOR PPRINT>>

<PUT LOCD PPRINT <FUNCTION () <PRINC "#LOCD "> <FORMS <IN .L>>>>

<PUT RSUBR PPRINT <FUNCTION ()
	<PRINC "<RSUBR '">
	<SET M <+ .M 1>>
	<<GET VECTOR PPRINT>>
	<PRINC ">">>>
<DEFINE FUNCBODY FBA (L P "AUX" (M <+ .M 1>) (TEM %<>))
	<COND (<EMPTY? .L>)
	      (ELSE
		<COND (<==? <TYPE <1 .L>> ATOM>
			<OR <CHECK <1 .L> -1> <TERPRI> <INDENT-TO .P>>
			<PRIN1 <1 .L>> <PRINC !" >
			<AND <EMPTY? <SET L <REST .L>>> <EXIT .FBA T>>)>
		<COND (<==? <TYPE <1 .L>> LIST> <SET TEM <PRINARGL <1 .L> .P>> <SET L <REST .L>>)>
		<COND (.TEM <COMPONENTS .L .M>)
		      (<CHECK .L -1> <PRINC !" > <ELEMENTS .L .M>)
		      (ELSE <TERPRI> <INDENT-TO .P> <COMPONENTS .L .M>)>)>>

<DEFINE CHECK (IT FUDGE) <FLATSIZE .IT <MIN <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M .FUDGE>>>>

<DEFINE PRINARGL (L PB "AUX" POS Q (OL .L))
	<COND (<CHECK .L -2> <PRINC "("> <ELEMENTS .L> <PRINC ")"> %<>)
	      (ELSE
		<OR <CHECK <SET Q <ABUNCH L>> -1> <TERPRI> <INDENT-TO .PB>>
		<PRINC "(">
		<SET POS <LINPOS .OUTCHAN>>
		<REPEAT ((NOTFIRST %<>) (N <+ .M 1>))
			<OR .Q <RETURN T>>
			<COND (<==? <TYPE .Q> STRING>
				<COND (.NOTFIRST <TERPRI> <INDENT-TO .POS>)>
				<PRIN1 .Q>
				<PRINC !" >)
			      (<CHECK .Q -2> <ELEMENTS .OL .N .L>)
			      (ELSE <COMPONENTS .OL .N .L>)>
			<SET NOTFIRST T>
			<SET OL .L>
			<SET Q <ABUNCH L>>>
		<PRINC ")">
		<TERPRI>
		<INDENT-TO .PB>)>>

<DEFINE ABUNCH (ATM "AUX" T)
	<COND (<EMPTY? ..ATM> %<>)
	      (<==? <TYPE <1 ..ATM>> STRING>
		<SET T <1 ..ATM>>
		<SET .ATM <REST ..ATM>>
		.T)
	      (ELSE
		<STACKFORM ,LIST .T
			<COND (<EMPTY? ..ATM> %<>)
			      (<==? <TYPE <1 ..ATM>> STRING> %<>)
			      (ELSE <SET T <1 ..ATM>> <SET .ATM <REST ..ATM>>)>>)>>
"How to print FORM and its special cases."
"Special cases for FORM are PUT on the appropriate function."

<PUT FORM PPRINT <FUNCTION () <<GET <1 .L> SPECFORM ',NORMFORM>>>>

<DEFINE NORMFORM ("AUX" (PN <+ 1 <LINPOS .OUTCHAN>>))
			<PRINC "<" >
			<FORMS <1 .L>>
			<COND (<==? .COMELE ,ELEMENTS> <COMEND>)
			      (<FORMAHEAD .L> <COMMENTS> <TERPRI> <INDENT-TO .PN>
				<COND (<FLATSIZE <REST .L> <- <LINLNT .OUTCHAN>
								<LINPOS .OUTCHAN>
								.M 3>>
						<ELEMENTS <REST .L>>)
				      (T <COMPONENTS <REST .L>>)>)
			      (T <COMEND>)>
			<PRINC ">">>


<SETG COMEND <FUNCTION ("AUX" (PPN <LINPOS .OUTCHAN>))
	<COND (<COMMENTS> <TERPRI> <INDENT-TO .PPN>)>
	<COND (<EMPTY? <REST .L>>)
	      (<PRINC !" > <.COMELE <REST .L>>)> >>


<DEFINE FORMAHEAD (ML "AUX" (AVSP <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>))
	<COND (<AND <==? <TYPE <1 .ML>> FORM>
		    <NOT <EMPTY? <REST .ML>>>
		    <NOT <FLATSIZE <1 .ML> <MIN 59 .AVSP>>>>
	       T)
	      (ELSE
	       <REPEAT ()
		  <COND (<L? <LENGTH .ML> 2> <RETURN #FALSE ()>)
			(<NOT <==? <TYPE <2 .ML>> FORM>> <RETURN #FALSE ()>)
			(<FLATSIZE <1 <2 .ML>>
				   <- <SET AVSP
					   <- .AVSP
					      3
					      <FLATSIZE <1 .ML> 99999999>>>
				      3>>
			 <SET ML <2 .ML>>)
			(ELSE <RETURN T>)>>)>>


<PUT LVAL SPECFORM <FUNCTION () <DAMMIT !".>>>

<PUT GVAL SPECFORM <FUNCTION () <DAMMIT !",>>>

<PUT QUOTE SPECFORM <FUNCTION () <DAMMIT !"'>>>

<DEFINE DAMMIT (Q)
	<COND (<==? 2 <LENGTH .L>>
		<PRINC .Q>		;"No fucking comments printed on . , or ' "
		<COND	(<EMPTY? <REST .L>>)
			(<.COMELE <REST .L>>)>)
	      (ELSE <NORMFORM>)>>

<PUT FUNCTION SPECFORM <FUNCTION ()
	<PRINC "<FUNCTION ">
	<FUNCBODY <REST .L> <- <LINPOS .OUTCHAN> 2>>
	<PRINC ">">>>

<PUT DEFINE SPECFORM <FUNCTION ()
	<PRINC "<DEFINE ">
	<SET POS <LINPOS .OUTCHAN>>
	<COND (<EMPTY? <SET L <REST .L>>>)
	      (ELSE
		<PRIN1 <1 .L>>
		<PRINC !" >
		<FUNCBODY <REST .L> .POS>)>
	<PRINC ">">>>

<PUT REPEAT SPECFORM <FUNCTION ("AUX" (CPOS <+ <LINPOS .OUTCHAN> 3>))
	<PRINC "<REPEAT ">
	<FORMS <2 .L>>
	<TERPRI>
	<INDENT-TO .CPOS>
	<.COMELE <REST .L 2>>
	<PRINC ">">>>
<SETG PPRINT <FUNCTION PPRINT  (L "OPTIONAL" (OUTCHAN .OUTCHAN))
	<COND (<NOT <==? <TYPE .L> ATOM>> <EPRINT .L>)
	      (<GASSIGNED? .L>
		<COND (<==? <TYPE ,.L> FUNCTION>
			<EPRINT <FORM DEFINE .L !,.L>>)
		      (<==? <TYPE ,.L> RSUBR>
			<EPRINT <FORM SETG .L <FORM RSUBR <FORM QUOTE <CHTYPE ,.L VECTOR>>>>>)
		      (ELSE <EPRINT <FORM SETG .L <FORM QUOTE ,.L>>>)>)
	      (<AND <BOUND? .L> <ASSIGNED? .L>>
		<EPRINT
		 <FORM SET .L
			     <COND (<==? <TYPE ..L> FUNCTION>
					<FORM FUNCTION !..L>)
				   (<==? <TYPE ..L> RSUBR>
					<FORM RSUBR <CHTYPE ..L VECTOR>>)
				   (ELSE <FORM QUOTE ..L>)>>>)
	      (ELSE <PRINT .L> #FALSE ("NAKED ATOM?"))>>>

<SETG EPRINT <FUNCTION (L "EXTRA" (M 0) (COMELE ,COMPONENTS))
	<SPEEDSEL>
	<TERPRI>
	<FORMS .L>
	<TERPRI>
	,NULL	;"Null atom returned" >>

<DEFINE PPRINF FACT (INF "OPTIONAL" (OUTF ("" "" "TPL"))
			"AUX" (INCH <OPEN  "READ" !.INF>)
				OUTCH NULLO)
	<OR .INCH <EXIT .FACT "BAD FILE NAME?">>
	<PUT <SET OUTCH <OPEN "PRINT" !.OUTF>> 13 100>
	<PUT <SET NULLO <OPEN "PRINT" "" "" "NUL">> 13 100>
	<REPEAT ((BOTH (<PUT .OUTCH 15 99999> <PUT .NULLO 15 99999>))
		  Q)
		<PPRINT <SET Q <READ '<RETURN T> .INCH>>
			<PUT .NULLO 16 <16 .OUTCH>>>
		<AND <G? <16 .NULLO> 58> <PRINC <ASCII 12> .BOTH>>
		<PPRINT .Q .OUTCH>>
	<CLOSE .INCH>
	<CLOSE .OUTCH>
	<CLOSE .NULLO>
	"DONE">



<ENDBLOCK>



<COND (<LOOKUP "PPRINT" <1 .OBLIST>> <SETG PPRINT ,PPRINT!-> <REMOVE PPRINT>)>
<COND (<LOOKUP "FRAMES" <1 .OBLIST>> <SETG FRAMES ,FRAMES!-> <REMOVE FRAMES>)>
<COND (<LOOKUP "FRM" <1 .OBLIST>> <SETG FRM ,FRM!-> <REMOVE FRM>)>
<COND (<LOOKUP "PPRINF" <1 .OBLIST>> <SETG PPRINF ,PPRINF!-> <REMOVE PPRINF>)>
ð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒ