--- /dev/null
+
+; " 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
+\f
+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>>
+\f
+<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">
+\f
+<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>>>>>
+\f
+<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>>
+\f
+<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>>>
+\f
+<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?>>
+\f
+<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>)>>>
+\f
+<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>)>>>
+\f
+<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>)>>>
+\f
+<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>>>)>>
+\f
+<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>)>>
+\f
+<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>
+\f
+<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>
projects / pdp10-muddle.git / blobdiff