X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;ds=sidebyside;f=%3Cmdl.comp%3E%2Fgetord.mud.1;fp=%3Cmdl.comp%3E%2Fgetord.mud.1;h=2d8431f71ba1a6a131727342c1fc5cb78f35c604;hb=bb23b34fe64e4bdb6479f4f36313382c42941c65;hp=0000000000000000000000000000000000000000;hpb=b3fcf50db6d34c93204a345cf2b40f7e1d0e1e7c;p=pdp10-muddle.git

diff --git a/<mdl.comp>/getord.mud.1 b/<mdl.comp>/getord.mud.1
new file mode 100644
index 0000000..2d8431f
--- /dev/null
+++ b/<mdl.comp>/getord.mud.1
@@ -0,0 +1,244 @@
+
+"GETORDER FUNCTIONS"
+
+<DEFINE CHECK (ATM)
+	#DECL ((ATM) <UNSPECIAL ATOM>)
+	<AND <TYPE? .ATM ATOM>
+	     <GASSIGNED? .ATM>
+	     <OR <TYPE? ,.ATM FUNCTION>
+		 <TYPE? ,.ATM MACRO>>>>
+
+<DEFINE PREV (LS SUBLS)
+	#DECL ((LS SUBLS) <UNSPECIAL LIST> (VALUE) LIST)
+	<REST .LS <- <LENGTH .LS> <LENGTH .SUBLS> 1>>>
+
+<DEFINE SPLOUTEM (FL OU)
+	#DECL ((FL) <UNSPECIAL LIST> (OU) <UNSPECIAL ATOM>)
+	<REPEAT (TEM)
+		#DECL ((TEM) <UNSPECIAL <PRIMTYPE LIST>>)
+		<COND (<EMPTY? .FL> <RETURN T>)
+		      (<SET TEM <MEMQ .OU <1 .FL>>>
+		       <COND (<==? <1 .FL> .TEM> <PUT .FL 1 <REST .TEM>>)
+			     (ELSE <PUTREST <PREV <1 .FL> .TEM> <REST .TEM>>)>)>
+		<SET FL <REST .FL 2>>>>
+
+<DEFINE REVERSE (LS)
+	#DECL ((LS) <UNSPECIAL LIST>)
+	<REPEAT ((RES ()) (TEM ()))
+		#DECL ((RES TEM) LIST)
+		<COND (<EMPTY? .LS> <RETURN .RES>)>
+		<SET TEM <REST .LS>>
+		<SET RES <PUTREST .LS .RES>>
+		<SET LS .TEM>>>
+
+<DEFINE ORDEREM (FLIST)
+   #DECL ((FLIST) <UNSPECIAL LIST>)
+   <REPEAT (TEM (RES ()))
+     #DECL ((RES) <UNSPECIAL <LIST [REST <OR ATOM LIST>]>>
+	    (VALUE) <LIST [REST <OR ATOM LIST>]>
+	    (TEM) <UNSPECIAL <PRIMTYPE LIST>>)
+     <COND
+      (<EMPTY? .FLIST> <RETURN <REVERSE .RES>>)
+      (<SET TEM <MEMQ () .FLIST>>
+       <SET RES (<2 .TEM> !.RES)>
+       <COND (<==? .TEM .FLIST> <SET FLIST <REST .FLIST 2>>)
+	     (ELSE <PUTREST <PREV .FLIST .TEM> <REST .TEM 2>>)>
+       <SPLOUTEM .FLIST <1 .RES>>)
+      (ELSE
+       <PROG ((RES2 ()) GOTONE)
+	     #DECL ((RES2) LIST)
+	     <SET GOTONE <>>
+	     <REPEAT ((RES1 .FLIST))
+		     #DECL ((RES1) LIST)
+		     <COND (<NOT <CALLME <2 .RES1> .FLIST>>
+			    <SET GOTONE T>
+			    <SET RES2 (<2 .RES1> !.RES2)>
+			    <COND (<==? .FLIST .RES1>
+				   <SET FLIST <REST .FLIST 2>>)
+				  (ELSE
+				   <PUTREST <PREV .FLIST .RES1>
+					    <REST .RES1 2>>)>)>
+		     <AND <EMPTY? <SET RES1 <REST .RES1 2>>> <RETURN>>>
+	     <COND (.GOTONE <AGAIN>)
+		   (<NOT <EMPTY? .FLIST>> <SET FLIST <CORDER .FLIST>>)>
+	     <SET TEM <REVERSE .RES>>
+	     <COND (<NOT <EMPTY? .FLIST>>
+		    <COND (<EMPTY? .RES>
+			   <SET TEM .FLIST>
+			   <SET RES <REST .FLIST <- <LENGTH .FLIST> 1>>>)
+			  (ELSE
+			   <SET RES
+				<REST <PUTREST .RES .FLIST>
+				      <LENGTH .FLIST>>>)>)>
+	     <COND (<EMPTY? .RES> <SET RES .RES2>)
+		   (ELSE <PUTREST .RES .RES2> <SET RES .TEM>)>>
+       <RETURN .RES>)>>>
+
+<DEFINE CALLME (ATM LST)
+	#DECL ((ATM) ATOM (LST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
+	<REPEAT ()
+		<AND <EMPTY? .LST> <RETURN <>>>
+		<AND <MEMQ .ATM <1 .LST>> <RETURN>>
+		<SET LST <REST .LST 2>>>>
+
+<DEFINE CORDER (LST "AUX" (RES ()))
+	#DECL ((LST) <LIST [REST <LIST [REST ATOM]> ATOM]> (RES) LIST)
+	<REPEAT ((LS .LST))
+		#DECL ((LS) <LIST [REST LIST ATOM]>)
+		<AND <EMPTY? .LS> <RETURN>>
+		<PUT .LS 1 <ALLREACH (<2 .LS>) <1 .LS> .LST>>
+		<SET LS <REST .LS 2>>>
+	<REPEAT ((PNT ()))
+		#DECL ((PNT) <LIST [REST LIST ATOM]>)
+		<REPEAT ((SHORT <CHTYPE <MIN> FIX>) (TL 0) (LST .LST))
+			#DECL ((SHORT TL) FIX (LST) <LIST [REST LIST ATOM]>)
+			<AND <EMPTY? .LST> <RETURN>>
+			<COND (<L? <SET TL <LENGTH <1 .LST>>> .SHORT>
+			       <SET SHORT .TL>
+			       <SET PNT .LST>)>
+			<SET LST <REST .LST 2>>>
+		<SET RES
+		     (<COND (<1? <LENGTH <1 .PNT>>> <1 <1 .PNT>>)
+			    (ELSE <1 .PNT>)>
+		      !.RES)>
+		<MAPF <> <FUNCTION (ATM) <SPLOUTEM .LST .ATM>> <1 .PNT>>
+		<REPEAT (TEM)
+			<COND (<SET TEM <MEMQ () .LST>>
+			       <COND (<==? .TEM .LST> <SET LST <REST .TEM 2>>)
+				     (ELSE
+				      <PUTREST <PREV .LST .TEM>
+					       <REST .TEM 2>>)>)
+			      (ELSE <RETURN>)>>
+		<AND <EMPTY? .LST> <RETURN>>>
+	<REVERSE .RES>>
+
+<DEFINE ALLREACH (LATM LST MLST)
+   #DECL ((LATM LST) <LIST [REST ATOM]>
+	  (MLST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
+   <MAPF <>
+    <FUNCTION (ATM)
+	    #DECL ((ATM) ATOM)
+	    <COND (<MEMQ .ATM .LATM>)
+		  (ELSE
+		   <SET LATM
+			<ALLREACH (.ATM !.LATM)
+				  <REPEAT ((L .MLST))
+					  #DECL ((L) <LIST [REST LIST ATOM]>)
+					  <AND <==? <2 .L> .ATM>
+					       <RETURN <1 .L>>>
+					  <SET L <REST .L 2>>>
+				  .MLST>>)>>
+    .LST>
+   .LATM>
+
+<DEFINE REMEMIT (ATM)
+	#DECL ((ATM) ATOM (FUNC) <SPECIAL ATOM>
+	       (FUNCL) <SPECIAL <LIST [REST ATOM]>>)
+	<OR <==? .ATM .FUNC>
+	    <MEMQ .ATM .FUNCL>
+	    <SET FUNCL (.ATM !.FUNCL)>>>
+
+<DEFINE FINDREC (OBJ "AUX" (FM '<>))
+	#DECL ((FM) FORM)
+	<COND (<MONAD? .OBJ>)
+	      (<AND <TYPE? .OBJ FORM SEGMENT>
+		    <NOT <EMPTY? <SET FM <CHTYPE .OBJ FORM>>>>>
+	       <COND (<AND <TYPE? <1 .FM> ATOM> <GASSIGNED? <1 .FM>>>
+		      <AND <TYPE? ,<1 .FM> FUNCTION> <REMEMIT <1 .FM>>>
+		      <AND <TYPE? ,<1 .FM> MACRO>
+			<NOT <EMPTY? ,<1 .FM>>>
+				<FINDREC <EMACRO .FM>>>
+				;"Analyze expansion of MACRO call"
+		      <AND <OR <==? ,<1 .FM> ,MAPF> <==? ,<1 .FM> ,MAPR>>
+			   <NOT <LENGTH? .FM 3>>
+			   <PROG ()
+				 <AND <TYPE? <2 .FM> FORM> <CHK-GVAL <2 .FM>>>
+				 T>
+			   <PROG ()
+				 <AND <TYPE? <3 .FM> FORM>
+				      <CHK-GVAL <3 .FM>>>>>)
+		     (<STRUCTURED? <1 .OBJ>> <MAPF <> ,FINDREC <1 .OBJ>>)>
+	       <COND (<EMPTY? <REST .OBJ>>)
+		     (ELSE <MAPF <> ,FINDREC <REST .OBJ>>)>)
+	      (ELSE <MAPF <> ,FINDREC .OBJ>)>>
+
+<DEFINE EMACRO (OBJ "AUX" (ERR <GET ERROR!-INTERRUPTS INTERRUPT>) TEM) 
+	<COND (.ERR <OFF .ERR>)>
+	<ON "ERROR"
+	    <FUNCTION (FR "TUPLE" T) 
+		    <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
+			   <DISMISS [!.T] ,MACACT>)
+			  (ELSE <APPLY ,<PARSE "OVALRET!-COMBAT!-"> " ">)>>
+	    100>
+	<COND (<TYPE? <SET TEM
+			   <PROG MACACT () #DECL ((MACACT) <SPECIAL ACTIVATION>)
+				 <SETG MACACT .MACACT>
+				 (<EXPAND .OBJ>)>>
+		      VECTOR>
+	       <OFF "ERROR">
+	       <COND (.ERR <EVENT .ERR>)>
+	       <ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
+	      (ELSE <OFF "ERROR"> <AND .ERR <EVENT .ERR>> <1 .TEM>)>>
+
+<DEFINE CHK-GVAL (FM) #DECL ((FM) FORM)
+	<AND	<==? <LENGTH .FM> 2>
+		<TYPE? <1 .FM> ATOM>
+		<==? ,<1 .FM> ,GVAL>
+		<TYPE? <2 .FM> ATOM>
+		<GASSIGNED? <2 .FM>>
+		<OR <TYPE? ,<2 .FM> FUNCTION>
+			<AND <TYPE? ,<2 .FM> MACRO>
+				<NOT <EMPTY? ,<2 .FM>>>
+				<TYPE? <1 ,<2 .FM>> FUNCTION>>>
+		<REMEMIT <2 .FM>>>>
+
+<DEFINE FINDEM (FUNC "AUX" (FUNCL ()))
+	#DECL ((FUNC) <SPECIAL ATOM> (FUNCL) <SPECIAL <LIST [REST ATOM]>>
+	       (VALUE) <LIST [REST ATOM]>)
+	<FINDREC ,.FUNC>
+	.FUNCL>
+
+<DEFINE FINDEMALL (ATM
+		   "AUX" (TOPDO
+			  <REPEAT ((TD ()))
+				  #DECL ((TD) LIST
+					 (VALUE)
+					 <LIST <LIST [REST ATOM]> ATOM>)
+				  <AND <EMPTY? .ATM> <RETURN .TD>>
+				  <SET TD (<FINDEM <1 .ATM>> <1 .ATM> !.TD)>
+				  <SET ATM <REST .ATM>>>))
+	#DECL ((ATM) <UNSPECIAL <TUPLE [REST ATOM]>>
+	       (TOPDO) <UNSPECIAL <LIST <LIST [REST ATOM]> ATOM>>)
+	<REPEAT ((TODO .TOPDO) (CURDO <1 .TOPDO>))
+		#DECL ((TODO) <UNSPECIAL LIST>
+		       (CURDO) <UNSPECIAL <LIST [REST ATOM]>>)
+		<COND (<EMPTY? .CURDO>
+		       <COND (<EMPTY? <SET TODO <REST .TODO 2>>>
+			      <RETURN .TOPDO>)
+			     (ELSE <SET CURDO <1 .TODO>> <AGAIN>)>)
+		      (<MEMQ <1 .CURDO> .TOPDO>)
+		      (ELSE
+		       <PUTREST <REST .TODO <- <LENGTH .TODO> 1>>
+				(<FINDEM <1 .CURDO>> <1 .CURDO>)>)>
+		<SET CURDO <REST .CURDO>>>>
+
+<DEFINE GETORDER ("TUPLE" ATMS)
+	#DECL ((ATMS) <UNSPECIAL <TUPLE [REST ATOM]>>)
+	<COND (<NOT <MEMQ #FALSE () <MAPF ,LIST ,CHECK .ATMS>>>
+	       <ORDEREM <FINDEMALL .ATMS>>)
+	      (ELSE <ERROR BAD-ARG GETORDER>)>>
+
+
+
+<SET LIST_OF_FUNCTIONS
+     '(CHECK
+       PREV
+       SPLOUTEM
+       REVERSE
+       ORDEREM
+       REMEMIT
+       FINDREC
+       FINDEM
+       FINDEMALL
+       GETORDER)>
+
\ No newline at end of file