--- /dev/null
+ "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>
+
+\f<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>
+\f<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>>)>>>
+\f<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
+\r '#FUNCTION ( ()
+ <PRINC "#">
+ <PRIN1 <TYPE .L>>
+ <FASTFORMS <CHTYPE .L <PRIMTYPE .L>>>)>>)>>>
+
+\f<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)>>>>
+\f"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 ">">>>
+\f<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>>)>>)>>
+\f"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 ">">>>
+\f<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>)>
+\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
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff