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

diff --git a/mim/development/mim/mimc/mapana.mud b/mim/development/mim/mimc/mapana.mud
new file mode 100644
index 0000000..40011b0
--- /dev/null
+++ b/mim/development/mim/mimc/mapana.mud
@@ -0,0 +1,478 @@
+
+<PACKAGE "MAPANA">
+
+<ENTRY MAPPER-AN
+       MAPRET-STOP-ANA
+       MAPLEAVE-ANA
+       MENTROPY
+       MAUX
+       MAUX1
+       MTUPLE
+       MBAD
+       MOPT
+       MOPT2
+       MNORM
+       MARGS-ANA>
+
+<USE "COMPDEC" "SYMANA" "CHKDCL" "CARANA" "ADVMESS">
+
+<SETG SPECIAL-MAPF-R-SUBRS [,LIST ,+ ,* ,MAX ,MIN]>
+
+<DEFINE MAPPER-AN (MNOD MRTYP
+		   "AUX" (K <KIDS .MNOD>) TT ITRNOD FAP T TF (MPSTRS ())
+			 (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (TUPCNT 1)
+			 (RETYPS NO-RETURN) TEM ASSU L-D L-V D-V VALSPCD SBR
+			 (SBRL <>) (SEGFX ()) FINTYPE STATE (FRET T) (FSTOP T)
+			 (OV .VARTBL) NSTR (CHF <>))
+   #DECL ((FAP ITRNOD) NODE (K) <LIST [REST NODE]> (TT NSTR) FIX
+	  (MPSTRS L-V D-V) <SPECIAL LIST> (R?) <SPECIAL <OR ATOM FALSE>>
+	  (STATE TUPCNT) <SPECIAL FIX> (SEGFX) <SPECIAL <LIST [REST NODE]>>
+	  (MNOD) <SPECIAL NODE> (OV) <SPECIAL SYMTAB>
+	  (FRET FSTOP MRTYP RETYPS) <SPECIAL ANY> (VALSPCD) <SPECIAL LIST>
+	  (ASSU L-D) LIST (SBRL) <OR VECTOR FALSE>)
+   <SET TF <EANA <SET FAP <1 .K>> ANY <NODE-NAME .MNOD>>>
+   <COND (<AND <SET SBR <SUBAP? .FAP>>
+	       <SET SBRL <MEMQ ,.SBR ,SPECIAL-MAPF-R-SUBRS>>>
+	  <PUT .FAP ,NODE-TYPE ,MFIRST-CODE>
+	  <COND (<N==? ,.SBR ,LIST>
+		 <SET FINTYPE '<OR FIX FLOAT>>
+		 <SET STATE 1>)
+		(ELSE <SET FINTYPE LIST>)>
+	  <PUT .FAP ,NODE-SUBR <LENGTH .SBRL>>)>
+   <SET ITRNOD <2 .K>>
+   <MAPF <>
+	 <FUNCTION (N) 
+		 #DECL ((N) NODE)
+		 <COND (<L? <MINL <RESULT-TYPE .N>> 1> <SET CHF T>)>>
+	 <REST .K 2>>
+   <COND
+    (<==? <SET TT <NODE-TYPE .ITRNOD>> ,MFCN-CODE>
+     <PUT .ITRNOD ,SIDE-EFFECTS <>>
+     <MAPF <>
+      <FUNCTION (N "AUX" RT R) 
+	      #DECL ((N) NODE)
+	      <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+			 <==? <NODE-TYPE .N> ,SEG-CODE>>
+		     <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
+		     <SET RT <GET-ELE-TYPE .RT ALL>>
+		     <COND (<NOT <TYPE-OK? .RT STRUCTURED>>
+			    <COMPILE-ERROR "MAPF/R on non structured object(s)"
+					   .MNOD>)>)
+		    (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
+	      <COND (<AND .VERBOSE
+			  <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
+		     <ADDVMESS
+		      .MNOD
+		      ("Non-specific structure for MAPF/R:  "
+		       .N
+		       " type is:  "
+		       .RT)>)>>
+      <SET K <REST .K 2>>>
+     <SET L-D <SAVE-L-D-STATE .VARTBL>>
+     <PROG ((HTMPS 0) (TMPS 0) (VARTBL <SYMTAB .ITRNOD>) (KK .K) (LL .LIFE)
+	    (OVV .VERBOSE))
+	   #DECL ((HTMPS TMPS) <SPECIAL FIX> (VARTBL) <SPECIAL SYMTAB>
+		  (KK) <LIST [REST NODE]>)
+	   <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
+	   <SET LIFE .LL>
+	   <SET L-V ()>
+	   <SET FSTOP T>
+	   <RESET-VARS .VARTBL .OV>
+	   <MUNG-L-D-STATE .VARTBL>
+	   <SET K .KK>
+	   <SET RETYPS NO-RETURN>
+	   <SET ASSU <BUILD-TYPE-LIST .OV>>
+	   <SET VALSPCD <BUILD-TYPE-LIST .OV>>
+	   <REPEAT ((BNDS <BINDING-STRUCTURE .ITRNOD>) (TUPF <>) (LAST-SEG <>)
+		    (SKIPF <>))
+		   <COND (<EMPTY? .BNDS>
+			  <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
+				 <COMPILE-ERROR 
+"MAPF/R function takes too few args "
+						.ITRNOD>)>
+			  <RETURN>)>
+		   <COND (<==? <CODE-SYM <1 .BNDS>> ,ARGL-TUPLE> <SET TUPF T>)>
+		   <COND (<AND <NOT <EMPTY? .K>>
+			       <OR <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
+				   <==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>>>
+			  <COND (<EMPTY? <REST .K>> <SET LAST-SEG 1>)>
+			  <COND (<NOT <OR .LAST-SEG .TUPF>> <SET SKIPF T>)>)>
+		   <COND (<OR <MANAL-DISP <1 .BNDS>
+					  <COND (<NOT <EMPTY? .K>> <1 .K>)>
+					  .SKIPF
+					  .LAST-SEG>
+			      .TUPF>
+			  <SET BNDS <REST .BNDS>>)>
+		   <COND (<AND <NOT <EMPTY? .BNDS>>
+			       <SPEC-SYM <1 .BNDS>>>
+			  <PUT .ITRNOD ,SPCS-X T>)>
+		   <COND (.LAST-SEG <SET LAST-SEG <+ .LAST-SEG 1>>)>
+		   <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
+			  <SET K <REST .K>>)>>
+	   <PUT .ITRNOD ,VSPCD (())>
+	   <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OVV .VERBOSE))
+		 #DECL ((STMPS SHTMPS) FIX)
+		 <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
+		 <SET LIFE .LL>
+		 <SET FRET T>
+		 <SET TMPS .STMPS>
+		 <SET HTMPS .SHTMPS>
+		 <PUT .ITRNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
+		 <PUT .ITRNOD ,ACCUM-TYPE NO-RETURN>
+		 <SET TEM <SEQ-AN <KIDS .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>
+		 <OR <NOT <AGND .ITRNOD>>
+		     <ASSUM-OK? <ASSUM .ITRNOD> <AGND .ITRNOD>>
+		     <AGAIN>>>
+	   <COND (<N==? .TEM NO-RETURN>
+		  <COND (<NOT .FRET>
+			 <SET L-V <MSAVE-L-D-STATE .L-V .OV>>
+			 <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .ITRNOD>>>)
+			(ELSE <SET L-V <SAVE-L-D-STATE .OV>>)>)
+		 (<N==? <ACCUM-TYPE .ITRNOD> NO-RETURN>
+		  <ASSERT-TYPES <VSPCD .ITRNOD>>)>
+	   <SET VALSPCD <ORUPC .OV .VALSPCD>>
+	   <OR <ASSUM-OK? .ASSU <BUILD-TYPE-LIST .VARTBL>> <AGAIN>>
+	   <PUT .ITRNOD ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .ITRNOD>>>
+	   <PUT .ITRNOD
+		,RESULT-TYPE
+		<TYPE-OK? <ACCUM-TYPE .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>>
+     <ASSERT-TYPES .VALSPCD>
+     <COND (<ASSIGNED? STATE>
+	    <FIX-STATE <ACCUM-TYPE .ITRNOD> .ITRNOD>
+	    <COND (<G? .STATE 4>
+		   <SET SBRL <>>
+		   <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
+		   <SET FINTYPE '<OR FIX FLOAT>>)
+		  (ELSE
+		   <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
+     <SAVE-SURVIVORS .L-D .LIFE T>
+     <SAVE-SURVIVORS .L-V .LIFE>
+     <SET D-V
+	  <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+		(ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+     <FREST-L-D-STATE .D-V>
+     <SET LIFE <KILL-REM .LIFE .OV>>
+     <COND (.SBRL <MUNG-SEGS .SEGFX>)>
+     <COND (<SIDE-EFFECTS .ITRNOD>
+	    <UPDATE-SIDE-EFFECTS .ITRNOD .MNOD>)>
+     <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
+		 <==? <NODE-NAME .FAP> #FALSE ()>>
+	    <TYPE-OK? <COND (.CHF <TYPE-MERGE FALSE .TEM .RETYPS>)
+			    (ELSE <TYPE-OK? <TYPE-MERGE .TEM .RETYPS> .MRTYP>)>
+		      .MRTYP>)
+	   (<ASSIGNED? FINTYPE>
+	    <COND (<==? .FINTYPE LIST>
+		   <TYPE-OK? <TYPE-MERGE <FORM LIST
+					       [REST <RESULT-TYPE .ITRNOD>]>
+					 .RETYPS>
+			     .MRTYP>)
+		  (ELSE <TYPE-OK? <TYPE-MERGE .FINTYPE .RETYPS> .MRTYP>)>)
+	   (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
+		 <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
+	    <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
+	    <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
+	   (ELSE <TYPE-OK? <TYPE-MERGE <APPLTYP .FAP> .RETYPS> .MRTYP>)>)
+    (ELSE
+     <COND (<N==? .TT ,MPSBR-CODE>
+	    <EANA .ITRNOD APPLICABLE <NODE-NAME .MNOD>>)>
+     <MAPF <>
+      <FUNCTION (N "AUX" RT R) 
+	      #DECL ((N) NODE)
+	      <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+			 <==? <NODE-TYPE .N> ,SEG-CODE>>
+		     <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
+		     <SET RT <GET-ELE-TYPE .RT ALL>>)
+		    (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
+	      <COND (<AND .VERBOSE
+			  <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
+		     <ADDVMESS
+		      .MNOD
+		      ("Non-specific structure for MAPF/R:  "
+		       .N
+		       " type is:  "
+		       .RT)>)>>
+      <SET MPSTRS <REST .K 2>>>
+     <COND (<==? .TT ,MPSBR-CODE>
+	    <SET TEM <EANA <1 <KIDS .ITRNOD>> ANY <NODE-NAME .MNOD>>>
+	    <COND (.CHF <SET TEM <TYPE-MERGE .TEM FALSE>>)>)
+	   (ELSE <SET TEM ANY>)>
+     <COND (<ASSIGNED? STATE>
+	    <FIX-STATE .TEM <1 <KIDS .ITRNOD>>>
+	    <COND (<G? .STATE 4>
+		   <SET SBRL <>>
+		   <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
+		   <SET FINTYPE '<OR FIX FLOAT>>)
+		  (ELSE
+		   <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
+     <COND (.SBRL <MUNG-SEGS .SEGFX>)>
+     <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
+		 <==? <NODE-NAME .FAP> #FALSE ()>>
+	    <TYPE-OK? .TEM .MRTYP>)
+	   (<ASSIGNED? FINTYPE>
+	    <COND (<==? .FINTYPE LIST>
+		   <TYPE-OK? <FORM LIST [REST .TEM]> .MRTYP>)
+		  (ELSE <TYPE-OK? .FINTYPE .MRTYP>)>)
+	   (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
+		 <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
+	    <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
+	    <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
+	   (ELSE <TYPE-OK? <APPLTYP .FAP> .MRTYP>)>)>>
+
+\ 
+
+<DEFINE FIX-STATE (TEM N "AUX" TT (SG <MEMQ <NODE-TYPE .N> ,SEG-CODES>)) 
+	#DECL ((STATE TT) FIX (N) NODE)
+	<SET TT
+	     <COND (<==? .TEM FIX> 1)
+		   (<==? .TEM FLOAT> 2)
+		   (<NOT <TYPE-OK? .TEM FLOAT>>
+		    <PUT .N
+			 ,RESULT-TYPE
+			 <COND (.SG
+				<TYPE-MERGE '<STRUCTURED [REST FIX]>
+					    <RESULT-TYPE .N>>)
+			       (ELSE FIX)>>
+		    1)
+		   (<NOT <TYPE-OK? .TEM FIX>>
+		    <PUT .N
+			 ,RESULT-TYPE
+			 <COND (.SG
+				<TYPE-MERGE '<STRUCTURED [REST FLOAT]>
+					    <RESULT-TYPE .N>>)
+			       (ELSE FLOAT)>>
+		    2)
+		   (ELSE 3)>>
+	<SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
+
+<SETG SEG-CODES [,SEG-CODE ,SEGMENT-CODE]>
+
+<DEFINE MUNG-SEGS (SEGS) 
+	#DECL ((SEGS) <LIST [REST NODE]>)
+	<MAPF <>
+	      <FUNCTION (N) #DECL ((N) NODE) <PUT .N ,NODE-TYPE ,SEG-CODE>>
+	      .SEGS>>
+
+<DEFINE MARGS-ANA (N R "AUX" (MK .MPSTRS) (NN <NODE-NAME .N>)) 
+	#DECL ((N) NODE (NN) FIX (MK) <LIST [REST NODE]>)
+	<SET R
+	     <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE <NTH .MK .NN>> ALL .R?> .R>>
+	<COND (.R? <TYPE-OK? .R '<STRUCTURED ANY>>) (ELSE .R)>>
+
+<DEFINE MAUX (SYM STRUC SKIPF LAST-SEG) 
+	#DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
+	<COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
+	       <COMPILE-ERROR "MAPF/R function takes too many args "
+			      <2 <KIDS .MNOD>>>)
+	      (ELSE <NORM-BAN .SYM>)>
+	T>
+
+<DEFINE MAUX1 (SYM STRUC SKIPF LAST-SEG) 
+	#DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
+	<COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
+	       <COMPILE-ERROR "MAPF/R function takes too many args "
+			      <2 <KIDS .MNOD>>>)>
+	<PUT .SYM
+	     ,COMPOSIT-TYPE
+	     <COND (.ANALY-OK NO-RETURN) (ELSE <DECL-SYM .SYM>)>>
+	<PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN) (ELSE ANY)>>
+	T>
+
+<DEFINE MNORM (SYM STRUC SKIPF LAST-SEG
+	       "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD N TYP)
+	#DECL ((SYM) SYMTAB (STRUC) <OR NODE FALSE> (VARTBL) <SPECIAL SYMTAB>
+	       (MNOD N) NODE)
+	<COND (<AND .STRUC <NOT .SKIPF>>
+	       <COND (.LAST-SEG
+		      <SET TYP
+			   <GET-ELE-TYPE
+			    <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>
+			    .LAST-SEG>>)
+		     (ELSE <SET TYP <EANA .STRUC ANY MAPF/R>>)>
+	       <COND (<NOT <SET TEM
+				<TYPE-OK? <GET-ELE-TYPE .TYP ALL .R?>
+					  <DECL-SYM .SYM>>>>
+		      <COMPILE-ERROR "MAPF/R structure violates arg DECL "
+				     <NAME-SYM .SYM>
+				     " "
+				     <DECL-SYM .SYM>
+				     .STRUC>)>
+	       <COND (.R? <SET TEM <TYPE-AND .TEM '<STRUCTURED ANY>>>)>
+	       <COND (<N=? .TEM <DECL-SYM .SYM>>
+		      <PUT .SYM ,CURRENT-TYPE .TEM>)>
+	       <PUT .SYM ,COMPOSIT-TYPE .TEM>)
+	      (<NOT .SKIPF>
+	       <COMPILE-ERROR "Too fewa argumens MAPF/R function" .MNOD>)>
+	T>
+
+<DEFINE MOPT (SYM STRUC SKIPF LAST-SEG "AUX" (VARTBL <NEXT-SYM .SYM>)) 
+	#DECL ((SYM) SYMTAB (VARTBL) <SPECIAL SYMTAB> (STRUC) <OR FALSE NODE>)
+	<COND (.STRUC
+	       <PUT .SYM ,INIT-SYM <>>
+	       <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
+	<COND (<OR <NOT .STRUC> .SKIPF .LAST-SEG> <NORM-BAN .SYM>)>
+	T>
+
+<DEFINE MBAD (SYM STRUC SKIPF LAST-SEG) 
+	<COMPILE-ERROR "Unrecognized arg decl in MAPF/R function "
+		       <NAME-SYM .SYM>>>
+
+<DEFINE MOPT2 (SYM STRUC SKIPF LAST-SEG) 
+	<COND (.STRUC <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
+	T>
+
+\ 
+
+<DEFINE MTUPLE (SYM STRUC SKIPF LAST-SEG
+		"AUX" (VARTBL <NEXT-SYM .SYM>) TYP
+		      (ATYP
+		       <GET-ELE-TYPE <DECL-SYM .SYM>
+				     <COND (.LAST-SEG ALL)
+					   (ELSE <SET TUPCNT <+ .TUPCNT 1>>)>>)
+		      TEM)
+   #DECL ((VARTBL) <SPECIAL ANY> (TUPCNT) FIX)
+   <COND
+    (<AND .STRUC <NOT .SKIPF>>
+     <COND (.R?
+	    <COND (<NOT <COND (.LAST-SEG
+			       <SET TEM
+				    <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
+			       <==? <STRUCTYP <GET-ELE-TYPE .TEM ALL>>
+				    <STRUCTYP .ATYP>>)
+			      (ELSE
+			       <SET TEM <EANA .STRUC STRUCTURED MAPF/R>>
+			       <==? <STRUCTYP .TEM> <STRUCTYP .ATYP>>)>>
+		   <COMPILE-ERROR "Bad argument to MAPF/R function "
+				  <NAME-SYM .SYM>
+				  .MNOD>)>)
+	   (.LAST-SEG
+	    <SET TEM <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
+	    <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <GET-ELE-TYPE .TEM ALL>
+						ALL>
+				  .ATYP>>
+		   <COMPILE-ERROR "Bad argument to MAPF/R function "
+				  <NAME-SYM .SYM>
+				  .MNOD>)>)
+	   (<AND .STRUC .SKIPF> <ANA .STRUC ANY>)
+	   (<NOT .SKIPF>
+	    <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <EANA .STRUC STRUCTURED MAPF/R>
+						ALL>
+				  .ATYP>>
+		   <COMPILE-ERROR "Bad argument to MAPF/R function "
+				  <NAME-SYM .SYM>
+				  .MNOD>)>)>
+     <>)
+    (ELSE T)>>
+
+<DEFINE MENTROPY (N R "OPT" X Y) T>
+
+<DEFINE MANAL-DISP (SYM NOD SKIPF LAST-SEG "AUX" (COD <CODE-SYM .SYM>)) 
+	<CASE ,==?
+	      .COD
+	      (,ARGL-ACT <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-IAUX <MAUX .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-AUX <MAUX1 .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-TUPLE <MTUPLE .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-ARGS <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-QIOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-IOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-QOPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-OPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-CALL <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-BIND <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-QUOTE <MNORM .SYM .NOD .SKIPF .LAST-SEG>)
+	      (,ARGL-ARG <MNORM .SYM .NOD .SKIPF .LAST-SEG>)>>
+
+"Additional SUBR analyzers associated with MAP hackers."
+
+<DEFINE MAPLEAVE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) TEM) 
+	#DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
+	<SET RET-OR-AGAIN T>
+	<COND (<ASSIGNED? MNOD>
+	       <ARGCHK .LN '(0 1) MAPLEAVE .N>
+	       <COND (<0? .LN>
+		      <PUT .N
+			   ,KIDS
+			   <SET K (<NODE1 ,QUOTE-CODE .N ATOM T ()>)>>)>
+	       <SET TEM <EANA <1 .K> .MRTYP MAPLEAVE>>
+	       <SET VALSPCD <ORUPC .OV .VALSPCD>>
+	       <SET D-V
+		    <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+			  (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+	       <SET FSTOP <>>
+	       <SET RETYPS <TYPE-MERGE .RETYPS .TEM>>
+	       <PUT .N ,NODE-TYPE ,MAPLEAVE-CODE>)
+	      (ELSE <SUBR-C-AN .N .R>)>
+	NO-RETURN>
+
+\ 
+
+<DEFINE MAPRET-STOP-ANA (NOD R "AUX" (ARGS 0) (TYP NO-RETURN) TYP1 ITRNOD) 
+   #DECL ((MNOD NOD ITRNOD) NODE (ARGS) FIX)
+   <SET RET-OR-AGAIN T>
+   <PROG ()
+     <OR <ASSIGNED? MNOD> <RETURN <SUBR-C-AN .NOD .R>>>
+     <PUT <SET ITRNOD <2 <KIDS .MNOD>>> ,ACTIVATED T>
+     					   ;"So frame will be built"
+     <COND (<NOT <NODE-NAME <1 <KIDS .MNOD>>>>
+	    <COMPILE-ERROR "MAPRET/STOP with no final function." .MNOD>)>
+     <MAPF <>
+      <FUNCTION (N) 
+	      #DECL ((N) NODE)
+	      <COND
+	       (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
+		    <==? <NODE-TYPE .N> ,SEG-CODE>>
+		<SET TYP1
+		     <EANA <1 <KIDS .N>>
+			   <COND (<ASSIGNED? STATE>
+				  '<STRUCTURED [REST <OR FIX FLOAT>]>)
+				 (ELSE STRUCTURED)>
+			   SEGMENT>>
+		<SET TYP <TYPE-MERGE .TYP <GET-ELE-TYPE .TYP1 ALL>>>
+		<PUT .NOD ,SEGS T>)
+	       (ELSE
+		<SET ARGS <+ .ARGS 1>>
+		<SET TYP
+		     <TYPE-MERGE
+		      .TYP
+		      <EANA .N
+			    <COND (<ASSIGNED? STATE> '<OR FIX FLOAT>)
+				  (ELSE ANY)>
+			    <NODE-NAME .NOD>>>>)>>
+      <KIDS .NOD>>
+     <AND <ASSIGNED? STATE> <N==? .TYP NO-RETURN> <FIX-STATE .TYP .NOD>>
+     <COND (<==? <NODE-SUBR .NOD> ,MAPRET>
+	    <SET L-V
+		 <COND (.FRET <SAVE-L-D-STATE .VARTBL>)
+		       (ELSE <MSAVE-L-D-STATE .L-V .VARTBL>)>>
+	    <PUT .ITRNOD
+		 ,VSPCD
+		 <COND (.FRET <BUILD-TYPE-LIST .VARTBL>)
+		       (ELSE <ORUPC .VARTBL <VSPCD .ITRNOD>>)>>
+	    <SET FRET <>>)
+	   (ELSE
+	    <SET D-V
+		 <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
+		       (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
+	    <SET VALSPCD <ORUPC .OV .VALSPCD>>
+	    <SET FSTOP <>>)>
+     <PUT <2 <KIDS .MNOD>>
+	  ,ACCUM-TYPE
+	  <TYPE-MERGE <ACCUM-TYPE <2 <KIDS .MNOD>>> .TYP>>
+     <PUT .NOD ,NODE-TYPE ,MAPRET-STOP-CODE>>
+   NO-RETURN>
+
+<COND (<GASSIGNED? MAPLEAVE-ANA>
+       <PUTPROP ,MAPLEAVE ANALYSIS ,MAPLEAVE-ANA>
+       <PUTPROP ,MAPRET ANALYSIS ,MAPRET-STOP-ANA>
+       <PUTPROP ,MAPSTOP ANALYSIS ,MAPRET-STOP-ANA>)>
+
+<DEFINE SUBAP? (NOD "AUX" TT (COD 0)) 
+	#DECL ((COD) FIX (NOD) NODE)
+	<AND <OR <==? <SET COD <NODE-TYPE .NOD>> ,FGVAL-CODE>
+		 <==? .COD ,GVAL-CODE>
+		 <==? .COD ,MFIRST-CODE>>
+	     <==? <NODE-TYPE <SET NOD <1 <KIDS .NOD>>>> ,QUOTE-CODE>
+	     <GASSIGNED? <SET TT <NODE-NAME .NOD>>>
+	     .TT>>
+
+<ENDPACKAGE>