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

diff --git a/<mdl.comp>/strana.mud.362 b/<mdl.comp>/strana.mud.362
new file mode 100644
index 0000000..7bf5030
--- /dev/null
+++ b/<mdl.comp>/strana.mud.362
@@ -0,0 +1,537 @@
+<PACKAGE "STRANA">
+
+<ENTRY LENGTH-ANA EMPTY?-ANA LENGTH?-ANA NTH-ANA REST-ANA PUT-ANA PUTREST-ANA
+	 MEMQ-ANA NTH-REST-ANA>
+
+<USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
+
+"Structure hackers for the compiler (analyzers)"
+
+<DEFINE LNTH-MT-ANA (NOD RTYP COD
+		     "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM (WHO ())
+			   (WHON
+			    <AND <OR <AND <==? .COD ,LNTH-CODE>
+					  <ASSIGNED? GLN>
+					  <ANCEST .GLN <PARENT .NOD>>>
+				     <AND <==? .PRED <PARENT .NOD>>
+					  <==? .COD ,MT-CODE>>>
+				 .NOD>))
+	#DECL ((NOD) NODE (LN COD) FIX (K) <LIST [REST NODE]>
+	       (WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR NODE FALSE>>)
+	<COND (<SEGFLUSH .NOD .RTYP>)
+	      (ELSE
+	       <ARGCHK .LN 1 <NODE-NAME .NOD>>
+	       <SET TEM <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>
+	       <COND (<SET TEM <STRUCTYP .TEM>> <PUT .NOD ,NODE-TYPE .COD>)
+		     (ELSE
+		      <COND (.VERBOSE
+			     <ADDVMESS .NOD
+				       ("Not open compiled because type is:  "
+					<RESULT-TYPE <1 .K>>)>)>
+		      <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
+	<COND (<==? .COD ,MT-CODE>
+	       <MAPF <>
+		     <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>)) 
+			     #DECL ((L) <LIST <OR FALSE ATOM> SYMTAB>
+				    (SYM) SYMTAB)
+			     '<SET TRUTH
+				   <ADD-TYPE-LIST .SYM
+						  '<STRUCTURED [REST
+								<NOT ANY>]>
+						  .TRUTH
+						  .FLG
+						  <REST .L 2>>>
+			     <SET UNTRUTH
+				  <ADD-TYPE-LIST
+				   .SYM
+				   '<STRUCTURED ANY>
+				   .UNTRUTH
+				   .FLG
+				   <REST .L 2>>>
+			     T>
+		     .WHO>)
+	      (ELSE <SET GLE .WHO>)>
+	<TYPE-OK? <COND (<==? <NODE-SUBR .NOD> ,LENGTH> <FORM FIX (0 ,PLUSINF)>)
+			(ELSE '<OR FALSE ATOM>)>
+		  .RTYP>>
+
+<DEFINE ANCEST (N1 N2) 
+	#DECL ((N1 N2) NODE)
+	<REPEAT ()
+		<COND (<==? .N1 .N2> <RETURN>)>
+		<OR <==? <NODE-TYPE .N2> ,SET-CODE> <RETURN <>>>
+		<COND (<TYPE? <PARENT .N2> NODE> <SET N2 <PARENT .N2>>)
+		      (ELSE <RETURN <>>)>>>
+
+<DEFINE LENGTH-ANA (N R) <LNTH-MT-ANA .N .R ,LNTH-CODE>>
+
+<PUT ,LENGTH ANALYSIS ,LENGTH-ANA>
+
+<DEFINE EMPTY?-ANA (N R) <LNTH-MT-ANA .N .R ,MT-CODE>>
+
+<PUT ,EMPTY? ANALYSIS ,EMPTY?-ANA>
+
+<DEFINE LENGTH?-ANA (NOD RTYP
+		     "AUX" (K <KIDS .NOD>) TEM (WHO ())
+			   (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>))
+   #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON) <SPECIAL ANY>
+	  (WHO) <SPECIAL LIST>)
+   <COND
+    (<SEGFLUSH .NOD .RTYP>)
+    (ELSE
+     <ARGCHK <LENGTH .K> 2 LENGTH?>
+     <SET TEM <EANA <1 .K> STRUCTURED LENGTH?>>
+     <SET WHON <>>
+     <EANA <2 .K> FIX LENGTH?>
+     <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>	     ;"Constant 2d arg?"
+	    <MAPF <>
+		  <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>)) 
+			  #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
+			  <SET UNTRUTH
+			       <ADD-TYPE-LIST .SYM
+					      <FORM STRUCTURED
+						    [<NODE-NAME <2 .K>> ANY]>
+					      .TRUTH
+					      .FLG
+					      <REST .L 2>>>>
+		  .WHO>)>
+     <COND (<SET TEM <STRUCTYP .TEM>>
+	    <PUT .NOD ,NODE-TYPE ,LENGTH?-CODE>)
+	   (ELSE
+	    <COND (.VERBOSE
+		   <ADDVMESS .NOD
+			     ("Not open compiled because type is:  "
+			      <RESULT-TYPE <1 .K>>)>)>
+	    <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+     <TYPE-OK? <FORM OR <FORM FIX
+			  (0
+			  <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+				 <NODE-NAME .NOD>)
+				(ELSE ,PLUSINF)>)>
+		    FALSE>
+	       .RTYP>)>>
+
+<PUT ,LENGTH? ANALYSIS ,LENGTH?-ANA>
+
+<DEFINE NTH-REST-ANA (NOD RTYP COD
+		      "OPTIONAL" (TF <>)
+		      "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TS VAL TPS
+			    (RV <OR .TF <==? <NODE-NAME .NOD> INTH>>)
+			    (SVWHO ())
+			    (NM <COND (.RV NTH) (ELSE <NODE-NAME .NOD>)>) XX
+			    (OWHON <AND <==? .WHON <PARENT .NOD>> .NOD>) NUMB)
+   #DECL ((COD NUMB LN) FIX (NOD WHON PRED) NODE (K) <LIST [REST NODE]>
+	  (WHO SVWHO) LIST)
+   <SET VAL
+    <PROG ((WHO ()) (WHON <>))
+      #DECL ((WHON) <SPECIAL ANY> (WHO) <SPECIAL LIST>)
+      <COND
+       (<SEGFLUSH .NOD .RTYP>)
+       (ELSE
+	<COND (<1? .LN>
+	       <PUT .NOD
+		    ,KIDS
+		    <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
+	      (ELSE <ARGCHK .LN 2 <NODE-NAME .NOD>>)>
+	<COND (.RV
+	       <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>
+	       <SET WHON .NOD>
+	       <SET TS <EANA <1 .K> STRUCTURED .NM>>)
+	      (ELSE
+	       <SET WHON .NOD>
+	       <SET TS <EANA <1 .K> STRUCTURED .NM>>
+	       <SET WHON <>>
+	       <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>)>
+	<COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
+	       <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
+	       <PUT <1 .K> ,RESULT-TYPE .TS>)>
+	<SET TPS <STRUCTYP .TS>>
+	<COND (<AND .TPS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+	       <SET SVWHO .WHO>)>
+	<COND
+	 (<AND .TPS
+	       <OR <==? <ISTYPE? .TF> FIX>
+		   <AND <==? <ISTYPE? .TF> OFFSET>
+			<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
+	       <N==? <ISTYPE? .TS> TEMPLATE>
+	       <OR <NOT <==? .TPS TEMPLATE>>
+		   <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>>
+	  <PUT .NOD ,NODE-TYPE .COD>)
+	 (ELSE
+	  <AND <==? .COD ,NTH-CODE> <PUT .NOD ,NODE-NAME NTH>>
+	  <COND (.VERBOSE
+		 <ADDVMESS .NOD ("Not open compiled because type is:  " .TS)>)>
+	  <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
+	<TYPE-OK?
+	 <GET-ELE-TYPE
+	  .TS
+	  <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+		 <SET NUMB
+		      <COND (<==? <ISTYPE? .TF> OFFSET>
+			     <INDEX <NODE-NAME <2 .K>>>)
+			    (ELSE <NODE-NAME <2 .K>>)>>)
+		(ELSE ALL)>
+	  <==? <NODE-SUBR .NOD> ,REST>>
+	 .RTYP>)>>>
+   <MAPF <>
+	 <FUNCTION (L "AUX" (SYM <2 .L>) (FL <1 .L>) T1 T2) 
+		 #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
+		 <SET XX (.NM .NUMB !<REST .L 2>)>
+		 <SET-CURRENT-TYPE
+		  .SYM
+		  <TYPE-AND <GET-CURRENT-TYPE .SYM> <TYPE-NTH-REST .VAL .XX>>>
+		 <COND (.OWHON <SET WHO ((.FL .SYM !.XX) !.WHO)>)>
+		 <COND (<AND <==? .PRED <PARENT .NOD>>
+			     <SET T1 <TYPE-OK? .VAL FALSE>>
+			     <SET T2 <TYPE-OK? .VAL '<NOT FALSE>>>>
+			<SET TRUTH <ADD-TYPE-LIST .SYM .T2 .TRUTH .FL .XX>>
+			<SET UNTRUTH
+			     <ADD-TYPE-LIST .SYM .T1 .UNTRUTH .FL .XX>>)>>
+	 .SVWHO>
+   <COND (<AND <==? .TPS LIST>
+	       <OR <==? <NODE-TYPE <1 .K>> ,LVAL-CODE>
+		   <==? <NODE-TYPE <1 .K>> ,SET-CODE>>
+	       <LOOK-FOR .NOD <1 .K> <2 .K> <==? <NODE-SUBR .NOD> ,REST>>>
+	  <PUT .NOD ,NODE-TYPE ,ALL-REST-CODE>)
+	 (<AND <==? .TPS LIST>
+	       <==? .COD ,REST-CODE>
+	       <GASSIGNED? PUT-SAME-CODE>
+	       <==? <NODE-TYPE <1 .K>> ,PUTR-CODE>
+	       <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+	       <==? .NUMB 1>>
+	  <PUT .NOD ,NODE-TYPE ,PUTR-CODE>)>
+   .VAL>
+
+<DEFINE LOOK-FOR (MN N1 N RFLG "AUX" TT K (S ()) (SS (() () ()))) 
+	#DECL ((S) <LIST [REST NODE]> (N MN N1) NODE (TT) <OR FALSE NODE>
+	       (K) <LIST [REST NODE]>)
+	<REPEAT ()
+		<COND (<==? <NODE-TYPE .N1> ,LVAL-CODE>
+		       <SET S (.N1 !.S)>
+		       <RETURN>)
+		      (<==? <NODE-TYPE .N1> ,SET-CODE>
+		       <SET S (.N1 !.S)>
+		       <SET N1 <2 <KIDS .N1>>>)
+		      (ELSE <RETURN>)>>
+	<AND <OR <AND .RFLG
+		      <SET TT <SET-SEARCH .N ,ARITH-CODE .S .SS>>
+		      <==? <NODE-SUBR <SET N .TT>> ,->
+		      <==? <LENGTH <SET K <KIDS .N>>> 2>
+		      <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
+		      <==? <NODE-NAME <2 .K>> 1>
+		      <SET N <1 .K>>>
+		 <NOT .RFLG>>
+	     <SET TT <SET-SEARCH .N ,LNTH-CODE .S <REST .SS>>>
+	     <SET TT
+		  <SET-SEARCH <1 <KIDS .TT>> ,LVAL-CODE .S <REST .SS 2>>>
+	     <SMEMQ <NODE-NAME .TT> .S>
+	     <PUT .MN ,TYPE-INFO .SS>>>
+
+<DEFINE SET-SEARCH (N C S SS "AUX" (L ())) 
+	#DECL ((N) NODE (C) FIX (S) <LIST [REST NODE]> (L SS) LIST)
+	<REPEAT ()
+		<COND (<==? .C <NODE-TYPE .N>> <PUT .SS 1 .L> <RETURN .N>)>
+		<COND (<OR <N==? <NODE-TYPE .N> ,SET-CODE>
+			   <SMEMQ <NODE-NAME .N> .S>>
+		       <RETURN <>>)>
+		<SET L (.N !.L)>
+		<SET N <2 <KIDS .N>>>>>
+
+<DEFINE SMEMQ (SYM L) 
+	#DECL ((SYM) SYMTAB (L) LIST)
+	<MAPR <>
+	      <FUNCTION (LL "AUX" (N <1 .LL>)) 
+		      #DECL ((N) NODE)
+		      <COND (<==? <NODE-NAME .N> .SYM> <MAPLEAVE .LL>)>>
+	      .L>>
+
+<DEFINE NTH-ANA (N R) <NTH-REST-ANA .N .R ,NTH-CODE>>
+
+<PUT ,NTH ANALYSIS ,NTH-ANA>
+
+<DEFINE REST-ANA (N R) <NTH-REST-ANA .N .R ,REST-CODE>>
+
+<PUT ,REST ANALYSIS ,REST-ANA>
+
+<DEFINE PUT-ANA (NOD RTYP
+		 "OPTIONAL" (TF <>)
+		 "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) (TS ANY) TV (TPS <>) VAL
+		       (SVWHO ()) WHICH NS TVO TEM (P ()) TFF NUMB
+		       (RV <OR .TF <==? <NODE-NAME .NOD> IPUT>>)
+		       (NM <COND (.RV PUT) (ELSE <NODE-NAME .NOD>)>))
+   #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN NUMB) FIX (WHO P SVWHO) LIST)
+   <SET VAL
+    <PROG ((WHO ()) (WHON <>))
+      #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR FALSE NODE>>)
+      <COND
+       (<SEGFLUSH .NOD .RTYP>)
+       (<==? .LN 2>
+	<EANA <1 .K> ANY <NODE-NAME .NOD>>
+	<EANA <2 .K> ANY <NODE-NAME .NOD>>
+	<COND (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
+	       <ADDVMESS .NOD ("PUT being used to remove association.")>)>
+	<PUT .NOD ,NODE-TYPE ,IREMAS-CODE>)
+       (ELSE
+	<ARGCHK .LN 3 <NODE-NAME .NOD>>
+	<COND (.RV
+	       <SET WHON <>>
+	       <OR .TF <SET TF <SET TFF <ANA <2 .K> ANY>>>>
+	       <SET WHON .NOD>
+	       <SET TS <ANA <1 .K> <OR <AND .TF STRUCTURED> ANY>>>
+	       <SET WHON <>>)
+	      (ELSE
+	       <SET WHON .NOD>
+	       <SET TS <ANA <1 .K> ANY>>
+	       <SET WHON <>>
+	       <OR .TF <SET TFF <SET TF <ANA <2 .K> ANY>>>>)>
+	<SET TV <ANA <3 .K> ANY>>
+	<COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <==? <ISTYPE? .TF> OFFSET>>
+	       <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
+	       <PUT <1 .K> ,RESULT-TYPE .TS>)>
+	<AND <TYPE-OK? .TS '<NOT STRUCTURED>> <SET TS <>>>
+	<OR <AND <OR <==? <ISTYPE? .TF> FIX>
+		     <AND <==? <ISTYPE? .TF> OFFSET>
+			  <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
+		 <==? <NODE-SUBR .NOD> ,PUT>>
+	    <SET TF <>>>
+	<SET NS
+	     <COND (<AND .TF .TS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+		    <SET WHICH
+			 <COND (<==? <ISTYPE? .TF> FIX> <NODE-NAME <2 .K>>)
+			       (ELSE <INDEX <NODE-NAME <2 .K>>>)>>
+		    <FORM STRUCTURED
+			  !<COND (<1? .WHICH> (.TV))
+				 (ELSE ([<- .WHICH 1> ANY] .TV))>>)
+		   (ELSE <SET WHICH ALL> '<STRUCTURED [REST ANY]>)>>
+	<COND
+	 (<AND .TS .TF <NOT <EMPTY? .WHO>>>
+	  <SET NS
+	   <MAPF ,TYPE-MERGE
+	    <FUNCTION (L "AUX" (S <2 .L>) (ND <1 <DECL-SYM .S>>)) 
+	       #DECL ((L) <LIST ANY SYMTAB> (S) SYMTAB)
+	       <SET ND <DECL-DOWN .ND !<REST .L 2>>>
+	       <OR <TYPE-OK? .ND .NS> <MESSAGE ERROR "BAD ARG TO PUT" .NOD>>
+	       <SET ND
+		<TYPE-AND
+		 <TYPE-AND
+		  <GET-ELE-TYPE .ND .WHICH <> .TV>
+		  <TOP-TYPE <DECL-DOWN <GET-CURRENT-TYPE .S> !<REST .L 2>>>>
+		 .ND>>>
+	    .WHO>>
+	  <SET TV <TYPE-AND .TV <GET-ELE-TYPE .NS .WHICH>>>)
+	 (<NOT <EMPTY? .WHO>> <SET TV ANY>)>
+	<AND .TS
+	     <PUT <1 .K> ,RESULT-TYPE <SET TS <TYPE-AND <TOP-TYPE .NS> .TS>>>>
+	<COND (.TS
+	       <SET TVO <GET-ELE-TYPE .TS .WHICH>>
+	       <SET TS <GET-ELE-TYPE .TS .WHICH <> .TV>>)>
+	<COND (<AND .TS .TF <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
+	       <SET SVWHO .WHO>)>
+	<COND (<AND .TS .TF>
+	       <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>)>
+	<COND
+	 (<AND .TS
+	       .TF
+	       <SET TPS <STRUCTYP .TS>>
+	       <OR <==? <ISTYPE? .TF> FIX> <==? <ISTYPE? .TF> OFFSET>>
+	       <N==? <ISTYPE? .TS> TEMPLATE>
+	       <OR <NOT <==? .TPS TEMPLATE>>
+		   <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE> <ISTYPE? .TS>>>
+	       <OR <NOT <==? .TPS LIST>>
+		   <0? <SET TEM <DEFERN .TV>>>
+		   <AND <==? .TEM 1> <1? <DEFERN .TVO>>>>>
+	  <PUT .NOD ,NODE-TYPE ,PUT-CODE>
+	  <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+		 <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>)
+	 (ELSE
+	  <COND
+	   (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
+	    <ADDVMESS
+	     .NOD
+	     <COND
+	      (.TF
+	       <COND (<==? .TPS LIST> ("Not open compiled because of defer."))
+		     (ELSE ("Not open compiled because type is: " .TS))>)
+	      (<NOT <TYPE-OK? .TFF FIX>>
+	       ("PUT used for association manipulation."))
+	      (ELSE
+	       ("PUT maybe structure or association.  Type of 1st arg is:  "
+		.TS
+		" and that of 2d arg is:  "
+		.TFF))>>)>
+	  <PUT .NOD ,NODE-TYPE ,IPUT-CODE>)>)>
+      <PUT-FLUSH <OR .TPS ALL>>
+      <TYPE-OK? <COND (.TS .TS) (ELSE ANY)> .RTYP>>>
+   <COND
+    (<==? <NODE-TYPE .NOD> ,PUT-CODE>
+     <MAPF <>
+      <FUNCTION (L "AUX" (SYM <2 .L>)) 
+	      #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
+	      <SET-CURRENT-TYPE
+	       .SYM
+	       <PUT-TYPE-HACK <GET-CURRENT-TYPE .SYM>
+			      .TS
+			      <LPR <REST .L 2>>
+			      .WHICH
+			      0>>>
+      .SVWHO>)>
+   <COND (<AND <==? <NODE-TYPE .NOD> ,PUT-CODE>
+	       <GASSIGNED? PUT-SAME-CODE>
+	       <MEMQ .TPS '![LIST VECTOR UVECTOR TUPLE!]>
+	       <MAPF <>
+		     <FUNCTION (N) 
+			     <COND (<AND <G=? <LENGTH .N> 
+					      <INDEX ,SIDE-EFFECTS>>
+					 <SIDE-EFFECTS .N>>
+				    <MAPLEAVE <>>)
+				   (ELSE T)>>
+		     .K>
+	       <MEMQ <NODE-TYPE <3 .K>> ,HACK-NODES>
+	       <==? <ISTYPE? <RESULT-TYPE <3 .K>>> FIX>
+	       <NOT <EMPTY? <SET TEM <KIDS <3 .K>>>>>
+	       <NOT <OR <==? <NODE-SUBR <3 .K>> ,/>
+			<AND <==? <NODE-SUBR <3 .K>> ,->
+			     <NOT <AND <==? <LENGTH .TEM> 2>
+				       <==? <NODE-NAME <2 .TEM>> 1>>>>>>
+	       <MAPR <>
+		     <FUNCTION (L "AUX" (N <1 .L>)) 
+			     <COND (<AND <==? <NODE-TYPE .N> ,NTH-CODE>
+					 <SAME-OBJ <1 .K> <1 <KIDS .N>>>
+					 <SAME-OBJ <2 .K> <2 <KIDS .N>>>>
+				    <COND (<NOT <EMPTY? .P>>
+					   <PUTREST .P <REST .L>>
+					   <SET TEM (.N !.TEM)>)>
+				    <MAPLEAVE>)>
+			     <SET P .L>
+			     <>>
+		     .TEM>>
+	  <PUT <3 .K> ,KIDS .TEM>
+	  <PUT .NOD ,NODE-TYPE ,PUT-SAME-CODE>)>
+   .VAL>
+
+<DEFINE PUT-TYPE-HACK (TY TS L WHICH EX) 
+	#DECL ((L) <LIST [REST FIX ATOM]>)
+	<COND (<EMPTY? .L> .TS)
+	      (<AND <EMPTY? <REST .L 2>> <==? <2 .L> REST>>
+	       <GET-ELE-TYPE
+		.TY
+		<+ <1 .L> .WHICH>
+		<>
+		<PUT-TYPE-HACK <GET-ELE-TYPE .TS .WHICH>
+			       .TS
+			       <REST .L 2>
+			       .WHICH
+			       0>>)
+	      (<==? <2 .L> REST>
+	       <PUT-TYPE-HACK .TY .TS <REST .L 2> .WHICH <1 .L>>)
+	      (ELSE
+	       <GET-ELE-TYPE
+		.TY
+		<+ <1 .L> .EX>
+		<>
+		<PUT-TYPE-HACK <GET-ELE-TYPE .TY <+ <1 .L> .EX>>
+			       .TS
+			       <REST .L 2>
+			       .WHICH
+			       0>>)>>
+
+<DEFINE LPR (L) 
+	#DECL ((L) LIST)
+	<COND (<EMPTY? .L> .L) (ELSE (!<LPR <REST .L>> <1 .L>))>>
+
+<SETG HACK-NODES ![,ABS-CODE ,ARITH-CODE!]>
+
+<PUT ,PUT ANALYSIS ,PUT-ANA>
+
+<PUT ,PUTPROP ANALYSIS ,PUT-ANA>
+
+<DEFINE SAME-OBJ (N1 N2) 
+	#DECL ((N1 N2) NODE)
+	<COND (<==? <NODE-TYPE .N1> <NODE-TYPE .N2>>
+	       <COND (<MEMQ <NODE-TYPE .N1> ,SNODES>
+		      <==? <NODE-NAME .N1> <NODE-NAME .N2>>)
+		     (ELSE
+		      <MAPF <>
+			    <FUNCTION (N3 N4) 
+				    <COND (<SAME-OBJ .N3 .N4>)
+					  (ELSE <MAPLEAVE <>>)>>
+			    <KIDS .N1>
+			    <KIDS .N2>>)>)>>
+
+<DEFINE DECL-DOWN ("TUPLE" TUP "AUX" (ND <1 .TUP>) (LN <- <LENGTH .TUP> 1>))
+	#DECL ((TUP) TUPLE (LN) FIX)
+	<REPEAT ()
+	    <COND (<L? .LN 2> <RETURN .ND>)
+		  (ELSE
+		   <SET ND
+			<GET-ELE-TYPE
+			 .ND
+			 <NTH .TUP <+ .LN 1>>
+			 <==? <NTH .TUP .LN> REST>>>)>
+	    <SET LN <- .LN 2>>>>
+
+<DEFINE DECL-UP (NX L) 
+	#DECL ((L) LIST)
+	<REPEAT ((FIRST T) (NUM 0))
+		#DECL ((NUM) FIX (L) LIST)
+		<COND (<EMPTY? .L> <RETURN .NX>)>
+		<COND (<==? <1 .L> NTH>
+		       <SET NX
+			    <FORM STRUCTURED
+				  !<COND (<0? <SET NUM <+ .NUM <2 .L> -1>>> ())
+					 (<1? .NUM> (ANY))
+					 (ELSE ([.NUM ANY]))>
+				  .NX>>
+		       <SET NUM 0>
+		       <SET FIRST <>>)
+		      (.FIRST <SET NX <REST-DECL .NX <2 .L>>>)
+		      (ELSE <SET NUM <+ .NUM <2 .L>>>)>
+		<SET L <REST .L 2>>>>
+
+<DEFINE PUTREST-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) T1 T2) 
+	#DECL ((NOD) NODE (K) <LIST [REST NODE]>)
+	<COND (<==? <NODE-SUBR .NOD> ,REST> <REST-ANA .NOD .RTYP>)
+	      (<SEGFLUSH .NOD .RTYP>
+	       <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+	       <TYPE-OK? '<PRIMTYPE LIST> .RTYP>)
+	      (ELSE
+	       <ARGCHK <LENGTH .K> 2 PUTREST>
+	       <SET T1 <EANA <1 .K> '<PRIMTYPE LIST> PUTREST>>
+	       <SET T2 <EANA <2 .K> '<PRIMTYPE LIST> PUTREST>>
+	       <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
+		      <MESSAGE ERROR " ATTEMPT TO MUNG QUOTED OBJECT " .NOD>)>
+	       <PUT .NOD ,NODE-TYPE ,PUTR-CODE>
+	       <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
+	       <TYPE-OK? .T1 .RTYP>)>>
+
+<PUT ,PUTREST ANALYSIS ,PUTREST-ANA>
+
+<DEFINE MEMQ-ANA (N R "AUX" (K <KIDS .N>) TYP VTYP STYP ETY) 
+	#DECL ((N) NODE (K) <LIST [REST NODE]>)
+	<COND
+	 (<SEGFLUSH .N .R>)
+	 (ELSE
+	  <ARGCHK <LENGTH .K> 2 MEMQ>
+	  <SET VTYP <EANA <1 .K> ANY MEMQ>>
+	  <SET TYP <EANA <2 .K> STRUCTURED MEMQ>>
+	  <COND (<NOT <TYPE-OK? .VTYP <SET ETY <GET-ELE-TYPE .TYP ALL>>>>
+		 <MESSAGE WARNING "MEMQ NEVER TRUE " .N>)>
+	  <COND (<AND <SET STYP <STRUCTYP .TYP>> <N==? .STYP TEMPLATE>>
+		 <PUT .N ,NODE-TYPE ,MEMQ-CODE>)
+		(ELSE
+		 <COND (.VERBOSE <ADDVMESS .N ("Not open compiled because type is:  "
+						.TYP)>)>
+		 <PUT .N ,NODE-TYPE ,ISUBR-CODE>)>
+	  <TYPE-OK? <TYPE-MERGE FALSE
+				<COND (<AND .ETY <N==? .ETY ANY>>
+				       <FORM <COND (.STYP) (STRUCTURED)>
+					     [REST .ETY]>)
+				      (.STYP)
+				      (STRUCTURED)>>
+		    .R>)>>
+
+<PUT ,MEMQ ANALYSIS ,MEMQ-ANA>
+
+<ENDPACKAGE>
+
+
\ No newline at end of file