github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-04 02:35:00 +00:00
Code Issues Releases Wiki Activity
Files
a94ae567ef41f4d17f65a49383ca5e4ab55bb61c
PDP-10.its/src/mudbug/pprint.36

1091 lines
36 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
<BLOAT 7100 100 5 20>
;"MUDDLE PRETTY-PRINT, FRAME-SCANNER, AND OTHER ROUTINES"
<PACKAGE "PP">
<RENTRY PPRINT EPRINT EPRIN1 COLPP
FRAMES FRATM FRLVAL FRM
PPRINF INDENT-TO FORMS NULL
LINPOS LINLNT PAGPOS PAGLNT
QUICKPRINT LOOKAHEAD VERTICAL DENSE LEFT-MARGIN>
;"These atoms are placed in the ROOT oblist to allow general
access to their functions"
<BLOCK (<ROOT>)> FIXUP!-RSUBRS <ENDBLOCK>
<COND (<NOT <GASSIGNED? NULL>>
<SETG NULL <INSERT <ATOM <ASCII 127>> <ROOT>>>)>
<SETG QUICKPRINT <SET QUICKPRINT T>>
<SETG LOOKAHEAD <SET LOOKAHEAD T>>
<SETG VERTICAL <SET VERTICAL <>>>
<SETG DENSE <SET DENSE <>>>
<SETG LEFT-MARGIN <SET LEFT-MARGIN 0>>
\
<DEFINE PPRINT (L "OPTIONAL" (OUTCHAN .OUTCHAN) "EXTRA" DEF)
#DECL ((L DEF) ANY (OUTCHAN) <SPECIAL CHANNEL>)
<COND (<NOT <TYPE? .L ATOM>> <EPRINT .L>)
(<GASSIGNED? .L>
<SET DEF ,.L>
<COND (<TYPE? .DEF FUNCTION>
<EPRINT <CHTYPE (DEFINE .L !.DEF) FORM>>)
(<TYPE? .DEF RSUBR> <EPRINT <FORM SETG .L <DUMP .DEF>>>)
(<TYPE? .DEF RSUBR-ENTRY>
<EPRINT <FORM SETG .L <ENT-DUMP .DEF>>>)
(<AND <TYPE? .DEF MACRO>
<NOT <EMPTY? .DEF>>>
<COND (<TYPE? <1 .DEF> FUNCTION>
<EPRINT <CHTYPE (DEFMAC .L !<1 .DEF>) FORM>>)
(ELSE <EPRINT <FORM SETG .L .DEF>>)>)
(ELSE <EPRINT <FORM SETG .L <FORM QUOTE .DEF>>>)>)
(<ASSIGNED? .L>
<SET DEF ..L>
<EPRINT <FORM SET
.L
<COND (<TYPE? .DEF FUNCTION>
<CHTYPE (FUNCTION !.DEF) FORM>)
(<TYPE? .DEF RSUBR> <DUMP .DEF>)
(<TYPE? .DEF RSUBR-ENTRY> <ENT-DUMP .DEF>)
(ELSE <FORM QUOTE .DEF>)>>>)
(ELSE <PRINT .L .OUTCHAN> #FALSE ("NAKED ATOM?"))>>
<DEFINE EPRINT (L "OPTIONAL" (MARG <VALUE LEFT-MARGIN>)
"EXTRA" (OUTC <INIT>))
#DECL ((L) ANY (MARG) <SPECIAL FIX>
(OUTC) CHANNEL)
<COND (<0? .MARG> <TERPRI .OUTC>)
(<L? <LINPOS .OUTC> .MARG> <INDENT-TO .MARG .OUTC>)>
<FORMS .L .OUTC 0>
<TERPRI .OUTC>
,NULL>
<DEFINE EPRIN1 (L "OPTIONAL" MARG
"EXTRA" (OUTC <INIT>))
#DECL ((L) ANY (MARG) <SPECIAL FIX>
(OUTC) CHANNEL)
<COND (<NOT <ASSIGNED? MARG>> <SET MARG <LINPOS .OUTC>>)>
<COND (<L? <LINPOS .OUTC> .MARG>
<INDENT-TO .MARG .OUTC>)>
<FORMS .L .OUTC 0>
,NULL>
<DEFINE PPRINF (INPUT
"OPTIONAL" OUTF (LL <13 ,OUTCHAN>) (EVAL? <>) (PL 58)
"AUX" INCH INL OUTCH (QUICKPRINT <>)
(REDEFINE T) (KEEP-FIXUPS T) (MUDDLE ,MUDDLE))
#DECL ((OUTF) STRING (EVAL?) <OR FALSE ATOM> (PL LL MUDDLE) FIX (INL) LIST
(INCH OUTCH) <OR FALSE CHANNEL> (QUICKPRINT) <SPECIAL ANY>
(INPUT) <OR ATOM LIST STRING> (REDEFINE KEEP-FIXUPS) <SPECIAL ANY>)
<COND (<TYPE? .INPUT ATOM> <SET INL <LIST .INPUT>>)
(<TYPE? .INPUT LIST> <SET INL .INPUT>)
(ELSE <SET INCH <OPEN "READ" .INPUT>>)>
<COND (<NOT <ASSIGNED? OUTF>>
<COND (<ASSIGNED? INL>
<COND (<AND <NOT <EMPTY? .INL>> <TYPE? <1 .INL> ATOM>>
<SET OUTF <SPNAME <1 .INL>>>)
(ELSE <SET OUTF "_PPRIN">)>)
(ELSE
<COND (<G? .MUDDLE 100> <SET OUTF .INPUT>)
(ELSE <SET OUTF "TPL:">)>)>)>
<UNWIND
<PROG ()
<COND (<AND <ASSIGNED? INCH> <NOT .INCH>> <RETURN .INCH>)>
<SET OUTCH <CHANNEL "PRINT" .OUTF>>
<COND (<G? .MUDDLE 100>
<SET OUTCH
<OPEN "PRINT" "PPRNF" "MUD" <9 .OUTCH> <10 .OUTCH>>>)
(T
<SET OUTCH
<OPEN "PRINT" "_PPRNF" ">" <9 .OUTCH> <10 .OUTCH>>>)>
<COND (<NOT .OUTCH>
<AND <ASSIGNED? INCH> <CLOSE .INCH>>
<RETURN .OUTCH>)>
<CLOSE .OUTCH>
<PUT .OUTCH 2 "PRINTO"> ;"Reopen OUTCH in PRINTO mode"
<RESET .OUTCH>
<PUT .OUTCH ,LINLNT .LL> ;"Appropriate line length"
<PUT .OUTCH ,PAGLNT 99999> ;"Big page length"
<REPEAT ((OUTCHAN .OUTCH) Q QC (UNIQUE (T)) ACC-OLD ACC-NOW
PPOS-OLD (NEWPG T))
#DECL ((OUTCHAN) <SPECIAL CHANNEL> (Q QC) ANY (UNIQUE) LIST
(ACC-OLD ACC-NOW PPOS-OLD) FIX (NEWPG) <OR FALSE ATOM>)
<COND (<ASSIGNED? INL>
<COND (<EMPTY? .INL> <RETURN>)>
<PPRINT <SET Q <1 .INL>>>
<SET INL <REST .INL>>)
(ELSE
<SET Q <READ .INCH '.UNIQUE>>
<COND (<==? .Q .UNIQUE> <RETURN>)>
<EPRIN1 .Q>)>
<COND (<ASSIGNED? INL>)
(<SET QC <GET .INCH COMMENT>> ;"Top-Level comment ?"
<TERPRI .OUTCHAN>
<PRINC !\; .OUTCHAN>
<EPRIN1 .QC>)>
<COND (.EVAL? <EVAL .Q>)>
<PROG ()
<COND (<G? <PAGPOS .OUTCHAN> .PL>
;"Last item overflowed page ?"
<COND (.NEWPG ;"Last item only item on this page ?"
<TERPRI .OUTCHAN>
<PRINC <ASCII 12> .OUTCHAN>
;"Simply end with form-feed"
<TERPRI .OUTCHAN>)
(ELSE
;"Last item was simply one too many on page"
<BUFOUT .OUTCHAN> ;"Flush out stragglers"
<SET ACC-NOW <17 .OUTCHAN>>
;"YES, go back and clobber in form-feed"
<ACCESS .OUTCHAN .ACC-OLD>
<PRINTB ,CR:FF:CR .OUTCHAN>
<ACCESS .OUTCHAN .ACC-NOW> ;"Return"
<PUT .OUTCHAN
,PAGPOS
<- <PAGPOS .OUTCHAN> .PPOS-OLD 1>>
;"Repair the page position slot"
<SET NEWPG T>
<AGAIN>)>)
(ELSE
<SET ACC-OLD <17 .OUTCHAN>> ;"Save current location"
<SET PPOS-OLD <PAGPOS .OUTCHAN>>
<PRINTB ,CR:SP:CR .OUTCHAN>;"Output clobberable chars"
<PUT .OUTCHAN ,LINPOS 0> ;"Fixup OUTCHAN slots"
<PUT .OUTCHAN ,PAGPOS <+ <PAGPOS .OUTCHAN> 2>>
<SET NEWPG <>>)>>>
<AND <ASSIGNED? INCH> <CLOSE .INCH>>
<COND (<G? .MUDDLE 100>
<CLOSE .OUTCH>
<RENAME <STRING <9 .OUTCH> ":<" <10 .OUTCH> ">"
<7 .OUTCH> "." <8 .OUTCH>>
TO .OUTF>)
(<RENAME .OUTCH .OUTF>
<CLOSE .OUTCH>)>
"DONE">
<PROG ()
<AND <ASSIGNED? INCH> <TYPE? .INCH CHANNEL> <CLOSE .INCH>>
<AND <ASSIGNED? OUTCH>
<TYPE? .OUTCH CHANNEL>
<CLOSE .OUTCH>>>>>
<SETG CR:SP:CR ![7022316820!]>
<SETG CR:FF:CR ![7021661460!]>
<GDECL (CR:SP:CR CR:FF:CR) UVECTOR>
<DEFINE COLPP (X
"OPTIONAL" (OUTCHAN .OUTCHAN) (COL <LINPOS .OUTCHAN>)
(WID <LINLNT .OUTCHAN>)
"AUX" (SWID <LINLNT .OUTCHAN>))
#DECL ((X) ANY (OUTCHAN) <SPECIAL CHANNEL> (COL WID SWID) FIX)
<PUT .OUTCHAN ,LINLNT .WID>
<EPRINT .X .COL>
<PUT .OUTCHAN ,LINLNT .SWID>
,NULL>
\
<DEFINE FRAMES ;"Prints FUNCT and ARGS for -n- frames down"
("OPTIONAL" (HOW-MANY 99999) (FIRST 0) "EXTRA" (NO-DUMP T) (OUTCHAN <INIT>))
#DECL ((HOW-MANY FIRST) FIX (OUTCHAN) <SPECIAL CHANNEL> (NO-DUMP) <SPECIAL ANY>)
<REPEAT ((F <FRM .FIRST>) FUNF FRMF X)
#DECL ((F FRMF) FRAME (FUNF) ATOM (X) ANY)
<COND (<0? .HOW-MANY> <TERPRI .OUTCHAN> <RETURN "FUNCT---ARGS">)
(<==? <SET FUNF <FUNCT .F>> TOPLEVEL>
<TERPRI .OUTCHAN>
<RETURN TOPLEVEL>)
(<AND ;"Don't print repetitious FSUBR args."
<OR <AND <GASSIGNED? .FUNF> <TYPE? ,FUNF FSUBR>>
<AND <ASSIGNED? .FUNF> <TYPE? ..FUNF FSUBR>>>
<==? <FUNCT <SET FRMF <FRAME .F>>> EVAL>
<TYPE? <SET X <1 <ARGS .FRMF>>> FORM>
<NOT <EMPTY? .X>>
<==? .FUNF <1 .X>>>)
(ELSE
<PRINT .FIRST .OUTCHAN>
<PRINC .FUNF .OUTCHAN>
<PRINC !\ .OUTCHAN> ;"Tab"
<EPRIN1 <ARGS .F>>)>
<SET F <FRAME .F>>
<SET HOW-MANY <- .HOW-MANY 1>>
<SET FIRST <+ .FIRST 1>>>>
<DEFINE FRATM ("OPTIONAL" (HOW-MANY 9999) (FIRST 0) "EXTRA" (OUTC <INIT>))
#DECL ((HOW-MANY FIRST) FIX (OUTC) CHANNEL)
<REPEAT ((F <FRM .FIRST>) AF V FF)
#DECL ((F) FRAME (AF) FORM (FF) ATOM)
<COND (<0? .HOW-MANY> <TERPRI .OUTC> <RETURN "FRAME---FUNCTION">)
(<==? <SET FF <FUNCT .F>> TOPLEVEL>
<TERPRI .OUTC>
<RETURN TOPLEVEL>)
(<OR <AND <==? .FF EVAL>
<1? <LENGTH <ARGS .F>>>
<TYPE? <1 <ARGS .F>> FORM>
<NOT <EMPTY? <SET AF <1 <ARGS .F>>>>>
<TYPE? <1 .AF> ATOM>
<OR <AND <GASSIGNED? <SET FF <1 .AF>>> <SET V ,.FF>>
<AND <ASSIGNED? .FF> <SET V ..FF>>>
<TYPE? .V FUNCTION RSUBR RSUBR-ENTRY>>
<AND <OR <AND <GASSIGNED? .FF> <SET V ,.FF>>
<AND <ASSIGNED? .FF> <SET V ..FF>>>
<TYPE? .V RSUBR RSUBR-ENTRY>>>
<PRIN1 .FIRST .OUTC>
<PRINC !\ .OUTC>
<PRIN1 .FF .OUTC>
<TERPRI .OUTC>)>
<SET F <FRAME .F>>
<SET FIRST <+ .FIRST 1>>
<SET HOW-MANY <- .HOW-MANY 1>>>>
<DEFINE FRM (I)
#DECL ((I) FIX (VALUE) FRAME)
<REPEAT ((F <FRAME>))
#DECL ((F VALUE) FRAME)
<COND (<0? .I> <RETURN .F>)
(<==? <FUNCT .F> TOPLEVEL>
<PRINT .I>
<PRINC "FRAMES FROM ">
<RETURN .F>)>
<SET F <FRAME .F>>
<SET I <- .I 1>>>>
<DEFINE FRLVAL (ATM "OPTIONAL" (HOW-MANY 100000) (FIRST 0)
"EXTRA" (OUTC <INIT>))
#DECL ((ATM) ATOM (HOW-MANY FIRST) FIX (OUTC) CHANNEL)
<COND (<NOT <BOUND? .ATM>> "Atom is not bound anywhere.")
(ELSE
<TERPRI .OUTC>
<SET HOW-MANY <+ .HOW-MANY 1>>
<REPEAT ((F <FRM .FIRST>) (LAST-LOC <LLOC .ATM>)
(FLG <ASSIGNED? .ATM>) (NUM 0) NEXT-LOC)
#DECL ((F) FRAME (LAST-LOC NEXT-LOC) LOCD (NUM) FIX
(FLG) <OR ATOM FALSE>)
<COND (<==? .NUM .HOW-MANY>
<PRINVAL "Bound further down to: " .LAST-LOC .FLG .OUTC>
<RETURN>)
(<==? <FUNCT .F> TOPLEVEL>
<PRINVAL "Toplevel binding: " .LAST-LOC .FLG .OUTC>
<RETURN>)
(<NOT <BOUND? .ATM .F>>
<PRINVAL <- .NUM 1> .LAST-LOC .FLG .OUTC>
<RETURN>)
(<==? .LAST-LOC <SET NEXT-LOC <LLOC .ATM .F>>>)
(ELSE
<PRINVAL <- .NUM 1> .LAST-LOC .FLG .OUTC>
<SET LAST-LOC .NEXT-LOC>
<SET FLG <ASSIGNED? .ATM .F>>)>
<SET F <FRAME .F>>
<SET NUM <+ .NUM 1>>>
"Frame----Value")>>
<DEFINE PRINVAL (PRE LOCA FLG OUTCHAN)
#DECL ((LOCA) LOCD (PRE) ANY (FLG) <OR ATOM FALSE>
(OUTCHAN) <SPECIAL CHANNEL>)
<PRINC .PRE .OUTCHAN>
<INDENT-TO 5 .OUTCHAN>
<COND (.FLG <EPRIN1 <IN .LOCA>> <TERPRI .OUTCHAN>)
(ELSE <PRINC "----bound, but not assigned a value----
" .OUTCHAN>)>>
<DEFINE INIT ("EXTRA" OUTC) ;"Insure valid OUTCHAN"
#DECL ((VALUE) CHANNEL)
<PROG ()
<COND (<AND <ASSIGNED? OUTCHAN>
<TYPE? <SET OUTC <VALUE OUTCHAN>> CHANNEL>>
;"The VALUE fakes the compiler out")
(ELSE
<ERROR BAD-CHANNEL!-ERRORS OUTCHAN PPRINT>
<AGAIN>)>
<COND (<NOT <ASSIGNED? QUICKPRINT>> ;"Ensure LVALs"
<SET QUICKPRINT ,QUICKPRINT>)>
<COND (<NOT <ASSIGNED? VERTICAL>>
<SET VERTICAL ,VERTICAL>)>
<COND (<NOT <ASSIGNED? LOOKAHEAD>>
<SET LOOKAHEAD ,LOOKAHEAD>)>
<COND (<NOT <ASSIGNED? DENSE>>
<SET DENSE ,DENSE>)>
.OUTC>>
\
;"Dispatch to proper printer based on type of LNEW.
Actually pass L (the original object) to save comments."
<DEFINE FORMS ;"Pprint one item at the current page location"
(L "OPTIONAL" (OUTC <INIT>) (M 0) (LNEW .L) "AUX" FITS? R TYP PTYP)
#DECL ((L LNEW) ANY (FITS?) <SPECIAL ANY> (M) FIX
(OUTC) <CHANNEL [12 ANY] [4 FIX]> (R) <OR FALSE APPLICABLE>
(TYP PTYP) ATOM)
<PROG ()
<COND (<MONAD? .LNEW> <PRIN1 .LNEW .OUTC> <RETURN>)>
;"If its a MONAD, just print it."
<SET FITS? <FLATSIZE .LNEW <- <LINLNT .OUTC> <LINPOS .OUTC> .M>>>
;"If it fits, use ELEMENTS, else COMPONENTS."
<COND (<AND .QUICKPRINT .FITS?>
<PRIN1 .LNEW .OUTC>
<RETURN>)
(<TYPE? .LNEW FORM> <FORM-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW LIST> <LIST-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW DECL> <DECL-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW STRING> <STRING-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW VECTOR> <VECTOR-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW UVECTOR> <UVECTOR-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW SEGMENT> <SEGMENT-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW TEMPLATE> <TEMPLATE-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW FUNCTION> <FUNCTION-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW RSUBR-ENTRY> <RSUBR-ENTRY-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW RSUBR> <RSUBR-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW CODE> <CODE-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW CHANNEL> <CHANNEL-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW TUPLE> <VECTOR-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW LOCD LOCAS LOCU LOCS LOCA LOCV LOCL>
<LOC-PPRINT .L .OUTC .M>)
(<TYPE? .LNEW STORAGE> <STORAGE-PPRINT .L .OUTC .M>)
(<SET R <GET <SET TYP <TYPE .LNEW>> PPRINT>>
<APPLY .R .LNEW .OUTC .M>)
(<N==? .TYP <SET PTYP <PRIMTYPE .LNEW>>> ;"Not primitive ?"
<PRINC !\# .OUTC> ;"Try again as primitive type"
<PRIN1 .TYP .OUTC>
<PRINC !\ .OUTC> ;"Space after type name"
<SET LNEW <CHTYPE .LNEW .PTYP>> ;"Try Primtype instead"
<AGAIN>)
(ELSE <ERROR CANT-PPRINT!-ERRORS .LNEW>)>>>
\
;"Routines to print objects in certain special formats"
<DEFINE COMELE (L OUTC M) ;"Select proper format"
#DECL ((L) ANY (M) FIX (OUTC) CHANNEL)
<COND (.FITS? <ELEMENTS .L .OUTC .M>)
(ELSE <COMPONENTS .L .OUTC .M>)>>
<DEFINE COMPONENTS ;"Print the components of a structure in a column"
(L OUTC OM "OPTIONAL" (STOP 0))
#DECL ((L) ANY (OM) FIX (STOP) ANY (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (.DENSE <BLOCKP .L <LINPOS .OUTC> .OUTC .OM .STOP>)
(ELSE
<REPEAT ((N <LINPOS .OUTC>) (M 0))
#DECL ((N) FIX (M) FIX)
<AND <EMPTY? <REST .L>> <SET M .OM>>
<FORMS <1 .L> .OUTC .M>
<COMMENTS .L .OUTC .M>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN DONE>)>
<AND <==? .STOP .L> <RETURN DONE>>
<TERPRI .OUTC>
<INDENT-TO .N .OUTC>>)>>
<DEFINE ELEMENTS ;"Print the components of a structure in a line."
(L OUTC OM "OPTIONAL" (STOP 0))
#DECL ((L) ANY (OM) FIX (STOP) ANY (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (<EMPTY? .L>)
(.QUICKPRINT
<REPEAT ()
<PRIN1 <1 .L> .OUTC>
<AND <OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>>
<RETURN>>
<PRINC !\ .OUTC>>)
(ELSE
<REPEAT ((N <LINPOS .OUTC>) (M 0) COM)
#DECL ((N) FIX (M) FIX (COM) <OR FALSE ATOM>)
<AND <EMPTY? <REST .L>> <SET M .OM>>
<FORMS <1 .L> .OUTC .M>
<SET COM <COMMENTS .L .OUTC .M>>
<COND (<OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>>
<RETURN>)>
<COND (.COM <TERPRI .OUTC> <INDENT-TO .N .OUTC>)
(ELSE <PRINC !\ .OUTC>)>>)>>
<DEFINE BLOCKP (L STRT OUTC OM "OPTIONAL" (STOP ()))
;"Block Printer"
#DECL ((L STOP) ANY (STRT) FIX
(OM) FIX (OUTC) CHANNEL)
<COND (<EMPTY? .L>)
(ELSE
<REPEAT ((LINE <PAGPOS .OUTC>) FLGC
(M <COND (<EMPTY? <REST .L>> .OM) (ELSE 0)>))
#DECL ((LINE) FIX (FLGC) <OR FALSE ATOM>
(M) FIX)
<FORMS <1 .L> .OUTC .M>
<SET FLGC <COMMENTS .L .OUTC .M>>
<COND (<OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>>
<RETURN>)>
<COND (<EMPTY? <REST .L>> <SET M .OM>)>
<COND (<AND <NOT .FLGC> <==? .LINE <PAGPOS .OUTC>>
<FLATSIZE <1 .L> <- <LINLNT .OUTC>
<LINPOS .OUTC> .M 1>>>
<PRINC !\ .OUTC>
<AGAIN>)>
<TERPRI .OUTC>
<INDENT-TO .STRT .OUTC>
<SET LINE <PAGPOS .OUTC>>>)>>
<DEFINE COMMENTS (L OUTC M "AUX" R CMNT FS1)
;"Prints comments. If no comment, returns false"
#DECL ((L CMNT) ANY (R FS1) FIX (M) FIX (MARG) <SPECIAL FIX>
(VALUE) <OR FALSE ATOM> (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (<SET CMNT <OR <GET .L COMMENT> <GET <REST .L 0> COMMENT>>>
<SET R <COND (<LENGTH? .L 1> .M) (0)>>
<SET FS1
<OR <FLATSIZE .CMNT <LINLNT .OUTC>> <LINLNT .OUTC>>>
<COND (<G? .FS1 <- <LINLNT .OUTC> <LINPOS .OUTC> .R 2>>
<TERPRI .OUTC>)>
<INDENT-TO <- <MAX <+ 2 .MARG> <- <LINLNT .OUTC> .FS1 .R>> 2> .OUTC>
<PRINC " ;" .OUTC>
<PRIN1 .CMNT .OUTC>
T)>>
\
;"Routines to print list structure in certain special formats"
<DEFINE LIST-COMELE (L OUTC M) ;"Select proper format"
#DECL ((L) <PRIMTYPE LIST> (M) FIX (OUTC) CHANNEL)
<COND (.FITS? <LIST-ELEMENTS .L .OUTC .M>)
(ELSE <LIST-COMPONENTS .L .OUTC .M>)>>
<DEFINE LIST-COMPONENTS ;"Print the components of list structure in a column"
(L OUTC OM "OPTIONAL" (STOP 0))
#DECL ((L) <PRIMTYPE LIST> (OM) FIX (STOP) ANY
(OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (.DENSE <LIST-BLOCKP .L <LINPOS .OUTC> .OUTC .OM .STOP>)
(ELSE
<REPEAT ((N <LINPOS .OUTC>) (M 0))
#DECL ((N) FIX (M) FIX)
<AND <EMPTY? <REST .L>> <SET M .OM>>
<FORMS <1 .L> .OUTC .M>
<LIST-COMMENTS .L .OUTC .M>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN DONE>)>
<AND <==? .STOP .L> <RETURN DONE>>
<TERPRI .OUTC>
<INDENT-TO .N .OUTC>>)>>
<DEFINE LIST-ELEMENTS ;"Print the components of list structure in a line."
(L OUTC OM "OPTIONAL" (STOP 0))
#DECL ((L) <PRIMTYPE LIST> (OM) FIX (STOP) ANY
(OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (<EMPTY? .L>)
(.QUICKPRINT
<REPEAT ()
<PRIN1 <1 .L> .OUTC>
<AND <OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>>
<RETURN>>
<PRINC !\ .OUTC>>)
(ELSE
<REPEAT ((N <LINPOS .OUTC>) (M 0) COM)
#DECL ((N) FIX (M) FIX (COM) <OR FALSE ATOM>)
<AND <EMPTY? <REST .L>> <SET M .OM>>
<FORMS <1 .L> .OUTC .M>
<SET COM <LIST-COMMENTS .L .OUTC .M>>
<COND (<OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>>
<RETURN>)>
<COND (.COM <TERPRI .OUTC> <INDENT-TO .N .OUTC>)
(ELSE <PRINC !\ .OUTC>)>>)>>
<DEFINE LIST-BLOCKP (L STRT OUTC OM "OPTIONAL" (STOP ()))
;"Block Printer for list structure"
#DECL ((L STOP) <PRIMTYPE LIST> (STRT) FIX
(OM) FIX (OUTC) CHANNEL)
<COND (<EMPTY? .L>)
(ELSE
<REPEAT ((LINE <PAGPOS .OUTC>) FLGC
(M <COND (<EMPTY? <REST .L>> .OM) (ELSE 0)>))
#DECL ((LINE) FIX (FLGC) <OR FALSE ATOM>
(M) FIX)
<FORMS <1 .L> .OUTC .M>
<SET FLGC <LIST-COMMENTS .L .OUTC .M>>
<COND (<OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>>
<RETURN>)>
<COND (<EMPTY? <REST .L>> <SET M .OM>)>
<COND (<AND <NOT .FLGC> <==? .LINE <PAGPOS .OUTC>>
<FLATSIZE <1 .L> <- <LINLNT .OUTC>
<LINPOS .OUTC> .M 1>>>
<PRINC !\ .OUTC>
<AGAIN>)>
<TERPRI .OUTC>
<INDENT-TO .STRT .OUTC>
<SET LINE <PAGPOS .OUTC>>>)>>
<DEFINE LIST-COMMENTS (L OUTC M "AUX" R CMNT FS1)
;"Prints comments on list structure. If no comment, returns false"
#DECL ((L) <PRIMTYPE LIST> (CMNT) ANY (R FS1) FIX (M) FIX (MARG) <SPECIAL FIX>
(VALUE) <OR FALSE ATOM> (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (<SET CMNT <OR <GET .L COMMENT> <GET <REST .L 0> COMMENT>>>
<SET R <COND (<LENGTH? .L 1> .M) (0)>>
<SET FS1
<OR <FLATSIZE .CMNT <LINLNT .OUTC>> <LINLNT .OUTC>>>
<COND (<G? .FS1 <- <LINLNT .OUTC> <LINPOS .OUTC> .R 2>>
<TERPRI .OUTC>)>
<INDENT-TO <- <MAX <+ 2 .MARG> <- <LINLNT .OUTC> .FS1 .R>> 2> .OUTC>
<PRINC " ;" .OUTC>
<COND (<TYPE? .CMNT STRING> <PRIN1 .CMNT .OUTC>)
(ELSE <PRIN1 .CMNT .OUTC>)>
T)>>
\
;"The following functions define the way to pprint a given data type.
They are called from FORMS for the appropriate type
FORM is a special case - see next page."
<DEFMAC LIST-PPRINT ('L 'OUTC 'M)
<FORM PROG
()
<FORM PRINC !\( .OUTC>
<FORM LIST-COMELE .L .OUTC <FORM + .M 1>>
<FORM PRINC !\) .OUTC>>>
<DEFMAC VECTOR-PPRINT ('L 'OUTC 'M)
<FORM PROG
()
<FORM PRINC !\[ .OUTC>
<FORM COMELE .L .OUTC <FORM + .M 1>>
<FORM PRINC !\] .OUTC>>>
<DEFMAC FUNCTION-PPRINT ('L 'OUTC 'M)
<FORM PROG
((POS1 <FORM + <FORM LINPOS .OUTC> 2>))
#DECL ((POS1) FIX)
<FORM PRINC !\# .OUTC>
<FORM PRIN1 FUNCTION .OUTC>
<FORM PRINC " (" .OUTC>
<FORM FUNCBODY
.L
<FORM LINPOS .OUTC>
<FORM LVAL POS1> .OUTC .M>
<FORM PRINC !\) .OUTC>>>
<DEFMAC CHANNEL-PPRINT ('L 'OUTC 'M)
<FORM PROG
()
<FORM PRINC !\# .OUTC>
<FORM PRIN1 CHANNEL .OUTC>
<FORM PRINC " [" .OUTC>
<FORM BLOCKP .L <FORM LINPOS .OUTC> .OUTC <FORM + .M 1>>
<FORM PRINC !\] .OUTC>>>
<DEFMAC UVECTOR-PPRINT ('L 'OUTC 'M)
<FORM PROG
((L .L))
#DECL ((L) <PRIMTYPE UVECTOR>)
<FORM PRINC "![" .OUTC>
<FORM COND
('<OR <==? WORD
<TYPEPRIM <UTYPE <LVAL L>>>>
<FLATSIZE <LVAL L>
<* 9 <LENGTH <LVAL L>>>>>
<FORM BLOCKP
<FORM LVAL L>
<FORM LINPOS .OUTC> .OUTC
<FORM + .M 2>>)
(ELSE <FORM COMELE .L .OUTC <FORM + .M 2>>)>
<FORM PRINC "!]" .OUTC>>>
<DEFMAC SEGMENT-PPRINT ('L 'OUTC 'M)
<FORM PROG () <FORM PRINC !\! .OUTC>
<FORM FORMS .L .OUTC .M <FORM CHTYPE .L FORM>>>>
<DEFMAC STRING-PPRINT ('L 'OUTC 'M) <FORM PRIN1 .L .OUTC>>
<DEFMAC TEMPLATE-PPRINT ('L 'OUTC 'M)
<FORM PROG
()
<FORM PRINC !\{ .OUTC>
<FORM COMELE .L .OUTC <FORM + .M 1>>
<FORM PRINC !\} .OUTC>>>
<DEFINE LOC-PPRINT (L OUTC M)
#DECL ((L) LOCATIVE (OUTC) <CHANNEL [12 ANY] [4 FIX]> (M) FIX)
<PRINC !\# .OUTC>
<PRINC <TYPE .L> .OUTC>
<PRINC !\ .OUTC>
<FORMS <IN .L> .OUTC .M>>
<DEFMAC RSUBR-ENTRY-PPRINT ('L 'OUTC 'M)
<FORM PROG
()
<FORM PRINC !\% .OUTC>
<FORM FORMS <FORM ENT-DUMP .L> .OUTC .M>>>
<DEFINE ENT-DUMP (RSENT)
#DECL ((RSENT) RSUBR-ENTRY)
<FORM RSUBR-ENTRY
[<COND (<TYPE? <1 .RSENT> RSUBR> <2 <1 .RSENT>>)
(ELSE <1 .RSENT>)>
<2 .RSENT>
!<REST .RSENT 2>]
<ENTRY-LOC .RSENT>>>
<DEFMAC RSUBR-PPRINT ('L 'OUTC 'M)
<FORM PROG () <FORM PRINC !\% .OUTC> <FORM FORMS <FORM DUMP .L> .OUTC .M>>>
<DEFINE DUMP (RSUB
"EXTRA" (FIXUPS <GET .RSUB RSUBR>)
(PURE <NOT <TYPE? <1 .RSUB> CODE>>))
#DECL ((RSUB) RSUBR (FIXUPS) ANY (PURE) <OR FALSE ATOM>)
<OR <TYPE? .FIXUPS LIST> <SET FIXUPS <>>>
<COND
(<OR .FIXUPS .PURE <AND <ASSIGNED? NO-DUMP> .NO-DUMP <SET PURE T>>
<=? <5 .OUTCHAN> "TTY">>
<FORM
<COND (.PURE RSUBR) (ELSE FIXUP!-RSUBRS)>
<FORM QUOTE
<MAPF ,VECTOR
<FUNCTION (OB "AUX" ATM)
#DECL ((OB) ANY (ATM) ATOM)
<COND (<AND <TYPE? .OB RSUBR RSUBR-ENTRY>
;"Named RSUBR ?"
<GASSIGNED? <SET ATM <2 .OB>>>
<TYPE? ,.ATM RSUBR RSUBR-ENTRY>>
.ATM)
(ELSE .OB)>>
.RSUB>>
!<COND (.PURE ()) (ELSE (<FORM QUOTE .FIXUPS>))>>)
(ELSE
<ERROR CAN-NOT-BE-DUMPED!-ERRORS>
<FORM RSUBR <FORM QUOTE <CHTYPE .RSUB VECTOR>>>)>>
<DEFMAC CODE-PPRINT ('L 'OUTC 'M)
<FORM PROG
()
<FORM COND
(<FORM N==? <FORM LINPOS .OUTC> 0>
<FORM TERPRI .OUTC>)>
<FORM PRIN1 .L .OUTC>>>
<DEFMAC STORAGE-PPRINT ('L 'OUTC 'M)
<FORM PROG
()
<FORM PRINC !\# .OUTC>
<FORM PRIN1 STORE .OUTC>
<FORM PRINC !\ .OUTC>
<FORM PRINC
<FORM CHTYPE
<FORM GETBITS .L #BITS *004400000000*>
FIX>
.OUTC>>>
<DEFINE CHECK2 (L OUTC M
"AUX" (F <CHECK <1 .L> 1 <REST .L> .OUTC .M>) FF)
#DECL ((L) <<PRIMTYPE LIST> [2 ANY]> (M FF) FIX (OUTC) CHANNEL
(F) <OR FALSE FIX>)
<AND .F
<NOT <GET .L COMMENT>>
<SET FF .F>
<CHECK <2 .L> <+ 2 .FF> <REST .L 2> .OUTC .M>>>
<DEFINE DECL-PPRINT (L OUTC OM "AUX" (M <+ .OM 1>) POS)
#DECL ((L) <PRIMTYPE LIST> (POS) FIX (OM M) FIX
(OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<PRINC !\# .OUTC>
<PRIN1 DECL .OUTC>
<PRINC " (" .OUTC>
<SET POS <LINPOS .OUTC>>
<COND (.FITS? <LIST-ELEMENTS .L .OUTC <+ .M 1>>)
(<NOT <0? <MOD <LENGTH .L> 2>>> <LIST-BLOCKP .L .POS .OUTC .M>)
(ELSE
<REPEAT ((FLG <CHECK2 .L .OUTC .M>) FLGC)
#DECL ((FLG) <OR FALSE FIX> (FLGC) <OR FALSE ATOM>)
<COND (<TYPE? <1 .L> LIST>
<COND (<AND .QUICKPRINT
<CHECK <1 .L> 0 <REST .L> .OUTC .M>>
<PRIN1 <1 .L> .OUTC>)
(ELSE
<PRINC !\( .OUTC>
<LIST-BLOCKP <1 .L> <LINPOS .OUTC> .OUTC <+ .M 1>>
<PRINC !\) .OUTC>)>)
(ELSE <FORMS <1 .L> .OUTC .M>)>
<LIST-COMMENTS .L .OUTC .M>
<SET L <REST .L>>
<COND (.FLG <PRINC !\ .OUTC>)
(ELSE <TERPRI .OUTC> <INDENT-TO .POS .OUTC>)>
<FORMS <1 .L> .OUTC .M>
<SET FLGC <LIST-COMMENTS .L .OUTC .M>>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN>)>
<COND (<AND <NOT .FLGC> .FLG <CHECK2 .L .OUTC .M>>
<PRINC !\ .OUTC>
<AGAIN>)>
<TERPRI .OUTC>
<INDENT-TO .POS .OUTC>>)>
<PRINC !\) .OUTC>>
\
;"Routines for PPRINTing Functions"
<DEFINE FUNCBODY (L P P1 OUTC OM
"AUX" (M <+ .OM 1>) (NEWLINE #FALSE ()) COMFLG)
#DECL ((L) <PRIMTYPE LIST> (P P1 OM M) FIX
(NEWLINE COMFLG) <OR FALSE ATOM>
(OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<PROG ()
<COND (<EMPTY? .L> <RETURN>)
(<TYPE? <1 .L> ATOM>
<OR <CHECK <1 .L> -1 .L .OUTC .M>
<TERPRI .OUTC> <INDENT-TO .P .OUTC>>
<PRIN1 <1 .L> .OUTC>
<SET COMFLG <LIST-COMMENTS .L .OUTC .M>>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN>)
(.COMFLG <TERPRI .OUTC> <SET NEWLINE T>)
(ELSE <PRINC !\ .OUTC>)>)>
<COND (<TYPE? <1 .L> LIST>
<AND .NEWLINE <INDENT-TO .P .OUTC>>
<SET NEWLINE <PRINARGL <1 .L> .P .OUTC .M>>
<SET COMFLG <LIST-COMMENTS .L .OUTC .M>>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN>)
(.COMFLG <TERPRI .OUTC> <SET NEWLINE T>)
(<NOT .NEWLINE> <PRINC !\ .OUTC>)>)>
<COND (<AND <NOT .NEWLINE> <CHECK .L -1 .L .OUTC .M>>
<LIST-ELEMENTS .L .OUTC .M>)
(ELSE
<OR .NEWLINE <TERPRI .OUTC>>
<COND (<FORMREC .L <- <LINLNT .OUTC> .P .M>>
<INDENT-TO .P1 .OUTC>)
(ELSE <INDENT-TO .P .OUTC>)>
<LIST-COMPONENTS .L .OUTC .M>)>>>
<DEFINE CHECK (IT FUDGE L OUTC M)
#DECL ((IT) ANY (FUDGE M) FIX (VALUE) <OR FALSE FIX>
(L) <PRIMTYPE LIST> (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<FLATSIZE .IT
<- <LINLNT .OUTC>
<LINPOS .OUTC>
.FUDGE
<COND (<EMPTY? .L> .M) (0)>>>>
<DEFINE PRINARGL (L PB OUTC M "AUX" POS Q (OL .L))
#DECL ((L) <SPECIAL LIST> (PB M) FIX (POS) FIX (OL) LIST
(Q) <OR LIST STRING FALSE> (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (<CHECK .L 0 .L .OUTC .M>
<PRINC !\( .OUTC>
<LIST-ELEMENTS .L .OUTC <+ .M 1>>
<PRINC !\) .OUTC>
#FALSE ())
(ELSE
<COND (<NOT <CHECK <SET Q <ABUNCH L>> -1 .L .OUTC .M>>
<TERPRI .OUTC>
<INDENT-TO .PB .OUTC>)>
<PRINC !\( .OUTC>
<SET POS <LINPOS .OUTC>>
<REPEAT ((FIRST T) (N <+ .M 1>))
#DECL ((FIRST) <OR FALSE ATOM> (N) FIX)
<COND (<NOT .Q> <RETURN>)>
<COND (<TYPE? .Q STRING>
<COND (<NOT .FIRST> <TERPRI .OUTC>
<INDENT-TO .POS .OUTC>)>
<PRIN1 .Q .OUTC>
<COND (<LIST-COMMENTS .OL .OUTC .M>
<OR <EMPTY? .L>
<TERPRI .OUTC>
<INDENT-TO .POS .OUTC>>)
(<NOT <EMPTY? .L>> <PRINC !\ .OUTC>)>)
(<LIST-BLOCKP .OL <LINPOS .OUTC> .OUTC .N .L>)>
<SET FIRST <>>
<SET OL .L>
<SET Q <ABUNCH L>>>
<PRINC !\) .OUTC>
<TERPRI .OUTC>
T)>>
<DEFINE ABUNCH (ATM "AUX" (BUNCH ..ATM))
#DECL ((ATM) ATOM (BUNCH) LIST (VALUE) <OR LIST STRING FALSE>)
<COND (<EMPTY? .BUNCH> #FALSE ())
(<TYPE? <1 .BUNCH> STRING>
<SET .ATM <REST .BUNCH>>
<1 .BUNCH>)
(ELSE
<MAPF ,LIST
<FUNCTION ("EXTRA" T)
#DECL ((T) ANY)
<COND (<OR <EMPTY? .BUNCH> <TYPE? <SET T <1 .BUNCH>> STRING>>
<SET .ATM .BUNCH>
<MAPSTOP>)
(ELSE
<SET BUNCH <REST .BUNCH>>
.T)>>>)>>
\
;"How to print FORM and its special cases.
Special cases for FORM are called from FORM-PPRINT."
<DEFMAC FORM-PPRINT ('L 'OUTC 'M)
<FORM PROG
((L .L) (L1 <FORM 1 <FORM LVAL L>>))
#DECL ((L) <PRIMTYPE LIST> (L1) ANY)
<FORM COND
('<OR <==? <LVAL L1> PROG>
<==? <LVAL L1> REPEAT>>
<FORM PROGREP <FORM LVAL L> .OUTC .M>)
('<==? <LVAL L1> LVAL>
<FORM LVAL-SPECFORM <FORM LVAL L> .OUTC .M>)
('<==? <LVAL L1> GVAL>
<FORM GVAL-SPECFORM <FORM LVAL L> .OUTC .M>)
('<==? <LVAL L1> QUOTE>
<FORM QUOTE-SPECFORM <FORM LVAL L> .OUTC .M>)
('<==? <LVAL L1> FUNCTION>
<FORM FUNCTION-SPECFORM <FORM LVAL L> .OUTC .M>)
('<OR <==? <LVAL L1> DEFINE>
<==? <LVAL L1> DEFMAC>>
<FORM DEFINE-SPECFORM <FORM LVAL L> .OUTC .M>)
(ELSE <FORM NORMFORM <FORM LVAL L> .OUTC .M>)>>>
<DEFINE NORMFORM (L OUTC M
"EXTRA" (PN <+ 1 <LINPOS .OUTC>>)
(L1 <1 .L>) COMFLG)
#DECL ((L) <PRIMTYPE LIST> (PN M) FIX (L1) ANY
(COMFLG) <OR ATOM FALSE> (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<PRINC !\< .OUTC>
<FORMS .L1 .OUTC .M>
<COND (.FITS? <COMEND .L .OUTC .M>)
(<FORMAHEAD .L <- <LINLNT .OUTC> <LINPOS .OUTC> .M>>
<PROG ()
<SET COMFLG <LIST-COMMENTS .L .OUTC .M>>
<COND (<EMPTY? <REST .L>> <RETURN>)
(<AND <NOT .COMFLG>
<OR <==? .L1 SET>
<==? .L1 SETG>
<==? .L1 STACKFORM>
<==? .L1 MAPF>
<==? .L1 MAPR>>
<CHECK <2 .L> 1 '(0) .OUTC .M>>
<SET L <REST .L>>
<PRINC !\ .OUTC>
<LIST-ELEMENTS .L .OUTC .M <REST .L>>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN>)>)
(ELSE <SET L <REST .L>>)>
<TERPRI .OUTC>
<INDENT-TO .PN .OUTC>
<COND (<CHECK .L 3 .L .OUTC .M> <LIST-ELEMENTS .L .OUTC <+ .M 1>>)
(ELSE <LIST-COMPONENTS .L .OUTC <+ .M 1>>)>>)
(T <COMEND .L .OUTC .M>)>
<PRINC !\> .OUTC>>
<DEFMAC COMEND ('L 'OUTC 'M)
<FORM PROG
((L .L) (PPN <FORM LINPOS .OUTC>))
#DECL ((L) <PRIMTYPE LIST> (PPN) FIX)
<FORM COND
(<FORM LIST-COMMENTS <FORM LVAL L> .OUTC .M>
<FORM TERPRI .OUTC>
<FORM INDENT-TO <FORM LVAL PPN> .OUTC>)>
<FORM COND
(<FORM EMPTY? <FORM REST <FORM LVAL L>>>)
(<FORM PRINC !\ .OUTC>
<FORM LIST-COMELE <FORM REST <FORM LVAL L>>
.OUTC <FORM + .M 1>>)>>>
<DEFMAC FORMAHEAD ('F 'AVSP)
<FORM PROG
((F .F) (AVSP .AVSP))
#DECL ((F) <PRIMTYPE LIST> (AVSP) FIX)
<FORM COND
(<FORM AND
<FORM TYPE? <FORM 1 <FORM LVAL F>> FORM SEGMENT>
<FORM NOT <FORM EMPTY? <FORM REST <FORM LVAL F>>>>
<FORM NOT
<FORM FLATSIZE
<FORM 1 <FORM LVAL F>>
<FORM LVAL AVSP>>>>
T)
(ELSE <FORM FORMREC <FORM LVAL F> <FORM LVAL AVSP>>)>>>
<DEFMAC FORMREC ('F 'AVSP)
<FORM COND
('.LOOKAHEAD <FORM FORMREC1 .F .AVSP>)
(ELSE '.VERTICAL)>>
<DEFINE FORMREC1 (F AVSP)
#DECL ((AVSP) FIX (F) <<PRIMTYPE LIST> ANY>)
<PROG (FS FSFIX FO)
#DECL ((FSFIX) FIX (FS) <OR FALSE FIX> (FO) ANY)
<COND (<SET FS <FLATSIZE <1 .F> .AVSP>>)
(<TYPE? .F FORM SEGMENT>
<COND (<EMPTY? <REST .F>> <RETURN #FALSE ()>)
(ELSE <RETURN T>)>)
(<OR <MONAD? <1 .F>>
<NOT <==? <PRIMTYPE <1 .F>> LIST>>
<FORMREC1 <1 .F> .AVSP>>
<RETURN T>)>
<COND (<EMPTY? <REST .F>> <RETURN #FALSE ()>)>
<COND (<TYPE? .F FORM SEGMENT>
<COND (<AND <TYPE? <SET FO <1 .F>> ATOM>
<OR <==? .FO LVAL>
<==? .FO GVAL>
<==? .FO QUOTE>>>
<SET AVSP <- .AVSP 1>>)
(ELSE
<SET FSFIX .FS>
<SET AVSP <- .AVSP .FSFIX 3>>)>)
(<TYPE? .F FUNCTION> <SET AVSP <- .AVSP 12>>)
(<TYPE? .F DECL> <SET AVSP <- .AVSP 8>>)
(ELSE <SET AVSP <- .AVSP 3>>)>
<SET F <REST .F>>
<REPEAT ((F2 <1 .F>) (F1 .F))
#DECL ((F1) LIST (F2) ANY)
<COND (<MONAD? .F2> <OR <FLATSIZE .F2 .AVSP> <RETURN T>>)
(<FLATSIZE .F2 .AVSP>)
(<NOT <==? LIST <PRIMTYPE .F2>>>)
(<FORMREC1 .F2 .AVSP> <RETURN T>)>
<COND (<EMPTY? <SET F1 <REST .F1>>> <RETURN #FALSE ()>)>
<SET F2 <1 .F1>>>>>
<DEFINE PROGREP (L OUTC M
"AUX" (POS1 <+ 2 <LINPOS .OUTC>>) POS COMFLG)
#DECL ((L) <PRIMTYPE LIST> (POS1 POS M) FIX
(COMFLG) <OR FALSE ATOM> (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<PRINC !\< .OUTC>
<PRIN1 <1 .L> .OUTC>
<SET POS <+ 1 <LINPOS .OUTC>>>
<SET COMFLG <LIST-COMMENTS .L .OUTC .M>>
<COND (<EMPTY? <SET L <REST .L>>>)
(ELSE
<PROG ()
<COND (<TYPE? <1 .L> ATOM>
<COND (.COMFLG <TERPRI .OUTC> <INDENT-TO .POS .OUTC>)
(ELSE <PRINC !\ .OUTC>)>
<PRIN1 <1 .L> .OUTC>
<SET COMFLG <LIST-COMMENTS .L .OUTC .M>>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN>)>)>
<COND (<TYPE? <1 .L> LIST>
<COND (.COMFLG <TERPRI .OUTC> <INDENT-TO .POS .OUTC>)
(ELSE <PRINC !\ .OUTC>)>
<COND (<CHECK <1 .L> 1 .L .OUTC .M> <FORMS <1 .L> .OUTC .M>)
(ELSE
<PRINC !\( .OUTC>
<LIST-BLOCKP <1 .L> <LINPOS .OUTC> .OUTC .M>
<PRINC !\) .OUTC>)>
<LIST-COMMENTS .L .OUTC .M>
<COND (<EMPTY? <SET L <REST .L>>> <RETURN>)>)>
<COND (<FORMREC .L <- <LINLNT .OUTC> .POS .M>>
<TERPRI .OUTC>
<INDENT-TO .POS1 .OUTC>)
(ELSE
<AND <G? <LINPOS .OUTC> .POS> <TERPRI .OUTC>>
<INDENT-TO .POS .OUTC>)>
<LIST-COMPONENTS .L .OUTC <+ .M 1>>>)>
<PRINC !\> .OUTC>>
<DEFMAC LVAL-SPECFORM ('L 'OUTC 'M)
<FORM DAMMIT !\. .L .OUTC .M>>
<DEFMAC GVAL-SPECFORM ('L 'OUTC 'M)
<FORM DAMMIT !\, .L .OUTC .M>>
<DEFMAC QUOTE-SPECFORM ('L 'OUTC 'M)
<FORM DAMMIT !\' .L .OUTC .M>>
<DEFMAC DAMMIT ('Q 'L 'OUTC 'M)
<FORM PROG
((L .L))
#DECL ((L) <PRIMTYPE LIST>)
<FORM COND
(<FORM ==? 2 <FORM LENGTH <FORM LVAL L>>>
<FORM PRINC .Q .OUTC>
<FORM LIST-COMELE <FORM REST <FORM LVAL L>> .OUTC <FORM + .M 1>>)
(ELSE <FORM NORMFORM <FORM LVAL L> .OUTC .M>)>>>
<DEFMAC FUNCTION-SPECFORM ('L 'OUTC 'M)
<FORM PROG
((L .L) (POS1 <FORM + <FORM LINPOS .OUTC> 3>)
POS
COMFLG)
#DECL ((L) <PRIMTYPE LIST> (POS1 POS) FIX (COMFLG) <OR FALSE ATOM>)
<FORM PRINC !\< .OUTC>
<FORM PRIN1 FUNCTION .OUTC>
<FORM SET POS <FORM - <FORM LINPOS .OUTC> 1>>
<FORM PROG
()
<FORM SET COMFLG <FORM LIST-COMMENTS <FORM LVAL L> .OUTC .M>>
<FORM COND
(<FORM EMPTY? <FORM SET L <FORM REST <FORM LVAL L>>>>
<FORM RETURN>)
(<FORM LVAL COMFLG>
<FORM TERPRI .OUTC>
<FORM INDENT-TO <FORM LVAL POS> .OUTC>)
(ELSE <FORM PRINC !\ .OUTC >)>
<FORM FUNCBODY
<FORM LVAL L>
<FORM LVAL POS>
<FORM LVAL POS1> .OUTC .M>>
<FORM PRINC !\> .OUTC>>>
<DEFMAC DEFINE-SPECFORM ('L 'OUTC 'M)
<FORM PROG
((L .L)
(POS1 <FORM + <FORM LINPOS .OUTC> 3>)
POS
COMFLG)
#DECL ((POS POS1) FIX (L) <PRIMTYPE LIST> (COMFLG) <OR FALSE ATOM>)
<FORM PRINC !\< .OUTC>
<FORM PRIN1 <FORM 1 <FORM LVAL L>> .OUTC>
<FORM SET POS <FORM + 1 <FORM LINPOS .OUTC>>>
<FORM PROG
()
<FORM SET COMFLG <FORM LIST-COMMENTS <FORM LVAL L> .OUTC .M>>
<FORM COND
(<FORM EMPTY? <FORM SET L <FORM REST <FORM LVAL L>>>>
<FORM RETURN>)
(<FORM LVAL COMFLG>
<FORM TERPRI .OUTC>
<FORM INDENT-TO <FORM LVAL POS> .OUTC>)
(ELSE <FORM PRINC !\ .OUTC>)>
<FORM PRIN1 <FORM 1 <FORM LVAL L>> .OUTC>
<FORM SET COMFLG <FORM LIST-COMMENTS <FORM LVAL L> .OUTC .M>>
<FORM COND
(<FORM EMPTY? <FORM SET L <FORM REST <FORM LVAL L>>>>
<FORM RETURN>)
(<FORM LVAL COMFLG>
<FORM TERPRI .OUTC>
<FORM INDENT-TO <FORM LVAL POS> .OUTC>)
(ELSE <FORM PRINC !\ .OUTC>)>
<FORM FUNCBODY
<FORM LVAL L>
<FORM LVAL POS>
<FORM LVAL POS1> .OUTC .M>>
<FORM PRINC !\> .OUTC>>>
\
<SETG LINPOS 14>
<SETG LINLNT 13>
<SETG PAGPOS 16>
<SETG PAGLNT 15>
<MANIFEST LINPOS LINLNT PAGPOS PAGLNT>
<SETG TABS ;"The n'th element is a string of n-1 tab characters"
<PROG ((I -1))
<IVECTOR 15 '<ISTRING <SET I <+ .I 1>> !\ >>>>
<SETG SPACES ;"The n'th element is a string of n-1 space characters"
<PROG ((I -1))
<IVECTOR 8 '<ISTRING <SET I <+ .I 1>> !\ >>>>
<GDECL (TABS SPACES) <VECTOR [REST STRING]>>
<DEFINE INDENT-TO (N "OPTIONAL" (OUTC .OUTCHAN) "EXTRA" (NOW <LINPOS .OUTC>))
;"Print tabs and spaces to get to column -n-"
#DECL ((N NOW) FIX (OUTC) <CHANNEL [12 ANY] [4 FIX]>)
<COND (<G? .N .NOW>
<PRINC <NTH ,TABS <MIN 15 <- </ .N 8> </ .NOW 8> -1>>>
.OUTC>
<COND (<G? .N <SET NOW <LINPOS .OUTC>>>
;"Can be screwed by MORE interrupt otherwise"
<PRINC <NTH ,SPACES <- .N .NOW -1>> .OUTC>)>)>>
<ENDPACKAGE>
Reference in New Issue View Git Blame Copy Permalink