X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=mim%2Fdevelopment%2Fmim%2Fmimc%2Fmset.mud;fp=mim%2Fdevelopment%2Fmim%2Fmimc%2Fmset.mud;h=9d363644487a3627d027c2246d7b0b5240eef773;hp=0000000000000000000000000000000000000000;hb=d73ace3f3292e320b461b8fcd2e9f5dc5d9684d7;hpb=d530283ea60fb0ddcc28e9c5bd072456afe06e07

diff --git a/mim/development/mim/mimc/mset.mud b/mim/development/mim/mimc/mset.mud
new file mode 100644
index 0000000..9d36364
--- /dev/null
+++ b/mim/development/mim/mimc/mset.mud
@@ -0,0 +1,275 @@
+
+<DEFINE MULTI-SET-GEN (N:NODE W
+		       "AUX" (K:<LIST [REST NODE]> <KIDS .N>) (SEG? <>)
+			     (SIDE-E <>) (MX:FIX 0) (MN:FIX 0)
+			     (VARS:<LIST [REST LIST]> <NODE-NAME .N>) TL:LIST
+			     (VLN:FIX <LENGTH .VARS>)
+			     (LV:<OR ATOM SYMTAB> <1 <NTH .VARS .VLN>>) (I:FIX 0))
+   <MAPF <>
+    <FUNCTION (N:NODE "AUX" RT) 
+	    <COND (<OR <==? <SET NT <NODE-TYPE .N>> ,SEG-CODE>
+		       <==? .NT ,SEGMENT-CODE>>
+		   <SET SEG? T>
+		   <SET MX <MAX <+ <MAXL <SET RT <RESULT-TYPE <1 <KIDS .N>>>>> .MX>
+				,MAX-LENGTH>>
+		   <SET MN <+ <MINL .RT> .MN>>)
+		  (ELSE
+		   <SET I <+ .I 1>>
+		   <SET MN <+ .MN 1>>
+		   <SET MX <MAX <+ .MX 1> ,MAX-LENGTH>>)>
+	    <COND (<AND <G=? <LENGTH .N> <INDEX ,SIDE-EFFECTS>>
+			<SIDE-EFFECTS .N>>
+		   <SET SIDE-E T>)>>
+    <SET K <REST .K>>>
+   <COND
+    (.SEG?
+     <PROG ((SEGLABEL <MAKE-TAG>) COUNTMP (SEGCALLED <>) SEGTMP)
+       #DECL ((SEGLABEL COUNTMP SEGCALLED) <SPECIAL ANY>)
+       <MAPF <>
+	<FUNCTION (NN:NODE "AUX" (NT <NODE-TYPE .NN>) RES) 
+	   <COND
+	    (<OR <==? .NT ,SEG-CODE> <==? .NT ,SEGMENT-CODE>>
+	     <COND (<NOT <ASSIGNED? SEGTMP>>
+		    <SET SEGTMP <GEN-TEMP <>>>
+		    <SET COUNTMP <GEN-TEMP FIX>>
+		    <SET-TEMP .COUNTMP .I '(`TYPE FIX)>)>
+	     <SET RES <GEN <SET NN <1 <KIDS .NN>>> .SEGTMP>>
+	     <SET SEGTYP <STRUCTYP-SEG <RESULT-TYPE .NN>>>
+	     <COND (<AND <N==? .RES ,NO-DATUM> <N==? .SEGTYP MULTI>>
+		    <SEGMENT-STACK .SEGTMP
+				   .COUNTMP
+				   .SEGTYP
+				   <ISTYPE? <RESULT-TYPE .NN>>
+				   .SEGLABEL>
+		    <SET SEGLABEL <MAKE-TAG>>)
+		   (.SEGCALLED
+		    <LABEL-TAG .SEGLABEL>
+		    <SET SEGLABEL <MAKE-TAG>>)>)
+	    (ELSE
+	     <COND (.CNT <IEMIT `ADD .CNT 1 = .CNT>)>
+	     <GEN .NN ,POP-STACK>)>>
+	.K>
+       <COND (<AND .CAREFUL <N==? .MX .MN>>
+	      <IEMIT `VEQUAL? .COUNTMP .VLN - `COMPERR>)>
+       <REPEAT ()
+	       <IEMIT `POP = <TEMP-NAME-SYM <1 <NTH .VARS .VLN>>>>
+	       <COND (<==? <SET VLN <- .VLN 1>> 0> <RETURN>)>>>)
+    (.SIDE-E
+     <SET TL
+	  <MAPF ,LIST
+		<FUNCTION (NN:NODE SYP:<LIST <OR ATOM SYMTAB>>
+			   "AUX" (TY <RESULT-TYPE .NN>) PT
+				 (SY:<OR ATOM SYMTAB> <1 .SYP>))
+			<COND (<TYPE? .SY SYMTAB>
+			       <SET TY <TYPE-AND <2 .SYP> .TY>>)>
+			<COND (<AND <SET TY <ISTYPE? .TY>>
+				    <OR <==? <SET PT <TYPEPRIM .TY>> FIX>
+					<==? .PT LIST>>>)
+			      (ELSE <SET TY ANY>)>
+			<GEN .NN <GEN-TEMP .TY>>>
+		.K
+		.VARS>>
+     <MAPF <>
+	   <FUNCTION (SYP:<LIST <OR ATOM SYMTAB>> TMP:TEMP
+		      "AUX" (SY:<OR ATOM SYMTAB> <1 .SYP>) (LCL <>)) 
+		   <COND (<AND <TYPE? .SY SYMTAB>
+			       <N==? <CODE-SYM .SY> -1>
+			       <SET LCL T>
+			       <NOT <SPEC-SYM .SY>>>
+			  <IEMIT `SET <TEM-NAME-SYM .SY> .TMP>
+			  <FREE-TEMP .TMP>)
+			 (ELSE
+			  <COND (<TYPE? .SY SYMTAB> <SET SY <NAME-SYM .SY>>)>
+			  <SET-VALUE .SY .TMP <NOT .LCL>>
+			  <FREE-TEMP .TMP>)>>
+	   .VARS
+	   .TL>)
+    (ELSE
+     <PROG (NL-LATER:LIST SL-LATER:LIST ANY-DONE (MUCH-LATER:LIST ())
+	    TTMP:TEMP)
+       <SET NL-LATER <SET SL-LATER ()>>
+       <SET ANY-DONE <>>
+       <MAPR <>
+	<FUNCTION (SL NL
+		   "AUX" (SYP:<LIST <OR ATOM SYMTAB TEMP>> <1 .SL>) (LCL <>) TY
+			 (N:NODE <1 .NL>) (SY:<OR ATOM SYMTAB TEMP> <1 .SYP>) TMP)
+		<COND (<OR <TYPE? .SY TEMP>
+			   <AND <NOT <REF? .SY <REST .NL>>>
+				<NOT <REF? .SY .NL-LATER>>>>
+		       <SET ANY-DONE T>
+		       <COND (<OR <AND <TYPE? .SY SYMTAB>
+				       <N==? <CODE-SYM .SY> -1>
+				       <SET LCL T>
+				       <NOT <SPEC-SYM .SY>>
+				       <SET TMP <TEMP-NAME-SYM .SY>>>
+				  <AND <TYPE? .SY TEMP> <SET TMP .SY>>>
+			      <GEN .N .TMP>)
+			     (ELSE
+			      <COND (<TYPE? .SY SYMTAB>
+				     <SET SY <NAME-SYM .SY>>)>
+			      <SET-VALUE .SY <GEN .N DONT-CARE> <NOT .LCL>>)>)
+		      (ELSE
+		       <SET SL-LATER (.SYP !.SL-LATER)>
+		       <SET NL-LATER (.N !.NL-LATER)>)>>
+	.VARS
+	.K>
+       <COND (<AND .ANY-DONE <NOT <EMPTY? .SL-LATER>>>
+	      <SET VARS .SL-LATER>
+	      <SET K .NL-LATER>
+	      <AGAIN>)
+	     (<NOT <EMPTY? .SL-LATER>>
+	      <SET MUCH-LATER
+		   ((<1 .SL-LATER> <SET TTMP <GEN-TEMP <>>>) !.MUCH-LATER)>
+	      <SET VARS ((.TTMP) !<REST .SL-LATER>)>
+	      <SET K .NL-LATER>
+	      <AGAIN>)>
+       <MAPF <>
+	     <FUNCTION (L
+			"AUX" (SY:<OR ATOM SYMTAB> <1 <1 .L>>) (LCL <>)
+			      (TMP:TEMP <2 .L>))
+		     <COND (<AND <TYPE? .SY SYMTAB>
+				 <N==? <CODE-SYM .SY> -1>
+				 <SET LCL T>
+				 <NOT <SPEC-SYM .SY>>>
+			    <IEMIT `SET <TEMP-NAME-SYM .SY> .TMP>
+			    <FREE-TEMP .TMP>)
+			   (ELSE
+			    <COND (<TYPE? .SY SYMTAB> <SET SY <NAME-SYM .SY>>)>
+			    <SET-VALUE .SY .TMP <NOT .LCL>>
+			    <FREE-TEMP .TMP>)>>
+	     .MUCH-LATER>>)>
+   <COND (<N==? .W FLUSHED>
+	  <SET LCL <>>
+	  <COND (<AND <TYPE? .VL SYMTAB>
+		      <N==? <CODE-SYM .VL> -1>
+		      <SET LCL T>
+		      <NOT <SPEC-SYM .VL>>>
+		 <TEMP-REFS .VL <+ <TEMP-REFS .VL> 1>>
+		 <MOVE-ARG .VL .W>)
+		(ELSE
+		 <COND (<TYPE? .VL SYMTAB> <SET VL <NAME-SYM .VL>>)>
+		 <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP <>>>)>
+		 <GET-VALUE-X .VL .W <NOT .LCL>>)>)
+	 (ELSE .W)>>
+
+<DEFINE REF? (SY:<OR ATOM SYMTAB> L:<LIST [REST NODE]>)
+	<MAPF <>
+	      <FUNCTION (N:NODE "AUX" (NT:FIX <NODE-TYPE .N>))
+		    <PROG ()
+			  <COND (<OR <==? .NT ,LVAL-CODE>
+				     <==? .NT ,ASSIGNED?-CODE>
+				     <==? .NT ,SET-CODE>>
+				 <COND (<==? <NODE-NAME .N> .SY> <MAPLEAVE>)>)
+				(<OR <==? .NT ,FLVAL-CODE> <==? .NT ,FSET-CODE>>
+				 <COND (<OR <==? <NODE-NAME .N> .SY>
+					    <COND (<==? <NODE-TYPE
+							 <SET NN <1 <KIDS .N>>>>
+							,QUOTE-CODE>
+						   <==? <NODE-NAME .NN> .SY>)
+						  (ELSE
+						   <OR <TYPE? .SY ATOM>
+						       <==? <CODE-SYM .SY> -1>
+						       <SPEC-SYM .SY>>)>>
+					<MAPLEAVE T>)>)
+				(<AND <G? <LENGTH .N> <INDEX ,SIDE-EFFECTS>>
+				      <MEMQ ALL <SIDE-EFFECTS .N>>
+				      <OR <TYPE? .SY ATOM>
+					  <SPEC-SYM .SY>
+					  <==? <CODE-SYM .SY> -1>>>
+				 <MAPLEAVE T>)
+				(ELSE
+				 <COND (<REF? .SY <KIDS .N>> <MAPLEAVE T>)>
+				 <COND (<==? .NT ,BRANCH-CODE>
+					<SET NT <NODE-TYPE <SET N <PREDIC .N>>>>
+					<AGAIN>)>)>>>
+	      .L>>
+				 
+<DEFINE GEN-DISPATCH (N W) 
+	<CASE ,==?
+	      <NODE-TYPE .N>
+	      (,FORM-CODE <FORM-GEN .N .W>)
+	      (,PROG-CODE <PROG-REP-GEN .N .W>)
+	      (,SUBR-CODE <SUBR-GEN .N .W>)
+	      (,COND-CODE <COND-GEN .N .W>)
+	      (,LVAL-CODE <LVAL-GEN .N .W>)
+	      (,SET-CODE <SET-GEN .N .W>)
+	      (,OR-CODE <OR-GEN .N .W>)
+	      (,AND-CODE <AND-GEN .N .W>)
+	      (,RETURN-CODE <RETURN-GEN .N .W>)
+	      (,COPY-CODE <COPY-GEN .N .W>)
+	      (,AGAIN-CODE <AGAIN-GEN .N .W>)
+	      (,ARITH-CODE <ARITH-GEN .N .W>)
+	      (,RSUBR-CODE <SUBR-GEN .N .W>)
+	      (,0-TST-CODE <0-TEST .N .W>)
+	      (,NOT-CODE <NOT-GEN .N .W>)
+	      (,1?-CODE <1?-GEN .N .W>)
+	      (,TEST-CODE <TEST-GEN .N .W>)
+	      (,EQ-CODE <==-GEN .N .W>)
+	      (,TY?-CODE <TYPE?-GEN .N .W>)
+	      (,LNTH-CODE <LNTH-GEN .N .W>)
+	      (,MT-CODE <MT-GEN .N .W>)
+	      (,REST-CODE <REST-GEN .N .W>)
+	      (,NTH-CODE <NTH-GEN .N .W>)
+	      (,PUT-CODE <PUT-GEN .N .W>)
+	      (,PUTR-CODE <PUTREST-GEN .N .W>)
+	      (,FLVAL-CODE <FLVAL-GEN .N .W>)
+	      (,FSET-CODE <FSET-GEN .N .W>)
+	      (,FGVAL-CODE <FGVAL-GEN .N .W>)
+	      (,FSETG-CODE <FSETG-GEN .N .W>)
+	      (,MIN-MAX-CODE <MIN-MAX .N .W>)
+	      (,CHTYPE-CODE <CHTYPE-GEN .N .W>)
+	      (,FIX-CODE <FIX-GEN .N .W>)
+	      (,FLOAT-CODE <FLOAT-GEN .N .W>)
+	      (,ABS-CODE <ABS-GEN .N .W>)
+	      (,MOD-CODE <MOD-GEN .N .W>)
+	      (,ID-CODE <ID-GEN .N .W>)
+	      (,ASSIGNED?-CODE <ASSIGNED?-GEN .N .W>)
+	      (,BITL-CODE <BITLOG-GEN .N .W>)
+	      (,ISUBR-CODE <SUBR-GEN .N .W>)
+	      (,EOF-CODE <ID-GEN .N .W>)
+	      (,READ-EOF2-CODE <READ2-GEN .N .W>)
+	      (,READ-EOF-CODE <SUBR-GEN .N .W>)
+	      (,GET2-CODE <GET2-GEN .N .W>)
+	      (,GET-CODE <GET-GEN .N .W>)
+	      (,IPUT-CODE <SUBR-GEN .N .W>)
+	      (,MAP-CODE <MAPFR-GEN .N .W>)
+	      (,MARGS-CODE <MPARGS-GEN .N .W>)
+	      (,MAPLEAVE-CODE <MAPLEAVE-GEN .N .W>)
+	      (,MAPRET-STOP-CODE <MAPRET-STOP-GEN .N .W>)
+	      (,UNWIND-CODE <UNWIND-GEN .N .W>)
+	      (,GVAL-CODE <GVAL-GEN .N .W>)
+	      (,SETG-CODE <SETG-GEN .N .W>)
+	      (,MEMQ-CODE <MEMQ-GEN .N .W>)
+	      (,LENGTH?-CODE <LENGTH?-GEN .N .W>)
+	      (,FORM-F-CODE <FORM-F-GEN .N .W>)
+	      (,ALL-REST-CODE <ALL-REST-GEN .N .W>)
+	      (,COPY-LIST-CODE <LIST-BUILD .N .W>)
+	      (,PUT-SAME-CODE <PUT-GEN .N .W>)
+	      (,BACK-CODE <BACK-GEN .N .W>)
+	      (,TOP-CODE <TOP-GEN .N .W>)
+	      (,ROT-CODE <ROT-GEN .N .W>)
+	      (,LSH-CODE <LSH-GEN .N .W>)
+	      (,BIT-TEST-CODE <BIT-TEST-GEN .N .W>)
+	      (,CALL-CODE <CALL-GEN .N .W>)
+	      (,MONAD-CODE <MONAD?-GEN .N .W>)
+	      (,GASSIGNED?-CODE <GASSIGNED?-GEN .N .W>)
+	      (,APPLY-CODE <APPLY-GEN .N .W>)
+	      (,ADECL-CODE <ADECL-GEN .N .W>)
+	      (,MULTI-RETURN-CODE <MULTI-RETURN-GEN .N .W>)
+	      (,VALID-CODE <VALID-TYPE?-GEN .N .W>)
+	      (,TYPE-C-CODE <TYPE-C-GEN .N .W>)
+	      (,=?-STRING-CODE <=?-STRING-GEN .N .W>)
+	      (,CASE-CODE <CASE-GEN .N .W>)
+	      (,FGETBITS-CODE <FGETBITS-GEN .N .W>)
+	      (,FPUTBITS-CODE <FPUTBITS-GEN .N .W>)
+	      (,ISTRUC-CODE <ISTRUC-GEN .N .W>)
+	      (,ISTRUC2-CODE <ISTRUC-GEN .N .W>)
+	      (,STACK-CODE <STACK-GEN .N .W>)
+	      (,CHANNEL-OP-CODE <CHANNEL-OP-GEN .N .W>)
+	      (,ATOM-PART-CODE <ATOM-PART-GEN .N .W>)
+	      (,OFFSET-PART-CODE <OFFSET-PART-GEN .N .W>)
+	      (,PUT-GET-DECL-CODE <PUT-GET-DECL-GEN .N .W>)
+	      (,SUBSTRUC-CODE <SUBSTRUC-GEN .N .W>)
+	      (,MULTI-SET-CODE <MULTI-SET-GEN .N .W>)
+	      DEFAULT
+	      (<DEFAULT-GEN .N .W>)>>
\ No newline at end of file