X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=%3Cmdl.comp%3E%2Fnprint.mud.21;fp=%3Cmdl.comp%3E%2Fnprint.mud.21;h=cdc6250ac7ebf4dc5d1a591dbbd0f5c0b9c8492e;hp=0000000000000000000000000000000000000000;hb=3395a5e4ef72d59cdb6832af7808dc9c2cf2a413;hpb=363cc6ead5cf4df20759797fe46b5dc29b3886e9

diff --git a/<mdl.comp>/nprint.mud.21 b/<mdl.comp>/nprint.mud.21
new file mode 100644
index 0000000..cdc6250
--- /dev/null
+++ b/<mdl.comp>/nprint.mud.21
@@ -0,0 +1,207 @@
+<PACKAGE "NPRINT">
+
+<ENTRY NODE-COMPLAIN NODE-PRINT>
+
+<USE "COMPDEC">
+
+<DEFINE NODE-COMPLAIN (N "OPTIONAL" (MAX 80) "AUX" (P .N) TEM) 
+	#DECL ((N) NODE (MAX) FIX (P) <OR VECTOR NODE>)
+	<REPEAT ((OPP .P))
+		<AND <EMPTY? .OPP> <RETURN>>
+		<OR <NODE-PRINT .OPP .N .MAX T> <RETURN>>
+		<OR <TYPE? <SET TEM <PARENT <SET P .OPP>>> NODE>
+		    <RETURN>>
+		<OR <MEMQ .OPP <KIDS <SET OPP .TEM>>>
+		    <RETURN>>>
+	<NODE-PRINT .P .N .MAX>>
+
+<DEFINE NODE-PRINT (N
+		    "OPTIONAL" (LOSER <>) (MAX 80) (FLAT <>)
+		    "AUX" (OUTC .OUTCHAN)
+			  (OUTCHAN
+			   <OPEN "PRINT" "INT:" <COND (.FLAT ,NF) (ELSE ,NP)>>)
+			  (NCHS 0))
+	#DECL ((MAX) <SPECIAL FIX> (NCHS) <SPECIAL ANY>
+	       (OUTCHAN OUTC) <SPECIAL CHANNEL>
+	       (LOSER) <SPECIAL <OR FALSE NODE>>)
+	<PUT .OUTCHAN 13 <- <13 .OUTC> 2>>
+	<COND (<PROG NACT ()
+		     #DECL ((NACT) <SPECIAL ACTIVATION>)
+		     <NPRINT .N>
+		     <>>
+	       <OR .FLAT <PRINC " ..." .OUTC>>
+	       <SET NCHS <>>)>
+	<OR .FLAT <TERPRI .OUTC>>
+	<CLOSE .OUTCHAN>
+	.NCHS>
+
+<DEFINE NF (CH) 
+	<COND (<L? <SET MAX <- .MAX 1>> 0> <RETURN T .NACT>)>
+	<SET NCHS <+ .NCHS 1>>>
+
+<DEFINE NP (CH) #DECL ((CH) CHARACTER)
+	<COND (<L? <SET MAX <- .MAX 1>> 0> <RETURN T .NACT>)>
+	<PRINC .CH .OUTC>>
+
+<DEFINE NPRINT (N "AUX" (COD <NODE-TYPE .N>) TC (FLG <==? .N .LOSER>)) 
+	#DECL ((N) NODE (COD TC) FIX)
+	<AND .FLG <PRINC " **** ">>
+	<COND (<OR <==? .COD ,FUNCTION-CODE> <==? .COD ,MFCN-CODE>>
+	       <PRINC "<FUNCTION ">
+	       <PRNARGL <BINDING-STRUCTURE .N> <RESULT-TYPE .N> <>>
+	       <PRINC " ">
+	       <SEQ-PRINT <KIDS .N>>
+	       <PRINC ">">)
+	      (<==? .COD ,PROG-CODE>
+	       <PRINC "<">
+	       <PRIN1 <NODE-NAME .N>>
+	       <PRINC " ">
+	       <PRNARGL <BINDING-STRUCTURE .N> <RESULT-TYPE .N> T>
+	       <PRINC " ">
+	       <SEQ-PRINT <KIDS .N>>
+	       <PRINC ">">)
+	      (<==? .COD ,MFIRST-CODE>
+	       <PRINC <NTH ,MAP-SPEC-PRINT <NODE-SUBR .N>>>)
+	      (<==? .COD ,MPSBR-CODE>
+	       <PRINC ",">
+	       <OR <AND <EMPTY? <KIDS .N>> some-subr>
+		   <PRIN1 <NODE-NAME <1 <KIDS .N>>>>>)
+	      (<==? .COD ,COPY-CODE>
+	       <PRINC <NTH ,ST-CHRS
+			   <SET TC
+				<LENGTH <MEMQ <NODE-NAME .N>
+					      '![UVECTOR VECTOR LIST!]>>>>>
+	       <SEQ-PRINT <KIDS .N>>
+	       <PRINC <NTH ,EN-CHRS .TC>>)
+	      (<OR <==? .COD ,SEG-CODE> <==? .COD ,SEGMENT-CODE>>)
+	      (<==? .COD ,BRANCH-CODE>
+	       <PRINC "(">
+	       <NPRINT <PREDIC .N>>
+	       <COND (<NOT <EMPTY? <CLAUSES .N>>>
+		      <PRINC " ">
+		      <SEQ-PRINT <CLAUSES .N>>)>
+	       <PRINC ")">)
+	      (<==? .COD ,QUOTE-CODE>
+	       <AND <TYPE? <NODE-NAME .N> VECTOR UVECTOR LIST FORM>
+		    <PRINC !"'>>
+	       <PRIN1 <NODE-NAME .N>>)
+	      (<OR <==? .COD ,SET-CODE> <==? .COD ,FSET-CODE>>
+	       <PRINC "<">
+	       <PRIN1 SET>
+	       <PRINC " ">
+	       <SEQ-PRINT <KIDS .N>>
+	       <PRINC ">">)
+	      (<OR <MEMQ .COD ,LGV>
+		   <AND <==? .COD ,SUBR-CODE>
+			<OR <AND <==? <NODE-SUBR .N> ,LVAL>
+				 <SET COD ,FLVAL-CODE>>
+			    <AND <==? <NODE-SUBR .N> ,GVAL>
+				 <SET COD ,FGVAL-CODE>>>>>
+	       <COND (<OR <==? .COD ,LVAL-CODE> <==? .COD ,FLVAL-CODE>>
+		      <PRINC !".>)
+		     (ELSE <PRINC !",>)>
+	       <COND (<TYPE? <NODE-NAME .N> SYMTAB>
+		      <PRIN1 <NAME-SYM <NODE-NAME .N>>>)
+		     (ELSE <OR <AND <EMPTY? <KIDS .N>> some-atom>
+			       <NPRINT <1 <KIDS .N>>>>)>)
+	      (<==? <NODE-NAME .N> INTH>
+	       <PRINC "<">
+	       <OR <EMPTY? <KIDS .N>> <NPRINT <2 <KIDS .N>>>>
+	       <PRINC " ">
+	       <OR <EMPTY? <KIDS .N>> <NPRINT <1 <KIDS .N>>>>
+	       <PRINC ">">)
+	      (ELSE
+	       <PRINC "<">
+	       <PRINC <NODE-NAME .N>>
+	       <PRINC " ">
+	       <SEQ-PRINT <KIDS .N>>
+	       <PRINC ">">)>
+	<AND .FLG <PRINC " **** ">>>
+
+<SETG MAP-SPEC-PRINT [",+" ",-" ",*" ",/" ",LIST"]>
+
+<SETG LGV
+      ![,LVAL-CODE ,FLVAL-CODE ,GVAL-CODE ,FGVAL-CODE!]>
+
+<SETG ST-CHRS ["(" "[" "!["]>
+
+<SETG EN-CHRS [")" "]" "!]"]>
+
+<DEFINE SEQ-PRINT (L) #DECL ((L) <LIST [REST NODE]>)
+	<COND (<NOT <EMPTY? .L>>
+	       <NPRINT <1 .L>>
+	       <COND (<NOT <EMPTY? <SET L <REST .L>>>>
+		      <MAPF <>
+			    <FUNCTION (N)
+				#DECL ((N) NODE)
+				<PRINC " ">
+				<NPRINT .N>>
+			    .L>)>)>>
+
+<DEFINE PRNARGL (B R "OPTIONAL" (INAUX <>) "AUX" (INOPT <>) (DC ()) (FIRST T)) 
+	#DECL ((B) <LIST [REST SYMTAB]> (DC) LIST)
+	<PRINC "(">
+	<MAPF <>
+	      <FUNCTION (SYM "AUX" (COD <CODE-SYM .SYM>)) 
+		      #DECL ((SYM) SYMTAB (COD) FIX)
+		      <OR .FIRST <PRINC " ">>
+		      <SET FIRST <>>
+		      <COND (<==? .COD 1>
+			     <PRINC "\"NAME\" ">
+			     <PRIN1 <NAME-SYM .SYM>>)
+			    (<L=? .COD 3>
+			     <COND (<NOT .INAUX>
+				    <SET INAUX T>
+				    <PRINC "\"AUX\" ">)>
+			     <COND (<==? .COD 2>
+				    <PRINC "(">
+				    <PRIN1 <NAME-SYM .SYM>>
+				    <PRINC " ">
+				    <NPRINT <INIT-SYM .SYM>>
+				    <PRINC ")">)
+				   (ELSE <PRIN1 <NAME-SYM .SYM>>)>)
+			    (<==? .COD 4>
+			     <PRINC "\"TUPLE\" ">
+			     <PRIN1 <NAME-SYM .SYM>>)
+			    (<==? .COD 5>
+			     <PRINC "\"ARGS\" ">
+			     <PRIN1 <NAME-SYM .SYM>>)
+			    (<L=? .COD 9>
+			     <COND (<NOT .INOPT>
+				    <SET INOPT T>
+				    <PRINC "\"OPTIONAL\" ">)>
+			     <COND (<L=? .COD 7>
+				    <PRINC "(">
+				    <AND <==? .COD 6> <PRINC "'">>
+				    <PRIN1 <NAME-SYM .SYM>>
+				    <PRINC " ">
+				    <NPRINT <INIT-SYM .SYM>>
+				    <PRINC ")">)
+				   (ELSE
+				    <AND <==? .COD 8> <PRINC "'">>
+				    <PRIN1 <NAME-SYM .SYM>>)>)
+			    (<==? .COD 10>
+			     <PRINC "\"CALL\" ">
+			     <PRIN1 <NAME-SYM .SYM>>)
+			    (<==? .COD 11>
+			     <PRINC "\"BIND\" ">
+			     <PRIN1 <NAME-SYM .SYM>>)
+			    (ELSE
+			     <AND <==? .COD 12> <PRINC "'">>
+			     <PRIN1 <NAME-SYM .SYM>>)>
+		      <COND (<N==? <1 <DECL-SYM .SYM>> ANY>
+			     <SET DC
+				  ((<NAME-SYM .SYM>)
+				   <1 <DECL-SYM .SYM>>
+				   !.DC)>)>>
+	      .B>
+	<COND (<AND .R <N==? .R ANY>> <SET DC ('(VALUE) .R !.DC)>)>
+	<PRINC ")">
+	<COND (<NOT <EMPTY? .DC>> <PRINC " "> <PRIN1 <CHTYPE .DC DECL>>)>>
+
+
+
+
+
+<ENDPACKAGE>
+
\ No newline at end of file