; " This is the PACKAGE handling routines, written in MIM. "
; " For documentaton, see The MDL Programming environment [Lebling 80]. "

<BLOCK (<ROOT>)>

PACKAGE-MODE

PACKAGE

RPACKAGE

ENTRY

RENTRY

SURVIVOR

EXTERNAL

USE

USE-WHEN

USE-TOTAL

USE-DEBUG

USE-DEFER

EXPORT

INCLUDE

INCLUDE-WHEN

INCLUDE-DEBUG

COMPILING?

DEBUGGING?

DEFINITIONS

END-DEFINITIONS

DROP

NULL-OBLIST

ENDPACKAGE

L-SEARCH-PATH

L-SECOND-NAMES

L-OPEN

L-FLOAD

L-LOAD

L-LOADER

L-NO-FILES

L-NO-MAGIC

L-ALWAYS-INQUIRE

L-UNUSE

UNUSE

L-GASSIGNED?

L-NOISY

L-VERY-NOISY

L-TRANSLATIONS

L-USE-ABSTRACTS?

TRANSLATE

UNTRANSLATE

TRANSLATIONS

IN-COLLECTION

OBLIST

IOBLIST

DISMISS     ;"NPCK is loaded before INT."

<MOBLIST PACKAGE>

<MOBLIST PKG!-PACKAGE>

<BLOCK (<MOBLIST IPKG!-PKG!-PACKAGE> <MOBLIST PKG!-PACKAGE> <ROOT>)>

<PARSE "SEARCH!-PKG!-PACKAGE">

;" USED BY L PACKAGE "

<SETG PKG!-PACKAGE .OBLIST>

<SETG PKG-OB <MOBLIST PACKAGE>>

<SETG COL-OB <MOBLIST RPACKAGE>>

<SETG LAST-SEARCH-VAL <>>

<GDECL (LAST-SEARCH-VAL) <OR STRING CHANNEL VECTOR FALSE>>

<SETG L-SEARCH-PATH '([] ["USR" "MIMLIB"] ["USR" "MIM/MIMLIB"])>
<SETG L-SECOND-NAMES '["MSUBR" "MUD"]>
; "THIS IS SET UP FOR UNIX, BUT MDL.LOAD SHOULD STRAIGHTEN IT OUT"

<GDECL (L-SECOND-NAMES) VECTOR
       (L-SEARCH-PATH) <LIST [REST <OR STRING VECTOR>]>>

<SETG L-NO-FILES <>>

<SETG L-NOISY T>

<SETG L-VERY-NOISY <>>

<OR <GASSIGNED? L-TRANSLATIONS> <SETG L-TRANSLATIONS ()>>

;"THIS SHOULD BE SETG'ED TO T IN COMPILERS."

<OR <GASSIGNED? L-USE-ABSTRACTS?> <SETG L-USE-ABSTRACTS? <>>>

<PACKAGE "LIBRARY">

<ENTRY PACKAGE-FIND ENTRY-FIND DEFER-FIND FILE-FIND LIBRARY-OPEN
       PARSE-LIBRARY-NAME>

<RENTRY PUBLIC-LIBRARY>

<ENDPACKAGE>

<USE "LIBRARY">

<PACKAGE "SUBSTITUTE">

<ENTRY SUBSTITUTE>

<ENDPACKAGE>

<USE "SUBSTITUTE">

<DEFINE FIND/LOAD (STR:STRING
		   "OPT" (L:<OR LIST STRING> ,L-SEARCH-PATH)
			 (LACTION:<OR ATOM FALSE> %<>)
		   "AUX" RESULT CH:CHANNEL (TMP %<>)
			 (OUTCHAN:<SPECIAL CHANNEL> ,OUTCHAN)
			 (NO-LOAD:<SPECIAL ANY> <>)
			 (OBLIS:<LIST [REST OBLIST]> .OBLIST)
			 (TSTR:<OR STRING FALSE> <TRANSLATE? .STR>)
			 (TL:<OR FALSE LIST> %<>)
		   "NAME" FL)
   <COND (<AND .TSTR
	       <SET TMP <LOOKUP .TSTR ,PKG-OB>>
	       <GASSIGNED? .TMP>
	       <NOT <GETPROP <SET TL ,.TMP> NOT-LOADED>>>
	  <RETURN .TMP .FL>)>
   <SETG LAST-SEARCH-VAL <>>
   <COND (<TYPE? .L STRING> <SET RESULT <PACKAGE-DO-OPEN .L>>)
	 (<SET RESULT <SEARCH .STR .L .LACTION>>)>
   <COND (<NOT <TYPE? .RESULT CHANNEL>> <RETURN .RESULT .FL>)>
   <SET CH .RESULT>
   <COND (<OR ,L-NOISY ,L-VERY-NOISY>
	  <PRINC "/">
	  <PRINC .STR>
	  <COND (<N==? .STR .TSTR>
		 <PRINC !\=>
		 <PRINC .TSTR>)>
	  <COND (<AND ,L-VERY-NOISY ,LAST-SEARCH-VAL>
		 <PRINC !\=>
		 <BIND ((LSV:<OR STRING CHANNEL VECTOR FALSE> ,LAST-SEARCH-VAL))
		    <COND (<TYPE? .LSV STRING> <PRINC .LSV>)
			  (<TYPE? .LSV CHANNEL> <PRINC <CHANNEL-OP .LSV NAME>>)
			  (T <PRINC .STR>)>>
		 <CRLF>)
		(T <PRINC !\ >)>)>
   <COND (.TL <PUTPROP .TL NOT-LOADED>)>
   <UNWIND <BIND ((PKO:OBLIST ,PKG-OB)
		  (LOADER <AND <GASSIGNED? L-LOADER> ,L-LOADER>))
	      <COND (<AND .LOADER <APPLICABLE? .LOADER>>
		     <APPLY .LOADER .CH>
		     <AND <CHANNEL-OPEN? .CH> <CLOSE .CH>>)
		    (<LOAD .CH>
		     <CLOSE .CH>)>
	      <COND (.TSTR
		     <OR <SET TMP <LOOKUP .TSTR .PKO>>
			 <BIND ()
			    <SET TMP <INSERT .TSTR .PKO>>
			    <SETG .TMP .OBLIS>
			    .TMP>>
		     .TMP)
		    (T)>>
	   <BIND ()
	      <SET OBLIST .OBLIS>
	      <AND <CHANNEL-OPEN? .CH> <CLOSE .CH>>>>>

<DEFINE PACKAGE-DO-OPEN (FNM:STRING
			 "OPT" (LSN:<OR STRING <VECTOR [REST STRING]>>
				,L-SECOND-NAMES)
			 "AUX" CH:<OR CHANNEL FALSE> NM2:<SPECIAL STRING>
			 "NAME" PDO)
   <COND (,L-USE-ABSTRACTS?
	  <SET NM2 "ABSTR">
	  <COND (<SET CH <OPEN "READ" .FNM>> <RETURN .CH .PDO>)>)>
   <COND (<TYPE? .LSN STRING>
	  <SET LSN [.LSN]>)>
   <MAPF %<>
	 <FUNCTION (NM:STRING)
	    <SET NM2 .NM>
	    <COND (<SET CH <OPEN "READ" .FNM>> <MAPLEAVE>)>>
	 .LSN>
   .CH>

<DEFINE SEARCH (IND L:<LIST [REST <OR STRING VECTOR>]>
		"OPT" (LACTION:<OR ATOM FALSE> %<>)
		"AUX" ODEV:STRING OSNM:STRING)
   <COND (<ASSIGNED? SNM> <SET OSNM .SNM>)
	 (<GASSIGNED? SNM> <SET OSNM ,SNM>)
	 (<SET OSNM "">)>
   <COND (<ASSIGNED? DEV> <SET ODEV .DEV>)
	 (<GASSIGNED? DEV> <SET ODEV ,DEV>)
	 (<SET ODEV "">)>
   <REPEAT (RESULT:<OR CHANNEL VECTOR FALSE> SPEC:<OR STRING VECTOR>
	    SNM:<SPECIAL STRING> DEV:<SPECIAL STRING> (L-NO-FILES ,L-NO-FILES))
      <COND (<EMPTY? .OSNM> <UNASSIGN SNM>)
	    (<SET SNM .OSNM>)>
      <COND (<EMPTY? .ODEV> <UNASSIGN DEV>)
	    (<SET DEV .ODEV>)>
      <COND (<EMPTY? .L> <RETURN %<>>)>
      <COND (<TYPE? <SET SPEC <1 .L>> STRING>
	     <COND (<AND <==? .LACTION PACKAGE-FIND>
			 <GASSIGNED? PACKAGE-FIND>
			 <SET RESULT <PACKAGE-FIND .IND .SPEC>>>
		    <SETG LAST-SEARCH-VAL .RESULT>
		    <RETURN .RESULT>)
		   (<AND <==? .LACTION FILE-FIND>
			 <GASSIGNED? FILE-FIND>
			 <SET RESULT <FILE-FIND .IND .SPEC ,L-SECOND-NAMES>>>
		    <SETG LAST-SEARCH-VAL .RESULT>
		    <RETURN .RESULT>)
		   (<AND <==? .LACTION DEFER-FIND>
			 <GASSIGNED? DEFER-FIND>
			 <SET RESULT <DEFER-FIND .IND .SPEC>>>
		    <SETG LAST-SEARCH-VAL .RESULT>
		    <RETURN .RESULT>)>)
	    (<NOT .L-NO-FILES>
	     <COND (<OR <EMPTY? .SPEC> <NOT <1 .SPEC>>>)
		   (<==? <LENGTH .SPEC> 1> <SET SNM <1 .SPEC>>)
		   (<SET SNM <2 .SPEC>> <SET DEV <1 .SPEC>>)>
	     <COND (<L=? <LENGTH .SPEC> 2> <SET SPEC ,L-SECOND-NAMES>)
		   (<SET SPEC <REST .SPEC 2>>)>
	     <COND (<SET RESULT <PACKAGE-DO-OPEN .IND .SPEC>>
		    <SETG LAST-SEARCH-VAL .RESULT>
		    <RETURN .RESULT>)>)>
      <SET L <REST .L>>>>

<DEFINE L-OPEN (PACKAGE:STRING)
   <SEARCH .PACKAGE ,L-SEARCH-PATH FILE-FIND>>

<DEFINE L-FLOAD (PACKAGE:STRING "AUX" CHN:<OR CHANNEL FALSE>)
   <COND (<SET CHN <L-OPEN .PACKAGE>>
	  <UNWIND <BIND ()
		     <LOAD .CHN>
		     <CLOSE .CHN>
		     "DONE">
		  <COND (<CHANNEL-OPEN? .CHN> <CLOSE .CHN>)>>)
	 (<ERROR FILE-NOT-FOUND!-ERRORS .PACKAGE L-FLOAD>)>>

<DEFINE DEFINITIONS (NAME:STRING "VALUE" ATOM
		     "AUX" (TNAME:<OR FALSE STRING> <TRANSLATE? .NAME>) ATM:ATOM
			   OBL:OBLIST TMP:LIST (OBLIS:LIST .OBLIST))
   <COND (.TNAME
	  <SET ATM <OR <LOOKUP .TNAME ,PKG-OB> <INSERT .TNAME ,PKG-OB>>>
	  <SET OBL <MOBLIST .ATM>>
	  <PUTPROP .OBL DEFINITIONS DEFINITIONS>
	  <BLOCK <SETG .ATM <SET TMP (.OBL <ROOT>)>>>
	  <COND (<AND <ASSIGNED? NO-LOAD> .NO-LOAD>
		 <PUTPROP .TMP NOT-LOADED NOT-LOADED>)>)
	 (<BLOCK <SET TMP (<1 .OBLIS> !.OBLIS)>> <SET ATM T>)>
   <PUTPROP .TMP IN-COLLECTION .ATM>
   .ATM>

<DEFINE PACKAGE (NAME:STRING
		 "OPT" (INAME:STRING .NAME) "VALUE" ATOM
		 "AUX" (TNAME:<OR FALSE STRING> <TRANSLATE? .NAME>) ATM:ATOM
		       IATM:ATOM OBL:OBLIST IOBL:OBLIST TMP:LIST
		       (OBLIS:LIST .OBLIST))
   <COND (.TNAME
	  <COND (<==? .INAME .NAME> <SET INAME <STRING !\I .TNAME>>)>
	  <SET ATM <OR <LOOKUP .TNAME ,PKG-OB> <INSERT .TNAME ,PKG-OB>>>
	  <SET OBL <MOBLIST .ATM>>
	  <SET IATM <OR <LOOKUP .INAME .OBL> <INSERT .INAME .OBL>>>
	  <SET IOBL <MOBLIST .IATM>>
	  <BLOCK <SETG .ATM <SET TMP (.IOBL .OBL <ROOT>)>>>
	  <COND (<AND <ASSIGNED? NO-LOAD> .NO-LOAD>
		 <PUTPROP .TMP NOT-LOADED NOT-LOADED>)>)
	 (<BLOCK <SET TMP (<1 .OBLIS> !.OBLIS)>> <SET ATM T>)>
   <COND (.TNAME <PUTPROP .ATM IOBLIST .IOBL>)>
   <PUTPROP .TMP IN-COLLECTION .ATM>
   .ATM>

<DEFINE RPACKAGE (NAME:STRING
		  "OPT" (INAME:STRING .NAME) "VALUE" ATOM
		  "AUX" ATM:ATOM IATM:ATOM IOBL:OBLIST
			(TNAME:<OR STRING FALSE> <TRANSLATE? .NAME>) TMP)
   <COND (.TNAME
	  <COND (<==? .NAME .INAME> <SET INAME <STRING !\I .NAME>>)>
	  <SET ATM <OR <LOOKUP .TNAME ,PKG-OB> <INSERT .TNAME ,PKG-OB>>>
	  <SET IATM <OR <LOOKUP .INAME ,COL-OB> <INSERT .INAME ,COL-OB>>>
	  <SET IOBL <MOBLIST .IATM>>
	  <BLOCK <SETG .ATM <SET TMP (.IOBL <ROOT>)>>>
	  <COND (<AND <ASSIGNED? NO-LOAD> .NO-LOAD>
		 <PUTPROP .TMP NOT-LOADED NOT-LOADED>)>
	  <PUTPROP .ATM IOBLIST .IOBL>)
	 (<BLOCK <SET TMP (<1 .OBLIST> <ROOT>)>> <SET ATM T>)>
   <PUTPROP .TMP IN-COLLECTION .ATM>
   .ATM>

<DEFINE SURVIVOR ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]>)
   T>

<DEFINE RENTRY ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> "VALUE" ATOM)
   <DO-ENTRY .NAMES <ROOT>>>

<DEFINE ENTRY ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> "VALUE" ATOM)
   <COND (<NOT <GETPROP <2 .OBLIST> DEFINITIONS>>
	  <DO-ENTRY .NAMES <2 .OBLIST>>)>>

<DEFINE DO-ENTRY (NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> OBL:OBLIST
		  "AUX" (OBLIS:LIST .OBLIST) (NAME:ATOM T) "VALUE" ATOM)
   <PUTPROP .OBL USE-DEFER>
   <COND (<NOT <GETPROP .OBLIS IN-COLLECTION>>
	  <ERROR ENTRY NOT-IN-PACKAGE-OR-COLLECTION!-ERRORS>)>
   <REPEAT ()
      <COND (<EMPTY? .NAMES> <RETURN .NAME>)>
      <SET NAME <1 .NAMES>>
      <SET NAMES <REST .NAMES>>
      <COND (<==? .OBL <ROOT>> <PUTPROP .NAME USE-DEFER>)>
      <COND (<==? <OBLIST? .NAME> <1 .OBLIS>>
	     <INSERT <REMOVE .NAME> .OBL>)
	    (<NOT <==? <OBLIST? .NAME> .OBL>>
	     <ERROR ENTRY .NAME ALREADY-USED-ELSEWHERE!-ERRORS>)>>>

<DEFINE DO-EXPORTS (PKNAME:ATOM
		    "AUX" (L:<OR LIST FALSE> <GETPROP .PKNAME EXPORT>))
   <COND (<AND .L <NOT <EMPTY? .L>>>
	  <USE !.L>)>>

<DEFINE EXPORT ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
		"AUX" VAL:ATOM PCK:<OR ATOM FALSE> L:<OR FALSE LIST>)
   <SET VAL <USE !.NAMES>>
   <COND (<SET PCK <GETPROP .OBLIST IN-COLLECTION>>
	  <COND (<AND <SET L <GETPROP .PCK EXPORT>> <NOT <EMPTY? .L>>>
		 <PUTREST <REST .L <- <LENGTH .L> 1>> <LIST !.NAMES>>)
		(T
		 <PUTPROP .PCK EXPORT <LIST !.NAMES>>)>)>
   .VAL>

<DEFINE INCLUDE-WHEN ('FOO "TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
   <COND (<EVAL .FOO> <INCLUDE !.NAMES>)>>

<DEFINE USE-WHEN ('FOO "TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
   <COND (<EVAL .FOO> <USE !.NAMES>)>>

<DEFINE USE-DEBUG ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
		   "AUX" (DEBUGGING?:<SPECIAL ANY> T))
   <USE !.NAMES>>

<DEFINE INCLUDE-DEBUG ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
		       "AUX" (DEBUGGING?:<SPECIAL ANY> T))
   <INCLUDE !.NAMES>>

<DEFINE COMPILING? (X) T>

<DEFINE DEBUGGING? (X)
   <AND <ASSIGNED? DEBUGGING?> .DEBUGGING?>>

<DEFINE INCLUDE ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]> "VALUE" ATOM
		 "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) NAME:STRING
		       PK:<OR ATOM FALSE> OBL:<OR OBLIST FALSE> N:FIX M:FIX)
   <REPEAT ((L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
      <COND (<EMPTY? .NAMES> <RETURN INCLUDE>)>
      <SET NAME <1 .NAMES>>
      <SET NAMES <REST .NAMES>>
      <SET PK <FIND/LOAD .NAME .L-SP FILE-FIND>>
      <COND (<NOT .PK> <ERROR DEFINITIONS .NAME NOT-FOUND!-ERRORS>)
	    (<==? .PK T>)
	    (<NOT <GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>>
	     <ERROR NOT-A-DEFINITION-MODULE!-ERRORS .PK INCLUDE>
	     <SET PK %<>>)
	    (<NOT <MEMQ .OBL .OBLIST>>
	     <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
		    <PUTREST <REST .OBLIS <- <SET M <LENGTH .OBLIS>> .N 1>>
			     (.OBL !<REST .OBLIS <- .M .N>>)>)
		   (T
		    <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (.OBL)>)>)>
      <COND (.PK
	     <DO-EXPORTS .PK>)>>>

<DEFINE USE ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]> "VALUE" ATOM
	     "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) NAME:STRING
	     PK:<OR ATOM FALSE> OBL:<OR FALSE OBLIST> N:FIX M:FIX)
   <REPEAT ((L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
      <COND (<EMPTY? .NAMES> <RETURN USE>)>
      <SET NAME <1 .NAMES>>
      <SET NAMES <REST .NAMES>>
      <SET PK <FIND/LOAD .NAME .L-SP PACKAGE-FIND>>
      <COND (<NOT .PK> <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>)
	    (<==? .PK T>)
	    (<GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>
	     <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .PK USE>
	     <SET PK %<>>)
	    (<NOT <MEMQ .OBL .OBLIS>>
	     <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
		    <PUTREST <REST .OBLIS <- <SET M <LENGTH .OBLIS>> .N 1>>
			     (.OBL !<REST .OBLIS <- .M .N>>)>)
		   (T
		    <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (.OBL)>)>)>
      <COND (.PK
	     <DO-EXPORTS .PK>)>>>

<DEFINE USE-DEFER ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
   <COND (,L-NO-MAGIC <USE !.NAMES>)
	 (T
	  <REPEAT (NAME:STRING RESULT OBL:<OR ATOM OBLIST>
		   (L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
	     <COND (<EMPTY? .NAMES> <RETURN USE-DEFER>)>
	     <SET NAME <1 .NAMES>>
	     <SET NAMES <REST .NAMES>>
	     <SET RESULT <FIND/LOAD .NAME .L-SP DEFER-FIND>>
	     <COND (<==? .RESULT T>)
		   (<TYPE? .RESULT ATOM>
		    <USE .NAME>)
		   (<TYPE? .RESULT VECTOR>
		    <COND (<==? <1 .RESULT> PACKAGE>
			   <SET OBL <MOBLIST <PACKAGE <4 .RESULT>>>>
			   <MAPF %<>
				 <FUNCTION (E:STRING) <ENTRY <PARSE .E>>>
				 <2 .RESULT>:<LIST [REST STRING]>>
			   <MAPF %<>
				 <FUNCTION (R:STRING)
				    <PUTPROP <RENTRY <PARSE .R>>
					     USE-DEFER <REST .RESULT 3>>>
				 <3 .RESULT>:<LIST [REST STRING]>>
			   <ENDPACKAGE>
			   <USE .NAME>
			   <PUTPROP .OBL USE-DEFER <REST .RESULT 3>>
			   <COND (<GASSIGNED? <SET OBL <CHTYPE .OBL ATOM>>>
				  <PUTPROP ,.OBL NOT-LOADED NOT-LOADED>)>)
			  (T
			   <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .NAME USE-DEFER>)>)
		   (T
		    <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>)>>)>>

<DEFINE USE-TOTAL ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
		   "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) NAME:STRING
			 PK:<OR ATOM FALSE> OBL:<OR FALSE OBLIST>
			 IOBL:<OR FALSE OBLIST> N:FIX M:FIX)
   <REPEAT (INAME:STRING (L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
      <COND (<EMPTY? .NAMES> <RETURN USE-TOTAL>)>
      <SET NAME <1 .NAMES>>
      <SET NAMES <REST .NAMES>>
      <SET PK <FIND/LOAD .NAME .L-SP PACKAGE-FIND>>
      <COND (<NOT .PK> <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>
	     <AGAIN>)
	    (<==? .PK T>)
	    (<GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>
	     <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .PK USE-TOTAL>
	     <AGAIN>)
	    (<NOT <MEMQ <SET OBL <MOBLIST .PK>> .OBLIS>>
	     <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
		    <PUTREST <REST .OBLIS
				   <- <SET M <LENGTH .OBLIS>> .N 1>>
			     (.OBL !<REST .OBLIS <- .M .N>>)>)
		   (T
		    <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>>
			     (.OBL)>)>)>
      <SET INAME <STRING !\I .NAME>>
      <SET IOBL <MOBLIST <LOOKUP .INAME .OBL>>>
      <COND (<NOT <MEMQ .IOBL .OBLIS>>
	     <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
		    <PUTREST <REST .OBLIS
				   <- <SET M <LENGTH .OBLIS>> .N 1>>
			     (.IOBL !<REST .OBLIS <- .M .N>>)>)
		   (T
		    <PUTREST <REST .OBLIS
				   <- <LENGTH .OBLIS> 1>> (.IOBL)>)>)>
      <COND (.PK
	     <DO-EXPORTS .PK>)>>>

<DEFINE L-GASSIGNED? (ATM:ATOM
		      "AUX" O:<OR OBLIST FALSE>
			    TMP:<OR FALSE <VECTOR [2 STRING]>>)
   <COND (<GASSIGNED? .ATM>)
	 (<SET TMP <COND (<==? <SET O <OBLIST? .ATM>> <ROOT>>
			  <GETPROP .ATM USE-DEFER>)
			 (.O <GETPROP .O USE-DEFER>)>>
	  <FIND/LOAD <1 .TMP> (<2 .TMP>) FILE-FIND>
	  <USE <1 .TMP>>
	  <COND (<NOT <GASSIGNED? .ATM>>
		 <ERROR PACKAGE "PACKAGE DID NOT DEFINE FUNCTION">)>
	  T)>>

<SETG EXTERNAL ,USE>

<DEFINE DROP ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]> "VALUE" ATOM
	      "AUX" NAME:<OR STRING FALSE> PK:<OR ATOM FALSE>
		    OBL:<OR FALSE OBLIST> IOBL:<OR FALSE OBLIST> N:FIX)
   <REPEAT ((OBLIS:<LIST [REST OBLIST]> .OBLIST))
      <COND (<EMPTY? .NAMES> <RETURN DROP>)>
      <SET NAME <TRANSLATE? <1 .NAMES>>>
      <SET NAMES <REST .NAMES>>
      <COND (<NOT .NAME> <AGAIN>)>
      <COND (<NOT <SET PK <LOOKUP .NAME ,PKG-OB>>>
	     <ERROR PACKAGE .NAME NOT-PACKAGE-OR-COLLECTION!-ERRORS>)>
      <SET OBL <MOBLIST .PK>>
      <COND (<NOT <0? <SET N <LENGTH <MEMQ .OBL .OBLIS>>>>>
	     <PUTREST <REST .OBLIS <SET N <- <LENGTH .OBLIS> .N 1>>>
		      <REST .OBLIS <+ .N 2>>>)>
      <COND (<SET IOBL <GETPROP .PK IOBLIST>>
	     <COND (<NOT <0? <SET N <LENGTH <MEMQ .IOBL .OBLIS>>>>>
		    <PUTREST <REST .OBLIS <SET N <- <LENGTH .OBLIS> .N 1>>>
			     <REST .OBLIS <+ .N 2>>>)>)>>>

<DEFINE END-DEFINITIONS ("OPT" (PKNM:<OR FALSE ATOM STRING> %<>))
   <ENDPACKAGE .PKNM>>

<DEFINE ENDPACKAGE ("OPT" (PKNM:<OR FALSE ATOM STRING> %<>)
		    "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) PK:<OR ATOM FALSE>)
   <REPEAT ()
      <COND (<SET PK <GETPROP .OBLIS IN-COLLECTION>>
	     <PUTPROP .OBLIS IN-COLLECTION>
	     <ENDBLOCK>
	     <SET OBLIS .OBLIST>
	     .PK)
	    (<TYPE? .PKNM ATOM> <RETURN>)
	    (T
	     <ERROR UNMATCHED-ENDPACKAGE-OR-ENDCOLLECTION!-ERRORS>
	     <RETURN>)>
      <COND (<OR <NOT .PKNM> <=? <SPNAME .PK> .PKNM>> <RETURN>)>>>

<DEFINE L-UNUSE (STR:<OR STRING FALSE>
		 "AUX" TMP ATM:<OR OBLIST FALSE> IATM:<OR OBLIST FALSE>)
   <SET STR <TRANSLATE? .STR>>
   <COND (<NOT .STR>)
	 (<AND <SET TMP <LOOKUP .STR ,PKG-OB>> <GASSIGNED? .TMP>>
	  <SET ATM <MOBLIST .TMP>>
	  <DROP .STR>
	  <SET IATM <GETPROP .TMP IOBLIST>>
	  <MAPF %<>
		<FUNCTION (L:LIST)
		   <MAPF %<>
			 <FUNCTION (A:<OR ATOM LINK>)
			    <COND (<OR <==? <OBLIST? .A> .ATM>
				       <==? <OBLIST? .A> .IATM>>
				   <REMOVE .A>)>>
			 .L>>
		,ATOM-TABLE>
	  <GUNASSIGN .TMP>
	  <PUTPROP .TMP IOBLIST>
	  <REMOVE .TMP ,PKG-OB>
	  "PACKAGE REMOVED")
	 (T #FALSE ("NOT PACKAGE OR DATUM"))>>

<SETG UNUSE ,L-UNUSE>

<DEFINE TRANSLATE? (NAME:STRING
		    "AUX" (L:<LIST [REST STRING <OR STRING FALSE>]>
			   ,L-TRANSLATIONS))
   <REPEAT ()
      <COND (<EMPTY? .L> <RETURN .NAME>)
	    (<=? <1 .L>:STRING .NAME> <RETURN <2 .L>>)>
      <SET L <REST .L 2>>>>

<DEFINE TRANSLATE (FROM:STRING TO:<OR FALSE STRING>
		   "AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
			  ,L-TRANSLATIONS) (OUTCHAN:CHANNEL ,OUTCHAN))
   <REPEAT ()
      <COND (<EMPTY? .L>
	     <SETG L-TRANSLATIONS (.FROM .TO !,L-TRANSLATIONS)>
	     <RETURN>)
	    (<=? <1 .L>:STRING .FROM> <PUT .L 2 .TO> <RETURN>)>
      <SET L <REST .L 2>>>
   <PRINC .FROM>
   <PRINC " --> ">
   <PRINC .TO>
   <CRLF>>

<DEFINE UNTRANSLATE ("OPT" (NAME:STRING "")
		     "AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
			    ,L-TRANSLATIONS))
   <COND (<EMPTY? .NAME>
	  <SETG L-TRANSLATIONS '()>
	  <PRINC "All gone">
	  <CRLF>)
	 (T
	  <REPEAT ((L1:<LIST [REST STRING <OR FALSE STRING>]> .L)
		   L2:<LIST [REST <OR FALSE STRING>]>)
	     <COND (<EMPTY? .L1> <RETURN #FALSE ("NOT TRANSLATED")>)
		   (<=? <1 .L1>:STRING .NAME>
		    <COND (<==? .L .L1>
			   <SETG L-TRANSLATIONS <REST .L 2>>)
			  (<PUTREST <REST .L2> <REST .L1 2>>)>
		    <RETURN .NAME>)>
	     <SET L2 .L1>
	     <SET L1 <REST .L1 2>>>)>>

<DEFINE TRANSLATIONS ("AUX" (L:<LIST [REST STRING <OR STRING FALSE>]>
			     ,L-TRANSLATIONS) (OUTCHAN:CHANNEL ,OUTCHAN))
   <COND (<EMPTY? .L> <PRINC "No translations"> <CRLF>)
	 (T
	  <REPEAT ()
	     <PRINC <1 .L>>
	     <PRINC " --> ">
	     <PRINC <2 .L>>
	     <CRLF>
	     <COND (<EMPTY? <SET L <REST .L 2>>> <RETURN>)>>)>>

<DEFINE L-ERROR-HANDLER (IGNORE FRM:FRAME "TUPLE" STUFF:<PRIMTYPE VECTOR>)
   <COND (<AND <NOT ,L-NO-MAGIC>
	       <G=? <LENGTH .STUFF> 3>
	       <==? <1 .STUFF> UNASSIGNED-VARIABLE!-ERRORS>
	       <==? <3 .STUFF> GVAL>
	       <TYPE? <2 .STUFF> ATOM>>
	  <TRY-DEFER-LOAD <2 .STUFF> .FRM>
	  <TRY-OOPS <2 .STUFF> .FRM>
	  <TRY-ENTRY-FIND <2 .STUFF> .FRM>)>>

<DEFINE TRY-OOPS (WRONG:ATOM FRM:FRAME
		  "AUX" RIGHT:<OR ATOM FALSE> (PNAME:STRING <SPNAME .WRONG>)
			(OUTCHAN:CHANNEL ,OUTCHAN))
   <MAPF %<>
	 <FUNCTION (POSS:<OR ATOM LINK>)
	    <COND (<AND <TYPE? .POSS ATOM>
			<=? <SPNAME .POSS> .PNAME>
			<GASSIGNED? .POSS>
			<N==? <OBLIST? .POSS> <MOBLIST PACKAGE>>>
		   ;"accept the first atom with the same name that has a gval,
		     (but not the package oblist atom)."
		   <SET RIGHT .POSS>
		   <MAPLEAVE>)>>
	 <NTH ,ATOM-TABLE:VECTOR 
	      <HASH-NAME .PNAME <LENGTH ,ATOM-TABLE:VECTOR>>>:LIST>
   <COND (<ASSIGNED? RIGHT>
	  <COND (,L-NOISY
		 ;"let the user know we're making a gval substitution"
		 <PRINC .RIGHT .OUTCHAN>
		 <PRINC ":  " .OUTCHAN>
		 <PRIN1 <OBLIST? .WRONG> .OUTCHAN>
		 <PRINC "->" .OUTCHAN>
		 <PRIN1 <OBLIST? .RIGHT> .OUTCHAN>
		 <CRLF .OUTCHAN>)>
	  <COND (<OBLIST? .RIGHT>
		 <SET PNAME <SPNAME <CHTYPE <OBLIST? .RIGHT> ATOM>>>
		 <MAYBE-USE/INCLUDE .RIGHT .WRONG .PNAME>)>
	  <DISMISS ,.RIGHT .FRM>)>>

<DEFINE TRY-DEFER-LOAD (WRONG:ATOM FRM:FRAME "AUX" DEFER:<OR VECTOR FALSE>)
   <COND (<AND <SET DEFER <OR <GETPROP <OBLIST? .WRONG> USE-DEFER>
			      <GETPROP .WRONG USE-DEFER>>>
	       <FIND/LOAD <1 .DEFER> (<2 .DEFER>) FILE-FIND>
	       <USE <1 .DEFER>>
	       <GASSIGNED? .WRONG>>
	  <DISMISS ,.WRONG .FRM>)>>

<DEFINE TRY-ENTRY-FIND (WRONG:ATOM FRM:FRAME)
   <REPEAT ((L-SP:LIST ,L-SEARCH-PATH) SPEC:<OR VECTOR STRING>
	    (WRONG-NAME:STRING <SPNAME .WRONG>) EDATA:<OR FALSE LIST>
	    EDESC:<OR <VECTOR FIX [2 STRING]> FALSE> RIGHT:<OR ATOM FALSE>
	    OBL:<OR OBLIST ATOM FALSE>)
      <COND (<EMPTY? .L-SP> <RETURN>)>
      <SET SPEC <1 .L-SP>>
      <SET L-SP <REST .L-SP>>
      <COND (<TYPE? .SPEC STRING>
	     <COND (<AND <GASSIGNED? ENTRY-FIND>
			 <SET EDATA <ENTRY-FIND .WRONG-NAME .SPEC T>>
			 <SET EDESC <PICK-DESCRIPTOR .WRONG .EDATA>>
			 <SET OBL <FIND/LOAD <2 .EDESC> (.SPEC) FILE-FIND>>>
		    <SET OBL <MOBLIST .OBL>>
		    <COND (<==? <ANDB <1 .EDESC> *40000*> 0>	;"Rentry?"
			   <SET RIGHT <LOOKUP .WRONG-NAME <ROOT>>>)
			  (T
			   <SET RIGHT <LOOKUP .WRONG-NAME .OBL>>)>
		    <COND (<AND .RIGHT <GASSIGNED? .RIGHT>>
			   <MAYBE-USE/INCLUDE .RIGHT .WRONG <2 .EDESC>>
			   <DISMISS ,.RIGHT .FRM>)>)>)>>>

<DEFINE MAYBE-USE/INCLUDE (RIGHT:ATOM WRONG:ATOM OBNAME:STRING
			   "AUX" (OBLIS:LIST .OBLIST) (OUTCHAN .OUTCHAN)
				 OBL:<OR OBLIST FALSE ATOM>
				 (TOBNAME:<OR STRING FALSE> <TRANSLATE? .OBNAME>))
   <COND (<AND <NOT <EMPTY? .OBLIS>>
	       <==? <OBLIST? .WRONG> <1 .OBLIS>>
	       <OR <AND .TOBNAME <SET OBL <LOOKUP .TOBNAME <MOBLIST PACKAGE>>>>
		   <SET OBL <LOOKUP .OBNAME <MOBLIST PACKAGE>>>>>
	  <COND (<GETPROP <SET OBL <MOBLIST .OBL>> DEFINITIONS>
		 <INCLUDE .OBNAME>)
		(<==? .OBL <OBLIST? .RIGHT>>
		 <USE .OBNAME>)
		(<NOT <==? <OBLIST? .RIGHT> <ROOT>>>
		 <USE-TOTAL .OBNAME>)>)>
   <COND (<AND <SET OBL <OBLIST? .WRONG>>
	       <SET OBL <OBLIST? <CHTYPE .OBL ATOM>>>
	       <==? <OBLIST? <SET OBL <CHTYPE .OBL ATOM>>> <MOBLIST PACKAGE>>
	       <GASSIGNED? .OBL>
	       <NOT <MEMQ <OBLIST? .RIGHT> <SET OBLIS ,.OBL>>>
	       <NOT <EMPTY? .OBLIS>>>
	  <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (<OBLIST? .RIGHT>)>)>
   <COND (<N==? .RIGHT .WRONG>
	  <COND (<GASSIGNED? SUBSTITUTE>
		 <SUBSTITUTE .RIGHT <REMOVE .WRONG>>)
		(T 
		 <SETG .WRONG ,.RIGHT>)>)>
   .RIGHT>

<DEFINE PICK-DESCRIPTOR (WRONG:ATOM EDATA:<LIST [REST <VECTOR FIX [2 STRING]>]>
			 "AUX" (OUTCHAN:CHANNEL ,OUTCHAN) RESPONSE)
   <COND (<EMPTY? .EDATA> %<>)
	 (<AND <NOT ,L-ALWAYS-INQUIRE> <LENGTH? .EDATA 1>>
	  <1 .EDATA>)
	 (T
	  <CRLF .OUTCHAN>
	  <PRINC "DYNAMIC LOADER:  " .OUTCHAN>
	  <PRINC .WRONG .OUTCHAN>
	  <PRINC " in modules:" .OUTCHAN>
	  <REPEAT ((E:LIST .EDATA) D:<VECTOR FIX [2 STRING]> (C:FIX 1))
	     <COND (<EMPTY? .E>
		    <CRLF .OUTCHAN>
		    <PRINC !\[ .OUTCHAN>
		    <PRINC .C .OUTCHAN>
		    <PRINTSTRING "] call ERROR" .OUTCHAN>
		    <CRLF .OUTCHAN>
		    <PRINC "Module number <ESC>: " .OUTCHAN>
		    <COND (<AND <TYPE? <SET RESPONSE <READ>> FIX>
				<G? .RESPONSE 0>
				<L=? .RESPONSE <LENGTH .EDATA>>>
			   <RETURN <NTH .EDATA .RESPONSE>>)>
		    <RETURN %<>>)
		   (T
		    <SET D <1 .E>>
		    <SET E <REST .E>>
		    <CRLF .OUTCHAN>
		    <PRINC !\[ .OUTCHAN>
		    <PRINC .C .OUTCHAN>
		    <PRINTSTRING "] " .OUTCHAN>
		    <PRINTSTRING <2 .D> .OUTCHAN>
		    <SET C <+ .C 1>>)>>)>>

<SETG L-NO-MAGIC <>>

<SETG L-ALWAYS-INQUIRE <>>

<SETG IOB <MOBLIST <LOOKUP "INITIAL" <ROOT>>>>

<ENDBLOCK>

<ENDBLOCK>

<SET OBLIST ,OBLIST>