X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=MUDDLE%2Fpprint.1;fp=MUDDLE%2Fpprint.1;h=b408a23090483f63df75a11dd8170aa555ce378a;hb=39c5769144e7f2a58076bdb973d2c80fa603345c;hp=0000000000000000000000000000000000000000;hpb=bab072f950a643ac109660a223b57e635492ac25;p=pdp10-muddle.git

diff --git a/MUDDLE/pprint.1 b/MUDDLE/pprint.1
new file mode 100644
index 0000000..b408a23
--- /dev/null
+++ b/MUDDLE/pprint.1
@@ -0,0 +1,401 @@
+ "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>)>
+ð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒ
\ No newline at end of file