X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=%3Cmdl.int%3E%2Fgcgdgl.mud.1;fp=%3Cmdl.int%3E%2Fgcgdgl.mud.1;h=8578f7651671b39affdad30216ec049b0b1bc45a;hp=0000000000000000000000000000000000000000;hb=bab072f950a643ac109660a223b57e635492ac25;hpb=233a3c5245f8274882cc9d27a3c20e9b3678000c

diff --git a/<mdl.int>/gcgdgl.mud.1 b/<mdl.int>/gcgdgl.mud.1
new file mode 100644
index 0000000..8578f76
--- /dev/null
+++ b/<mdl.int>/gcgdgl.mud.1
@@ -0,0 +1,186 @@
+
+<PACKAGE "GC-GRLOAD">
+
+<ENTRY GC-GROUP-LOAD GC-GROUP-DUMP>
+
+<USE "EDIT">
+
+<COND (<G? ,MUDDLE 100> <SETG TNM1 "ETMP"> <SETG TNM2 "MUDT">)
+      (ELSE <SETG TNM1 "_ETMP_"> <SETG TNM2 ">">)>
+
+<SETG VCOMP
+      <FORM COND
+	    (<FORM N==? ,MUDDLE <FORM GVAL MUDDLE>>
+	     <FORM ERROR RSUBR-CANT-RUN-IN-THIS-VERSION-OF-MUDDLE!-ERRORS>)>>
+
+<DEFINE GC-GROUP-LOAD (STR
+		       "OPTIONAL" NAM
+		       "AUX" (CHN <OPEN "READB" .STR>) FSP (REDEFINE T))
+	#DECL ((REDEFINE) <SPECIAL ANY>)
+	<PROG ()
+	      <COND (<NOT <TYPE? .CHN CHANNEL>> <RETURN .CHN>)>
+	      <COND (<NOT <ASSIGNED? NAM>>
+		     <SET NAM
+			  <PARSE <MAPF ,STRING
+				       <FUNCTION (C) <MAPRET !"\\ .C>>
+				       <7 .CHN>>>>)>
+				      ;"To hack ugly file names. (TT, 75/10/07)"
+	      <PUT .NAM
+		   CHANNEL
+		   <SET FSP <LIST <7 .CHN> <8 .CHN> <9 .CHN> <10 .CHN>>>>
+	      <EVAL <GC-READ .CHN>>
+	      <CLOSE .CHN>
+	      .NAM>>
+
+<DEFINE GC-GROUP-DUMP (STR
+		       "OPTIONAL" NM (BKILLER T)
+		       "AUX" (CHN <CHANNEL "PRINTB" .STR>)
+			     (NAM
+			      <COND (<ASSIGNED? NM> .NM)
+				    (ELSE <PARSE <7 .CHN>>)>)
+			     (OC
+			      <OPEN "PRINTB" ,TNM1 ,TNM2 <9 .CHN> <10 .CHN>>)
+			     (FIXERS ()) FUNC BKS TEM TT HOLDANY GRP FIXES)
+   #DECL ((CHN) CHANNEL (NAM) ATOM (OC) <OR CHANNEL FALSE> (FIXERS) LIST)
+   <PROG ()
+     <COND (<NOT .OC> <RETURN .OC>)>
+     <COND (<OR <NOT <ASSIGNED? .NAM>> <NOT <TYPE? ..NAM LIST>>>
+	    <CLOSE .OC>
+	    <RETURN #FALSE ("Not a valid group name")>)>
+     <SET GRP ..NAM>
+     <SET FIXERS
+	  (<FORM PUT .NAM BLOCK <FORM UNGET <UNGET <GET .NAM BLOCK '.OBLIST>>>>
+	   !.FIXERS)>
+     <MAPR <>
+      <FUNCTION (OBP "AUX" (OB <1 .OBP>)) 
+	 <COND (<SET TEM <GET <FORM QUOTE .OBP> COMMENT>>
+		<SET FIXERS
+		     (<FORM PUT <FORM QUOTE .OBP> COMMENT .TEM> !.FIXERS)>)>
+	 <COND (<SET TEM <GET .OBP BLOCK>>
+		<SET FIXERS
+		     (<FORM PUT
+			    <FORM QUOTE .OBP>
+			    BLOCK
+			    <FORM UNGET <UNGET .TEM>>>
+		      !.FIXERS)>)>
+	 <COND
+	  (<AND <TYPE? .OB FORM> <NOT <EMPTY? .OB>>>
+	   <COND
+	    (<OR <==? <SET TEM <1 .OB>> DEFINE> <==? .TEM DEFMAC>>
+	     <COND
+	      (<AND
+		.BKILLER				   ;"Breakpoint killer"
+		<G? <LENGTH .OB> 1>
+		<SET BKS
+		     <GETPROP
+		      <AND <GASSIGNED? <SET FUNC <GET <2 .OB> VALUE '<2
+								      .OB>>>>
+			   <GLOC .FUNC>>
+		      BREAKS>>>
+	       <PUTPROP <GLOC .FUNC> BREAKS>
+	       <REPEAT ()
+		       <COND (<EMPTY? .BKS> <RETURN>)>
+		       <COND (<TYPE? <SET HOLDANY <IN <1 .BKS>>> BREAK>
+			      <SETLOC <1 .BKS> <2 .HOLDANY>>)>
+		       <SET BKS <REST .BKS>>>)>
+	     <SET TEM <COMMENT-ON .OB>>
+	     <COND (<NOT <EMPTY? .TEM>>
+		    <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .FIXERS>
+		    <SET FIXERS .TEM>)>)
+	    (<AND <==? .TEM SETG>
+		  <==? <LENGTH .OB> 3>
+		  <TYPE? <SET NM <GET <2 .OB> VALUE '<2 .OB>>> ATOM>
+		  <OR <TYPE? <SET TEM <3 .OB>> RSUBR>
+		      <AND <GASSIGNED? .NM> <TYPE? <SET TEM ,.NM> RSUBR>>>
+		  <==? .NM <2 .TEM>>>
+	     <COND (<AND <TYPE? <1 .TEM> CODE> <SET FIXES <GET .TEM RSUBR>>>
+		    <SET FIXERS
+			 (<FORM FIXIT <FORM QUOTE .TEM> .FIXES> !.FIXERS)>)
+		   (<TYPE? <1 .TEM> CODE>
+		    <PRINC 
+"Warning:  RSUBR lacks fixups, only use in same MUDDLE version.  ">
+		    <PRIN1 .NM>
+		    <CRLF>
+		    <SET FIXERS (,VCOMP !.FIXERS)>)>
+	     <COND (<NOT <EMPTY? <SET TT <ANON-SRCH .TEM>>>>
+		    <PUTREST <REST .TT <- <LENGTH .TT> 1>> .FIXERS>
+		    <SET FIXERS .TT>)>
+	     <COND (<TYPE? <SET TT <1 .TEM>> PCODE>
+		    <SET FIXERS
+			 (<FORM PUT
+				<FORM QUOTE .TEM>
+				1
+				<PARSE <REST <UNPARSE .TT>>>>
+			  !.FIXERS)>)>)>)>>
+      .GRP>
+     <GC-DUMP (<FORM MAPF
+		     <>
+		     <FORM GVAL EVAL>
+		     <FORM SET .NAM <FORM QUOTE .GRP>>>
+	       .FIXERS)
+	      .OC>
+     <RENAME .OC .STR>
+     <CLOSE .OC>
+     .NAM>>
+
+<DEFINE COMMENT-ON (OB "AUX" (L ()) TEM TT) 
+   <COND
+    (<NOT <MONAD? .OB>>
+     <MAPR <>
+	   <FUNCTION (OBP) 
+		   <COND (<SET TEM <GET .OBP COMMENT>>
+			  <SET L
+			       (<FORM PUT <FORM QUOTE .OBP> COMMENT .TEM>
+				!.L)>)>
+		   <COND (<NOT <EMPTY? <SET TEM <COMMENT-ON <1 .OBP>>>>>
+			  <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .L>
+			  <SET L .TEM>)>>
+	   <REST .OB>>
+     <COND (<SET TEM <GET <1 .OB> COMMENT>>
+	    <SET L (<FORM PUT <FORM QUOTE <1 .OB>> COMMENT .TEM> !.L)>)>
+     <COND (<OR <SET TEM <GET <SET TT .OB> COMMENT>>
+		<SET TEM <GET <SET TT <REST .OB 0>> COMMENT>>>
+	    <SET L (<FORM PUT <FORM QUOTE .TT> COMMENT .TEM> !.L)>)>)
+    (<SET TEM <GET .OB COMMENT>> <SET L (.TEM)>)>
+   .L>
+
+<DEFINE ANON-SRCH (R "AUX" (L ()) TEM) 
+   #DECL ((R) <PRIMTYPE VECTOR> (L) LIST)
+   <MAPR <>
+    <FUNCTION (THP "AUX" (THING <1 .THP>)) 
+	    <COND (<AND <TYPE? .THING RSUBR>
+			<G? <LENGTH .THING> 1>
+			<TYPE? <SET TEM <2 .THING>> ATOM>
+			<OR <NOT <GASSIGNED? .TEM>> <N==? ,.TEM .THING>>>
+		   <COND (<AND <TYPE? <1 .THING> CODE>
+			       <SET TEM <GET .THING RSUBR>>>
+			  <SET L (<FORM FIXIT <FORM QUOTE .THING> .TEM> !.L)>)
+			 (<TYPE? <1 .THING> CODE>
+			  <PRINC 
+"Warning:  RSUBR lacks fixups, only use in same MUDDLE version.  ">
+			  <PRIN1 <2 .THING>>
+			  <CRLF>)>)>
+	    <COND (<AND <TYPE? .THING RSUBR> <TYPE? <1 .THING> PCODE>>
+		   <SET L
+			(<FORM PUT
+			       <FORM QUOTE .THING>
+			       1
+			       <PARSE <REST <UNPARSE <1 .THING>>>>>
+			 !.L)>)>
+	    <COND (<TYPE? .THING LOCD LOCR TYPE-W TYPE-C>
+		   <SET L
+			(<FORM PUT
+			       <FORM QUOTE .THP>
+			       1
+			       <PARSE <REST <UNPARSE .THING>>>>
+			 !.L)>
+		   <COND (<TYPE? .THING LOCD>
+			  <PUT .THP 1 LOCD>)>)>>
+    .R>
+   .L>
+
+<DEFINE UNGET (O)
+	<MAPF ,LIST <FUNCTION (X) <GET .X OBLIST>> .O>>
+
+<ENDPACKAGE>
+
\ No newline at end of file