;"This is the interpreter code for TYPEs."

<DEFINE I$APE-TVAL (ARG APE-OFF APE-NAME "AUX" OFF ENTRY)
	#DECL ((ARG APE-NAME) T$ATOM (OFF) <OR T$TYPE-C FALSE>
	       (APE-OFF) FIX (VALUE) <OR T$ATOM APPLICABLE FALSE>
	       (ENTRY) T$TYPE-ENTRY)
	<COND (<SET OFF <VALID-TYPE? .ARG>>
	       <NTH <SET ENTRY <NTH ,M$$TYPE-INFO <+ <LSH .OFF -6> 1>>>
		    .APE-OFF>)
	      (ELSE <T$ERROR %<P-E "BAD-TYPE-NAME"> .APE-NAME>)>>

<DEFINE I$APE-TSET (ARG1 ARG2 APE-OFF APE-NAM APE-FCN APE-TYP
		    "AUX" ENTRY1 ENTRY2 OFF
		    "NAME" ERR)
	#DECL ((ARG1 APE-NAME) T$ATOM (ARG2) <OR T$ATOM T$MSUBR APPLICABLE>
	       (APE-OFF) FIX (APE-FCN) <OR T$FUNCTION T$MSUBR>
	       (OFF) <OR T$TYPE-C FALSE>
	       (APE-TYP) <VECTOR [REST T$ATOM]> (ENTRY1 ENTRY2) T$TYPE-ENTRY
	       (ERR) ANY (VALUE) <OR T$ATOM APPLICABLE FALSE ANY>)
	<COND (<SET OFF <VALID-TYPE? .ARG1>>
	       <SET ENTRY1 <NTH ,M$$TYPE-INFO <+ <LSH .OFF -6> 1>>>)
	      (ELSE <RETURN <T$ERROR %<P-E "BAD-TYPE-NAME"> .APE-NAM> .ERR>)>
	<COND (<AND <TYPE? .ARG2 T$ATOM> <SET OFF <VALID-TYPE? .ARG2>>>
	       <SET ENTRY2 <NTH ,M$$TYPE-INFO <+ <LSH .OFF -6> 1>>>
	       <COND (<N==? <NTH .ENTRY1 ,M$$PTYPE> <NTH .ENTRY2 ,M$$PTYPE>>
		      <RETURN <T$ERROR %<P-E "STORAGE-TYPE-DIFFER"> .APE-NAM>
			      .ERR>)>
	       <PUT .ENTRY1 .APE-OFF <NTH .ENTRY2 .APE-OFF>>)
	      (<TYPE? .ARG2 T$ATOM>
	       <RETURN <T$ERROR %<P-E "BAD-TYPE-NAME"> .APE-NAM> .ERR>)
	      (<==? .ARG2 .APE-FCN>
	       <COND (<MEMQ .ARG1 .APE-TYP> <PUT .ENTRY1 .APE-OFF .ARG1>)
		     (ELSE <PUT .ENTRY1 .APE-OFF <>>)>)
	      (ELSE <PUT .ENTRY1 .APE-OFF .ARG2>)>
	.ARG1>

;"Here are some SUBRs for TYPE manipulation."

<DEFINE T$ALLTYPES ()
	#DECL ((VALUE) <VECTOR [REST T$ATOM]>)
	<COND (,M$$NEWTYPE?
	       <SETG M$$NEWTYPE? <>>
	       <SETG M$$ALLTYPES
		     <MAPF ,VECTOR
			   <FUNCTION (VEC)
				     #DECL ((VEC) <OR T$TYPE-ENTRY FALSE>)
				     <OR .VEC <MAPSTOP>>
				     <NTH .VEC ,M$$NTYPE>>
			   ,M$$TYPE-INFO>>)
	      (ELSE ,M$$ALLTYPES)>>

<DEFINE T$TYPE? (ARG "TUPLE" ARGS
		     "AUX" (TYPC <CHTYPE <LSH <CALL TYPE .ARG> -6> FIX>)
		           (ENTRY <NTH ,M$$TYPE-INFO <+ .TYPC 1>>)
		           (TYP <NTH .ENTRY ,M$$NTYPE>) L)
	#DECL ((ARGS) <TUPLE T$ATOM [REST T$ATOM]> (TYPC) FIX
	       (ENTRY) T$TYPE-ENTRY (TYP) T$ATOM (L) <OR <VECTOR T$ATOM> FALSE>)
	<COND (<SET L <MEMQ .TYP .ARGS>>
	       <1 .L>)>>

<DEFINE T$TYPE (ARG "AUX" ENTRY (TYP <CHTYPE <LSH <CALL TYPE .ARG> -6> FIX>))
	#DECL ((ARG) ANY (VALUE) T$ATOM (ENTRY) T$TYPE-ENTRY (TYP) FIX)
	<NTH <SET ENTRY <NTH ,M$$TYPE-INFO <+ .TYP 1>>> ,M$$NTYPE>>

<DEFINE T$PRIMTYPE (ARG "AUX" ENTRY
		              (TYP <CHTYPE <LSH <CALL TYPE .ARG> -6> FIX>))
	#DECL ((ARG) ANY (VALUE) T$ATOM (ENTRY) T$TYPE-ENTRY (TYP) FIX)
	<NTH <SET ENTRY <NTH ,M$$TYPE-INFO <+ 1 .TYP>>> ,M$$PTYPE>>

<DEFINE T$TYPEPRIM (ARG "AUX" OFF ENTRY)
	#DECL ((ARG) T$ATOM (ENTRY) T$TYPE-ENTRY (VALUE) <OR T$ATOM ANY>)
	<COND (<NOT <SET OFF <VALID-TYPE? .ARG>>>
	       <T$ERROR %<P-E "BAD-TYPE-NAME"> %<P-R "TYPEPRIM">>)
	      (ELSE
	       <SET ENTRY <NTH ,M$$TYPE-INFO <+ <LSH .OFF -6> 1>>>
	       <NTH .ENTRY ,M$$PTYPE>)>>

<DEFINE T$VALID-TYPE? (ARG)
	#DECL ((ARG) T$ATOM (CNT) FIX (VALUE) <OR T$TYPE-C FALSE>)
	<VALID-TYPE? .ARG>>

<DEFINE T$TYPE-C (ARG1 "OPTIONAL" ARG2 "AUX" OFF1 OFF2 SAT ENTRY)
	#DECL ((ARG1 ARG2) T$ATOM (OFF1 OFF2) <OR FALSE FIX T$TYPE-C>
	       (SAT) FIX (VALUE) T$TYPE-C (ENTRY) T$TYPE-ENTRY)
	<COND (<AND <SET OFF1 <VALID-TYPE? .ARG1>> <NOT <ASSIGNED? ARG2>>>
	       .OFF1)
	      (<AND .OFF1 <ASSIGNED? ARG2>>
	       <COND (<NOT <SET OFF2 <VALID-TYPE? .ARG2>>>
		      <T$ERROR %<P-E "BAD-TYPE-NAME"> %<P-R "TYPE-C">>)
		     (<==? <NTH <SET ENTRY <NTH ,M$$TYPE-INFO
						<+ <LSH .OFF1 -6> 1>>>
				,M$$PTYPE>
			   <NTH <SET ENTRY <NTH ,M$$TYPE-INFO
						<+ <LSH .OFF2 -6> 1>>>
				,M$$PTYPE>>
		      .OFF1)
		     (ELSE
		      <T$ERROR %<P-E "STORAGE-TYPE-DIFFER"> %<P-R "TYPE-C">>)>)
	      (<AND <ASSIGNED? ARG2>
		    <N==? .ARG2 %<P-R "RECORD">>
		    <NOT <SET OFF2 <VALID-TYPE? .ARG2>>>>
	       <T$ERROR %<P-E "BAD-TYPE-NAME"> %<P-R "TYPE-C">>)
	      (<ASSIGNED? ARG2>
	       <COND (<==? .ARG2  %<P-R "RECORD">> <SET SAT ,M$$T-REC>)
		     (ELSE
		      <SET SAT
			   <CHTYPE <ANDB ,M$$TYSAT
					 <NTH <SET ENTRY
						   <NTH ,M$$TYPE-INFO
							<+ <LSH .OFF2 -6> 1>>>
					      ,M$$TYWRD>>
				   FIX>>)>
	       <SET OFF1 <CHTYPE <LSH <CALL NEWTYPE .SAT> -6> FIX>>
	       <SET SAT <CHTYPE <ORB <LSH .OFF1 ,M$$TYOFF> .SAT> FIX>>
	       <SETG M$$NEWTYPE? T>
	       <PUT ,M$$TYPE-INFO
		    <+ .OFF1 1>
		    <CHTYPE [.ARG1
			     <COND (<==? .ARG2 %<P-R "RECORD">> .ARG1)
				   (ELSE
				    <M$$PTYPE
				     <SET ENTRY <NTH ,M$$TYPE-INFO
						     <+ <LSH .OFF2 -6> 1>>>>)>
			     <> <> <> <CHTYPE .SAT T$TYPE-C> <>]
			    T$TYPE-ENTRY>>
	       <PUT .ARG1 ,M$$TYPE <CHTYPE .SAT T$TYPE-C>>
	       <T$ALLTYPES>
	       <CHTYPE .SAT T$TYPE-C>)
	      (ELSE <T$ERROR %<P-E "TYPE-UNDEFINED"> %<P-R "TYPE-C">>)>>

<DEFINE T$NEWTYPE (ARG1 ARG2 "OPTIONAL" (ARG3 <>) "AUX" ENTRY OFF1 OFF2 SAT)
	#DECL ((ARG1 ARG2) T$ATOM (ARG3) <OR T$ATOM FORM SEGMENT FALSE>
	       (ENTRY) T$TYPE-ENTRY (SAT) FIX
	       (OFF1 OFF2) <OR FALSE FIX T$TYPE-C>
	       (VALUE) <OR T$ATOM ANY>)
	<COND (<AND <N==? .ARG2 %<P-R "RECORD">>
		    <NOT <SET OFF2 <VALID-TYPE? .ARG2>>>>
	       <T$ERROR %<P-E "BAD-TYPE-NAME"> %<P-R "NEWTYPE">>)
	      (<AND <SET OFF1 <VALID-TYPE? .ARG1>>
		    <COND (<N==? <NTH <SET ENTRY <NTH ,M$$TYPE-INFO
						      <+ <LSH .OFF2 -6> 1>>>
				      ,M$$PTYPE>
				 <NTH <SET ENTRY <NTH ,M$$TYPE-INFO
						      <+ <LSH .OFF1 -6> 1>>>
				      ,M$$PTYPE>>
			   <NOT <T$ERROR %<P-E "TYPE-ALREADY-EXISTS">
					 %<P-R "NEWTYPE">
					 %<P-R "ERRET-NON-FALSE-TO-REDEFINE">>>)
			  (ELSE
			   <COND (.ARG3 <PUT .ENTRY ,M$$TDECL .ARG3>)>
			   .ARG1)>>)
	      (T
	       <SET ENTRY <NTH ,M$$TYPE-INFO <+ <LSH .OFF2 -6> 1>>>
	       <SET SAT <COND (<==? .ARG2 %<P-R "RECORD">> ,M$$T-REC)
			      (ELSE
			       <CHTYPE <ANDB ,M$$TYSAT
					     <NTH .ENTRY ,M$$TYWRD>> FIX>)>>
	       <SET OFF1 <CHTYPE <LSH <CALL NEWTYPE .SAT> -6> FIX>>
	       <SET SAT <CHTYPE <ORB <LSH .OFF1 ,M$$TYOFF> .SAT> FIX>>
	       <SETG M$$NEWTYPE? T>
	       <PUT ,M$$TYPE-INFO
		    <+ .OFF1 1>
		    <CHTYPE [.ARG1 <COND (<==? .ARG2 %<P-R "RECORD">> .ARG1)
					 (ELSE <M$$PTYPE .ENTRY>)> <> <>
			     <> <CHTYPE .SAT T$TYPE-C> .ARG3]
			    T$TYPE-ENTRY>>
	       <PUT .ARG1 ,M$$TYPE <CHTYPE .SAT T$TYPE-C>>
	       <T$ALLTYPES>
	       .ARG1)>>

<DEFINE T$CHTYPE (ARG1 ARG2 "AUX" OFF ENTRY ENTRY1)
	#DECL ((ARG1 VALUE) ANY (ARG2) T$ATOM (OFF) <OR FALSE T$TYPE-C>
	       (ENTRY1 ENTRY) T$TYPE-ENTRY)
	<COND (<NOT <SET OFF <VALID-TYPE? .ARG2>>>
	       <T$ERROR %<P-E "BAD-TYPE-NAME"> %<P-R "CHTYPE">>)
	      (<N==? <NTH <SET ENTRY1
			       <NTH ,M$$TYPE-INFO
				    <+ <LSH <CALL TYPE .ARG1>
					    -6> 1>>>
			  ,M$$PTYPE>
		     <NTH <SET ENTRY <NTH ,M$$TYPE-INFO <+ <LSH .OFF -6> 1>>>
			  ,M$$PTYPE>>
	       <T$ERROR %<P-E "STORAGE-TYPES-DIFFER"> %<P-R "CHTYPE">>)
	      (<AND <NTH .ENTRY ,M$$TDECL>
		    <N==? .ENTRY .ENTRY1>
		    <NOT <T$DECL? .ARG1 <NTH .ENTRY ,M$$TDECL>>>>
	       <T$ERROR %<P-E "DECL-VIOLATION"> %<P-R "CHTYPE">>)
	      (ELSE <CALL CHTYPE .ARG1 <CHTYPE .OFF FIX>>)>>

<DEFINE T$ASCII (ARG)
	#DECL ((ARG) <OR CHARACTER FIX> (VALUE) <OR FIX CHARACTER ANY>)
	<COND (<TYPE? .ARG CHARACTER> <CHTYPE .ARG FIX>)
	      (<OR <L? .ARG 0> <G? .ARG 255>>
	       <T$ERROR %<P-E "ARGUMENT-OUT-OF-RANGE"> %<P-R "ASCII">>)
	      (ELSE <CHTYPE .ARG CHARACTER>)>>

<DEFINE T$PRINTTYPE (ARG1 "OPTIONAL" ARG2)
	#DECL ((ARG1) T$ATOM (ARG2) <OR T$ATOM T$MSUBR APPLICABLE>
	       (VALUE) <OR T$ATOM APPLICABLE FALSE ANY>)
	<COND (<ASSIGNED? ARG2>
	       <I$APE-TSET .ARG1 .ARG2 ,M$$PRINT %<P-R "PRINTTYPE">
			   ,T$PRINT ,M$$PRINT-TYPES>)
	      (ELSE <I$APE-TVAL .ARG1 ,M$$PRINT %<P-R "PRINTTYPE">>)>>

<DEFINE T$EVALTYPE (ARG1 "OPTIONAL" ARG2)
	#DECL ((ARG1) T$ATOM (ARG2) <OR T$ATOM APPLICABLE>
	       (VALUE) <OR T$ATOM APPLICABLE FALSE ANY>)
	<COND (<ASSIGNED? ARG2>
	       <I$APE-TSET .ARG1 .ARG2 ,M$$NEVAL %<P-R "EVALTYPE">
			   ,T$EVAL ,M$$NEVAL-TYPES>)
	      (ELSE <I$APE-TVAL .ARG1 ,M$$NEVAL %<P-R "EVALTYPE">>)>>

<DEFINE T$APPLYTYPE (ARG1 "OPTIONAL" ARG2)
	#DECL ((ARG1) T$ATOM (ARG2) <OR T$ATOM APPLICABLE>
	       (VALUE) <OR T$ATOM APPLICABLE FALSE ANY>)
	<COND (<ASSIGNED? ARG2>
	       <I$APE-TSET .ARG1 .ARG2 ,M$$APPLY %<P-R "APPLYTYPE">
			   ,T$APPLY ,M$$APPLY-TYPES>)
	      (ELSE <I$APE-TVAL .ARG1 ,M$$APPLY %<P-R "APPLYTYPE">>)>>

<DEFINE T$APPLICABLE? (ARG "AUX" ENTRY
		                 (TYP <CHTYPE <LSH <CALL TYPE .ARG> -6> FIX>))
	#DECL ((ARG) ANY (VALUE) <OR T$ATOM FALSE> (ENTRY) T$TYPE-ENTRY
	       (TYP) FIX)
	<COND (<NTH <SET ENTRY <NTH ,M$$TYPE-INFO <+ .TYP 1>>> ,M$$APPLY>
	       %<P-R "T">)>>

<DEFINE T$STRUCTURED? (ARG) #DECL ((ARG) ANY (VALUE) <OR T$ATOM FALSE>)
	<COND (<MEMQ <T$PRIMTYPE .ARG> ,M$$STRUCTURED>
	       %<P-R "T">)>>

<DEFINE T$LOCATIVE? (ARG) #DECL ((ARG) ANY (VALUE) <OR T$ATOM FALSE>)
	<COND (<MEMQ <T$PRIMTYPE .ARG> ,M$$LOCATIVE>
	       %<P-R "T">)>>

;"HACK FOR APOLLO VERSION NEEDS TO BE GENERALIZED"

<DEFINE T$TYPE-W (X "OPT" Y "AUX" Z)
	#DECL ((X Y) ATOM)
	<COND (<ASSIGNED? Y> <SET Z <T$TYPE-C .X .Y>>)
	      (ELSE <SET Z <T$TYPE-C .X>>)>
	<CALL TYPEW .Z <T$TYPE-C <T$TYPEPRIM .X>>>>