2 ; " This is the PACKAGE handling routines, written in MIM. "
3 ; " For documentaton, see The MDL Programming environment [Lebling 80]. "
97 DISMISS ;"NPCK is loaded before INT."
101 <MOBLIST PKG!-PACKAGE>
103 <BLOCK (<MOBLIST IPKG!-PKG!-PACKAGE> <MOBLIST PKG!-PACKAGE> <ROOT>)>
105 <PARSE "SEARCH!-PKG!-PACKAGE">
107 ;" USED BY L PACKAGE "
109 <SETG PKG!-PACKAGE .OBLIST>
111 <SETG PKG-OB <MOBLIST PACKAGE>>
113 <SETG COL-OB <MOBLIST RPACKAGE>>
115 <SETG LAST-SEARCH-VAL <>>
117 <GDECL (LAST-SEARCH-VAL) <OR STRING CHANNEL VECTOR FALSE>>
119 <SETG L-SEARCH-PATH '([] ["USR" "MIMLIB"] ["USR" "MIM/MIMLIB"])>
120 <SETG L-SECOND-NAMES '["MSUBR" "MUD"]>
121 ; "THIS IS SET UP FOR UNIX, BUT MDL.LOAD SHOULD STRAIGHTEN IT OUT"
123 <GDECL (L-SECOND-NAMES) VECTOR
124 (L-SEARCH-PATH) <LIST [REST <OR STRING VECTOR>]>>
130 <SETG L-VERY-NOISY <>>
132 <OR <GASSIGNED? L-TRANSLATIONS> <SETG L-TRANSLATIONS ()>>
134 ;"THIS SHOULD BE SETG'ED TO T IN COMPILERS."
136 <OR <GASSIGNED? L-USE-ABSTRACTS?> <SETG L-USE-ABSTRACTS? <>>>
140 <ENTRY PACKAGE-FIND ENTRY-FIND DEFER-FIND FILE-FIND LIBRARY-OPEN
143 <RENTRY PUBLIC-LIBRARY>
149 <PACKAGE "SUBSTITUTE">
157 <DEFINE FIND/LOAD (STR:STRING
158 "OPT" (L:<OR LIST STRING> ,L-SEARCH-PATH)
159 (LACTION:<OR ATOM FALSE> %<>)
160 "AUX" RESULT CH:CHANNEL (TMP %<>)
161 (OUTCHAN:<SPECIAL CHANNEL> ,OUTCHAN)
162 (NO-LOAD:<SPECIAL ANY> <>)
163 (OBLIS:<LIST [REST OBLIST]> .OBLIST)
164 (TSTR:<OR STRING FALSE> <TRANSLATE? .STR>)
165 (TL:<OR FALSE LIST> %<>)
168 <SET TMP <LOOKUP .TSTR ,PKG-OB>>
170 <NOT <GETPROP <SET TL ,.TMP> NOT-LOADED>>>
172 <SETG LAST-SEARCH-VAL <>>
173 <COND (<TYPE? .L STRING> <SET RESULT <PACKAGE-DO-OPEN .L>>)
174 (<SET RESULT <SEARCH .STR .L .LACTION>>)>
175 <COND (<NOT <TYPE? .RESULT CHANNEL>> <RETURN .RESULT .FL>)>
177 <COND (<OR ,L-NOISY ,L-VERY-NOISY>
180 <COND (<N==? .STR .TSTR>
183 <COND (<AND ,L-VERY-NOISY ,LAST-SEARCH-VAL>
185 <BIND ((LSV:<OR STRING CHANNEL VECTOR FALSE> ,LAST-SEARCH-VAL))
186 <COND (<TYPE? .LSV STRING> <PRINC .LSV>)
187 (<TYPE? .LSV CHANNEL> <PRINC <CHANNEL-OP .LSV NAME>>)
191 <COND (.TL <PUTPROP .TL NOT-LOADED>)>
192 <UNWIND <BIND ((PKO:OBLIST ,PKG-OB)
193 (LOADER <AND <GASSIGNED? L-LOADER> ,L-LOADER>))
194 <COND (<AND .LOADER <APPLICABLE? .LOADER>>
196 <AND <CHANNEL-OPEN? .CH> <CLOSE .CH>>)
200 <OR <SET TMP <LOOKUP .TSTR .PKO>>
202 <SET TMP <INSERT .TSTR .PKO>>
209 <AND <CHANNEL-OPEN? .CH> <CLOSE .CH>>>>>
211 <DEFINE PACKAGE-DO-OPEN (FNM:STRING
212 "OPT" (LSN:<OR STRING <VECTOR [REST STRING]>>
214 "AUX" CH:<OR CHANNEL FALSE> NM2:<SPECIAL STRING>
216 <COND (,L-USE-ABSTRACTS?
218 <COND (<SET CH <OPEN "READ" .FNM>> <RETURN .CH .PDO>)>)>
219 <COND (<TYPE? .LSN STRING>
222 <FUNCTION (NM:STRING)
224 <COND (<SET CH <OPEN "READ" .FNM>> <MAPLEAVE>)>>
228 <DEFINE SEARCH (IND L:<LIST [REST <OR STRING VECTOR>]>
229 "OPT" (LACTION:<OR ATOM FALSE> %<>)
230 "AUX" ODEV:STRING OSNM:STRING)
231 <COND (<ASSIGNED? SNM> <SET OSNM .SNM>)
232 (<GASSIGNED? SNM> <SET OSNM ,SNM>)
234 <COND (<ASSIGNED? DEV> <SET ODEV .DEV>)
235 (<GASSIGNED? DEV> <SET ODEV ,DEV>)
237 <REPEAT (RESULT:<OR CHANNEL VECTOR FALSE> SPEC:<OR STRING VECTOR>
238 SNM:<SPECIAL STRING> DEV:<SPECIAL STRING> (L-NO-FILES ,L-NO-FILES))
239 <COND (<EMPTY? .OSNM> <UNASSIGN SNM>)
241 <COND (<EMPTY? .ODEV> <UNASSIGN DEV>)
243 <COND (<EMPTY? .L> <RETURN %<>>)>
244 <COND (<TYPE? <SET SPEC <1 .L>> STRING>
245 <COND (<AND <==? .LACTION PACKAGE-FIND>
246 <GASSIGNED? PACKAGE-FIND>
247 <SET RESULT <PACKAGE-FIND .IND .SPEC>>>
248 <SETG LAST-SEARCH-VAL .RESULT>
250 (<AND <==? .LACTION FILE-FIND>
251 <GASSIGNED? FILE-FIND>
252 <SET RESULT <FILE-FIND .IND .SPEC ,L-SECOND-NAMES>>>
253 <SETG LAST-SEARCH-VAL .RESULT>
255 (<AND <==? .LACTION DEFER-FIND>
256 <GASSIGNED? DEFER-FIND>
257 <SET RESULT <DEFER-FIND .IND .SPEC>>>
258 <SETG LAST-SEARCH-VAL .RESULT>
261 <COND (<OR <EMPTY? .SPEC> <NOT <1 .SPEC>>>)
262 (<==? <LENGTH .SPEC> 1> <SET SNM <1 .SPEC>>)
263 (<SET SNM <2 .SPEC>> <SET DEV <1 .SPEC>>)>
264 <COND (<L=? <LENGTH .SPEC> 2> <SET SPEC ,L-SECOND-NAMES>)
265 (<SET SPEC <REST .SPEC 2>>)>
266 <COND (<SET RESULT <PACKAGE-DO-OPEN .IND .SPEC>>
267 <SETG LAST-SEARCH-VAL .RESULT>
271 <DEFINE L-OPEN (PACKAGE:STRING)
272 <SEARCH .PACKAGE ,L-SEARCH-PATH FILE-FIND>>
274 <DEFINE L-FLOAD (PACKAGE:STRING "AUX" CHN:<OR CHANNEL FALSE>)
275 <COND (<SET CHN <L-OPEN .PACKAGE>>
280 <COND (<CHANNEL-OPEN? .CHN> <CLOSE .CHN>)>>)
281 (<ERROR FILE-NOT-FOUND!-ERRORS .PACKAGE L-FLOAD>)>>
283 <DEFINE DEFINITIONS (NAME:STRING "VALUE" ATOM
284 "AUX" (TNAME:<OR FALSE STRING> <TRANSLATE? .NAME>) ATM:ATOM
285 OBL:OBLIST TMP:LIST (OBLIS:LIST .OBLIST))
287 <SET ATM <OR <LOOKUP .TNAME ,PKG-OB> <INSERT .TNAME ,PKG-OB>>>
288 <SET OBL <MOBLIST .ATM>>
289 <PUTPROP .OBL DEFINITIONS DEFINITIONS>
290 <BLOCK <SETG .ATM <SET TMP (.OBL <ROOT>)>>>
291 <COND (<AND <ASSIGNED? NO-LOAD> .NO-LOAD>
292 <PUTPROP .TMP NOT-LOADED NOT-LOADED>)>)
293 (<BLOCK <SET TMP (<1 .OBLIS> !.OBLIS)>> <SET ATM T>)>
294 <PUTPROP .TMP IN-COLLECTION .ATM>
297 <DEFINE PACKAGE (NAME:STRING
298 "OPT" (INAME:STRING .NAME) "VALUE" ATOM
299 "AUX" (TNAME:<OR FALSE STRING> <TRANSLATE? .NAME>) ATM:ATOM
300 IATM:ATOM OBL:OBLIST IOBL:OBLIST TMP:LIST
301 (OBLIS:LIST .OBLIST))
303 <COND (<==? .INAME .NAME> <SET INAME <STRING !\I .TNAME>>)>
304 <SET ATM <OR <LOOKUP .TNAME ,PKG-OB> <INSERT .TNAME ,PKG-OB>>>
305 <SET OBL <MOBLIST .ATM>>
306 <SET IATM <OR <LOOKUP .INAME .OBL> <INSERT .INAME .OBL>>>
307 <SET IOBL <MOBLIST .IATM>>
308 <BLOCK <SETG .ATM <SET TMP (.IOBL .OBL <ROOT>)>>>
309 <COND (<AND <ASSIGNED? NO-LOAD> .NO-LOAD>
310 <PUTPROP .TMP NOT-LOADED NOT-LOADED>)>)
311 (<BLOCK <SET TMP (<1 .OBLIS> !.OBLIS)>> <SET ATM T>)>
312 <COND (.TNAME <PUTPROP .ATM IOBLIST .IOBL>)>
313 <PUTPROP .TMP IN-COLLECTION .ATM>
316 <DEFINE RPACKAGE (NAME:STRING
317 "OPT" (INAME:STRING .NAME) "VALUE" ATOM
318 "AUX" ATM:ATOM IATM:ATOM IOBL:OBLIST
319 (TNAME:<OR STRING FALSE> <TRANSLATE? .NAME>) TMP)
321 <COND (<==? .NAME .INAME> <SET INAME <STRING !\I .NAME>>)>
322 <SET ATM <OR <LOOKUP .TNAME ,PKG-OB> <INSERT .TNAME ,PKG-OB>>>
323 <SET IATM <OR <LOOKUP .INAME ,COL-OB> <INSERT .INAME ,COL-OB>>>
324 <SET IOBL <MOBLIST .IATM>>
325 <BLOCK <SETG .ATM <SET TMP (.IOBL <ROOT>)>>>
326 <COND (<AND <ASSIGNED? NO-LOAD> .NO-LOAD>
327 <PUTPROP .TMP NOT-LOADED NOT-LOADED>)>
328 <PUTPROP .ATM IOBLIST .IOBL>)
329 (<BLOCK <SET TMP (<1 .OBLIST> <ROOT>)>> <SET ATM T>)>
330 <PUTPROP .TMP IN-COLLECTION .ATM>
333 <DEFINE SURVIVOR ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]>)
336 <DEFINE RENTRY ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> "VALUE" ATOM)
337 <DO-ENTRY .NAMES <ROOT>>>
339 <DEFINE ENTRY ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> "VALUE" ATOM)
340 <COND (<NOT <GETPROP <2 .OBLIST> DEFINITIONS>>
341 <DO-ENTRY .NAMES <2 .OBLIST>>)>>
343 <DEFINE DO-ENTRY (NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> OBL:OBLIST
344 "AUX" (OBLIS:LIST .OBLIST) (NAME:ATOM T) "VALUE" ATOM)
345 <PUTPROP .OBL USE-DEFER>
346 <COND (<NOT <GETPROP .OBLIS IN-COLLECTION>>
347 <ERROR ENTRY NOT-IN-PACKAGE-OR-COLLECTION!-ERRORS>)>
349 <COND (<EMPTY? .NAMES> <RETURN .NAME>)>
350 <SET NAME <1 .NAMES>>
351 <SET NAMES <REST .NAMES>>
352 <COND (<==? .OBL <ROOT>> <PUTPROP .NAME USE-DEFER>)>
353 <COND (<==? <OBLIST? .NAME> <1 .OBLIS>>
354 <INSERT <REMOVE .NAME> .OBL>)
355 (<NOT <==? <OBLIST? .NAME> .OBL>>
356 <ERROR ENTRY .NAME ALREADY-USED-ELSEWHERE!-ERRORS>)>>>
358 <DEFINE DO-EXPORTS (PKNAME:ATOM
359 "AUX" (L:<OR LIST FALSE> <GETPROP .PKNAME EXPORT>))
360 <COND (<AND .L <NOT <EMPTY? .L>>>
363 <DEFINE EXPORT ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
364 "AUX" VAL:ATOM PCK:<OR ATOM FALSE> L:<OR FALSE LIST>)
365 <SET VAL <USE !.NAMES>>
366 <COND (<SET PCK <GETPROP .OBLIST IN-COLLECTION>>
367 <COND (<AND <SET L <GETPROP .PCK EXPORT>> <NOT <EMPTY? .L>>>
368 <PUTREST <REST .L <- <LENGTH .L> 1>> <LIST !.NAMES>>)
370 <PUTPROP .PCK EXPORT <LIST !.NAMES>>)>)>
373 <DEFINE INCLUDE-WHEN ('FOO "TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
374 <COND (<EVAL .FOO> <INCLUDE !.NAMES>)>>
376 <DEFINE USE-WHEN ('FOO "TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
377 <COND (<EVAL .FOO> <USE !.NAMES>)>>
379 <DEFINE USE-DEBUG ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
380 "AUX" (DEBUGGING?:<SPECIAL ANY> T))
383 <DEFINE INCLUDE-DEBUG ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
384 "AUX" (DEBUGGING?:<SPECIAL ANY> T))
387 <DEFINE COMPILING? (X) T>
389 <DEFINE DEBUGGING? (X)
390 <AND <ASSIGNED? DEBUGGING?> .DEBUGGING?>>
392 <DEFINE INCLUDE ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]> "VALUE" ATOM
393 "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) NAME:STRING
394 PK:<OR ATOM FALSE> OBL:<OR OBLIST FALSE> N:FIX M:FIX)
395 <REPEAT ((L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
396 <COND (<EMPTY? .NAMES> <RETURN INCLUDE>)>
397 <SET NAME <1 .NAMES>>
398 <SET NAMES <REST .NAMES>>
399 <SET PK <FIND/LOAD .NAME .L-SP FILE-FIND>>
400 <COND (<NOT .PK> <ERROR DEFINITIONS .NAME NOT-FOUND!-ERRORS>)
402 (<NOT <GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>>
403 <ERROR NOT-A-DEFINITION-MODULE!-ERRORS .PK INCLUDE>
405 (<NOT <MEMQ .OBL .OBLIST>>
406 <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
407 <PUTREST <REST .OBLIS <- <SET M <LENGTH .OBLIS>> .N 1>>
408 (.OBL !<REST .OBLIS <- .M .N>>)>)
410 <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (.OBL)>)>)>
414 <DEFINE USE ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]> "VALUE" ATOM
415 "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) NAME:STRING
416 PK:<OR ATOM FALSE> OBL:<OR FALSE OBLIST> N:FIX M:FIX)
417 <REPEAT ((L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
418 <COND (<EMPTY? .NAMES> <RETURN USE>)>
419 <SET NAME <1 .NAMES>>
420 <SET NAMES <REST .NAMES>>
421 <SET PK <FIND/LOAD .NAME .L-SP PACKAGE-FIND>>
422 <COND (<NOT .PK> <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>)
424 (<GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>
425 <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .PK USE>
427 (<NOT <MEMQ .OBL .OBLIS>>
428 <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
429 <PUTREST <REST .OBLIS <- <SET M <LENGTH .OBLIS>> .N 1>>
430 (.OBL !<REST .OBLIS <- .M .N>>)>)
432 <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (.OBL)>)>)>
436 <DEFINE USE-DEFER ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
437 <COND (,L-NO-MAGIC <USE !.NAMES>)
439 <REPEAT (NAME:STRING RESULT OBL:<OR ATOM OBLIST>
440 (L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
441 <COND (<EMPTY? .NAMES> <RETURN USE-DEFER>)>
442 <SET NAME <1 .NAMES>>
443 <SET NAMES <REST .NAMES>>
444 <SET RESULT <FIND/LOAD .NAME .L-SP DEFER-FIND>>
445 <COND (<==? .RESULT T>)
446 (<TYPE? .RESULT ATOM>
448 (<TYPE? .RESULT VECTOR>
449 <COND (<==? <1 .RESULT> PACKAGE>
450 <SET OBL <MOBLIST <PACKAGE <4 .RESULT>>>>
452 <FUNCTION (E:STRING) <ENTRY <PARSE .E>>>
453 <2 .RESULT>:<LIST [REST STRING]>>
456 <PUTPROP <RENTRY <PARSE .R>>
457 USE-DEFER <REST .RESULT 3>>>
458 <3 .RESULT>:<LIST [REST STRING]>>
461 <PUTPROP .OBL USE-DEFER <REST .RESULT 3>>
462 <COND (<GASSIGNED? <SET OBL <CHTYPE .OBL ATOM>>>
463 <PUTPROP ,.OBL NOT-LOADED NOT-LOADED>)>)
465 <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .NAME USE-DEFER>)>)
467 <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>)>>)>>
469 <DEFINE USE-TOTAL ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
470 "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) NAME:STRING
471 PK:<OR ATOM FALSE> OBL:<OR FALSE OBLIST>
472 IOBL:<OR FALSE OBLIST> N:FIX M:FIX)
473 <REPEAT (INAME:STRING (L-SP:<LIST [REST <OR VECTOR STRING>]> ,L-SEARCH-PATH))
474 <COND (<EMPTY? .NAMES> <RETURN USE-TOTAL>)>
475 <SET NAME <1 .NAMES>>
476 <SET NAMES <REST .NAMES>>
477 <SET PK <FIND/LOAD .NAME .L-SP PACKAGE-FIND>>
478 <COND (<NOT .PK> <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>
481 (<GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>
482 <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .PK USE-TOTAL>
484 (<NOT <MEMQ <SET OBL <MOBLIST .PK>> .OBLIS>>
485 <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
486 <PUTREST <REST .OBLIS
487 <- <SET M <LENGTH .OBLIS>> .N 1>>
488 (.OBL !<REST .OBLIS <- .M .N>>)>)
490 <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>>
492 <SET INAME <STRING !\I .NAME>>
493 <SET IOBL <MOBLIST <LOOKUP .INAME .OBL>>>
494 <COND (<NOT <MEMQ .IOBL .OBLIS>>
495 <COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
496 <PUTREST <REST .OBLIS
497 <- <SET M <LENGTH .OBLIS>> .N 1>>
498 (.IOBL !<REST .OBLIS <- .M .N>>)>)
500 <PUTREST <REST .OBLIS
501 <- <LENGTH .OBLIS> 1>> (.IOBL)>)>)>
505 <DEFINE L-GASSIGNED? (ATM:ATOM
506 "AUX" O:<OR OBLIST FALSE>
507 TMP:<OR FALSE <VECTOR [2 STRING]>>)
508 <COND (<GASSIGNED? .ATM>)
509 (<SET TMP <COND (<==? <SET O <OBLIST? .ATM>> <ROOT>>
510 <GETPROP .ATM USE-DEFER>)
511 (.O <GETPROP .O USE-DEFER>)>>
512 <FIND/LOAD <1 .TMP> (<2 .TMP>) FILE-FIND>
514 <COND (<NOT <GASSIGNED? .ATM>>
515 <ERROR PACKAGE "PACKAGE DID NOT DEFINE FUNCTION">)>
520 <DEFINE DROP ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]> "VALUE" ATOM
521 "AUX" NAME:<OR STRING FALSE> PK:<OR ATOM FALSE>
522 OBL:<OR FALSE OBLIST> IOBL:<OR FALSE OBLIST> N:FIX)
523 <REPEAT ((OBLIS:<LIST [REST OBLIST]> .OBLIST))
524 <COND (<EMPTY? .NAMES> <RETURN DROP>)>
525 <SET NAME <TRANSLATE? <1 .NAMES>>>
526 <SET NAMES <REST .NAMES>>
527 <COND (<NOT .NAME> <AGAIN>)>
528 <COND (<NOT <SET PK <LOOKUP .NAME ,PKG-OB>>>
529 <ERROR PACKAGE .NAME NOT-PACKAGE-OR-COLLECTION!-ERRORS>)>
530 <SET OBL <MOBLIST .PK>>
531 <COND (<NOT <0? <SET N <LENGTH <MEMQ .OBL .OBLIS>>>>>
532 <PUTREST <REST .OBLIS <SET N <- <LENGTH .OBLIS> .N 1>>>
533 <REST .OBLIS <+ .N 2>>>)>
534 <COND (<SET IOBL <GETPROP .PK IOBLIST>>
535 <COND (<NOT <0? <SET N <LENGTH <MEMQ .IOBL .OBLIS>>>>>
536 <PUTREST <REST .OBLIS <SET N <- <LENGTH .OBLIS> .N 1>>>
537 <REST .OBLIS <+ .N 2>>>)>)>>>
539 <DEFINE END-DEFINITIONS ("OPT" (PKNM:<OR FALSE ATOM STRING> %<>))
542 <DEFINE ENDPACKAGE ("OPT" (PKNM:<OR FALSE ATOM STRING> %<>)
543 "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) PK:<OR ATOM FALSE>)
545 <COND (<SET PK <GETPROP .OBLIS IN-COLLECTION>>
546 <PUTPROP .OBLIS IN-COLLECTION>
550 (<TYPE? .PKNM ATOM> <RETURN>)
552 <ERROR UNMATCHED-ENDPACKAGE-OR-ENDCOLLECTION!-ERRORS>
554 <COND (<OR <NOT .PKNM> <=? <SPNAME .PK> .PKNM>> <RETURN>)>>>
556 <DEFINE L-UNUSE (STR:<OR STRING FALSE>
557 "AUX" TMP ATM:<OR OBLIST FALSE> IATM:<OR OBLIST FALSE>)
558 <SET STR <TRANSLATE? .STR>>
560 (<AND <SET TMP <LOOKUP .STR ,PKG-OB>> <GASSIGNED? .TMP>>
561 <SET ATM <MOBLIST .TMP>>
563 <SET IATM <GETPROP .TMP IOBLIST>>
567 <FUNCTION (A:<OR ATOM LINK>)
568 <COND (<OR <==? <OBLIST? .A> .ATM>
569 <==? <OBLIST? .A> .IATM>>
574 <PUTPROP .TMP IOBLIST>
575 <REMOVE .TMP ,PKG-OB>
577 (T #FALSE ("NOT PACKAGE OR DATUM"))>>
579 <SETG UNUSE ,L-UNUSE>
581 <DEFINE TRANSLATE? (NAME:STRING
582 "AUX" (L:<LIST [REST STRING <OR STRING FALSE>]>
585 <COND (<EMPTY? .L> <RETURN .NAME>)
586 (<=? <1 .L>:STRING .NAME> <RETURN <2 .L>>)>
587 <SET L <REST .L 2>>>>
589 <DEFINE TRANSLATE (FROM:STRING TO:<OR FALSE STRING>
590 "AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
591 ,L-TRANSLATIONS) (OUTCHAN:CHANNEL ,OUTCHAN))
594 <SETG L-TRANSLATIONS (.FROM .TO !,L-TRANSLATIONS)>
596 (<=? <1 .L>:STRING .FROM> <PUT .L 2 .TO> <RETURN>)>
603 <DEFINE UNTRANSLATE ("OPT" (NAME:STRING "")
604 "AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
606 <COND (<EMPTY? .NAME>
607 <SETG L-TRANSLATIONS '()>
611 <REPEAT ((L1:<LIST [REST STRING <OR FALSE STRING>]> .L)
612 L2:<LIST [REST <OR FALSE STRING>]>)
613 <COND (<EMPTY? .L1> <RETURN #FALSE ("NOT TRANSLATED")>)
614 (<=? <1 .L1>:STRING .NAME>
616 <SETG L-TRANSLATIONS <REST .L 2>>)
617 (<PUTREST <REST .L2> <REST .L1 2>>)>
620 <SET L1 <REST .L1 2>>>)>>
622 <DEFINE TRANSLATIONS ("AUX" (L:<LIST [REST STRING <OR STRING FALSE>]>
623 ,L-TRANSLATIONS) (OUTCHAN:CHANNEL ,OUTCHAN))
624 <COND (<EMPTY? .L> <PRINC "No translations"> <CRLF>)
631 <COND (<EMPTY? <SET L <REST .L 2>>> <RETURN>)>>)>>
633 <DEFINE L-ERROR-HANDLER (IGNORE FRM:FRAME "TUPLE" STUFF:<PRIMTYPE VECTOR>)
634 <COND (<AND <NOT ,L-NO-MAGIC>
635 <G=? <LENGTH .STUFF> 3>
636 <==? <1 .STUFF> UNASSIGNED-VARIABLE!-ERRORS>
637 <==? <3 .STUFF> GVAL>
638 <TYPE? <2 .STUFF> ATOM>>
639 <TRY-DEFER-LOAD <2 .STUFF> .FRM>
640 <TRY-OOPS <2 .STUFF> .FRM>
641 <TRY-ENTRY-FIND <2 .STUFF> .FRM>)>>
643 <DEFINE TRY-OOPS (WRONG:ATOM FRM:FRAME
644 "AUX" RIGHT:<OR ATOM FALSE> (PNAME:STRING <SPNAME .WRONG>)
645 (OUTCHAN:CHANNEL ,OUTCHAN))
647 <FUNCTION (POSS:<OR ATOM LINK>)
648 <COND (<AND <TYPE? .POSS ATOM>
649 <=? <SPNAME .POSS> .PNAME>
651 <N==? <OBLIST? .POSS> <MOBLIST PACKAGE>>>
652 ;"accept the first atom with the same name that has a gval,
653 (but not the package oblist atom)."
656 <NTH ,ATOM-TABLE:VECTOR
657 <HASH-NAME .PNAME <LENGTH ,ATOM-TABLE:VECTOR>>>:LIST>
658 <COND (<ASSIGNED? RIGHT>
660 ;"let the user know we're making a gval substitution"
661 <PRINC .RIGHT .OUTCHAN>
662 <PRINC ": " .OUTCHAN>
663 <PRIN1 <OBLIST? .WRONG> .OUTCHAN>
664 <PRINC "->" .OUTCHAN>
665 <PRIN1 <OBLIST? .RIGHT> .OUTCHAN>
667 <COND (<OBLIST? .RIGHT>
668 <SET PNAME <SPNAME <CHTYPE <OBLIST? .RIGHT> ATOM>>>
669 <MAYBE-USE/INCLUDE .RIGHT .WRONG .PNAME>)>
670 <DISMISS ,.RIGHT .FRM>)>>
672 <DEFINE TRY-DEFER-LOAD (WRONG:ATOM FRM:FRAME "AUX" DEFER:<OR VECTOR FALSE>)
673 <COND (<AND <SET DEFER <OR <GETPROP <OBLIST? .WRONG> USE-DEFER>
674 <GETPROP .WRONG USE-DEFER>>>
675 <FIND/LOAD <1 .DEFER> (<2 .DEFER>) FILE-FIND>
678 <DISMISS ,.WRONG .FRM>)>>
680 <DEFINE TRY-ENTRY-FIND (WRONG:ATOM FRM:FRAME)
681 <REPEAT ((L-SP:LIST ,L-SEARCH-PATH) SPEC:<OR VECTOR STRING>
682 (WRONG-NAME:STRING <SPNAME .WRONG>) EDATA:<OR FALSE LIST>
683 EDESC:<OR <VECTOR FIX [2 STRING]> FALSE> RIGHT:<OR ATOM FALSE>
684 OBL:<OR OBLIST ATOM FALSE>)
685 <COND (<EMPTY? .L-SP> <RETURN>)>
687 <SET L-SP <REST .L-SP>>
688 <COND (<TYPE? .SPEC STRING>
689 <COND (<AND <GASSIGNED? ENTRY-FIND>
690 <SET EDATA <ENTRY-FIND .WRONG-NAME .SPEC T>>
691 <SET EDESC <PICK-DESCRIPTOR .WRONG .EDATA>>
692 <SET OBL <FIND/LOAD <2 .EDESC> (.SPEC) FILE-FIND>>>
693 <SET OBL <MOBLIST .OBL>>
694 <COND (<==? <ANDB <1 .EDESC> *40000*> 0> ;"Rentry?"
695 <SET RIGHT <LOOKUP .WRONG-NAME <ROOT>>>)
697 <SET RIGHT <LOOKUP .WRONG-NAME .OBL>>)>
698 <COND (<AND .RIGHT <GASSIGNED? .RIGHT>>
699 <MAYBE-USE/INCLUDE .RIGHT .WRONG <2 .EDESC>>
700 <DISMISS ,.RIGHT .FRM>)>)>)>>>
702 <DEFINE MAYBE-USE/INCLUDE (RIGHT:ATOM WRONG:ATOM OBNAME:STRING
703 "AUX" (OBLIS:LIST .OBLIST) (OUTCHAN .OUTCHAN)
704 OBL:<OR OBLIST FALSE ATOM>
705 (TOBNAME:<OR STRING FALSE> <TRANSLATE? .OBNAME>))
706 <COND (<AND <NOT <EMPTY? .OBLIS>>
707 <==? <OBLIST? .WRONG> <1 .OBLIS>>
708 <OR <AND .TOBNAME <SET OBL <LOOKUP .TOBNAME <MOBLIST PACKAGE>>>>
709 <SET OBL <LOOKUP .OBNAME <MOBLIST PACKAGE>>>>>
710 <COND (<GETPROP <SET OBL <MOBLIST .OBL>> DEFINITIONS>
712 (<==? .OBL <OBLIST? .RIGHT>>
714 (<NOT <==? <OBLIST? .RIGHT> <ROOT>>>
715 <USE-TOTAL .OBNAME>)>)>
716 <COND (<AND <SET OBL <OBLIST? .WRONG>>
717 <SET OBL <OBLIST? <CHTYPE .OBL ATOM>>>
718 <==? <OBLIST? <SET OBL <CHTYPE .OBL ATOM>>> <MOBLIST PACKAGE>>
720 <NOT <MEMQ <OBLIST? .RIGHT> <SET OBLIS ,.OBL>>>
721 <NOT <EMPTY? .OBLIS>>>
722 <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (<OBLIST? .RIGHT>)>)>
723 <COND (<N==? .RIGHT .WRONG>
724 <COND (<GASSIGNED? SUBSTITUTE>
725 <SUBSTITUTE .RIGHT <REMOVE .WRONG>>)
727 <SETG .WRONG ,.RIGHT>)>)>
730 <DEFINE PICK-DESCRIPTOR (WRONG:ATOM EDATA:<LIST [REST <VECTOR FIX [2 STRING]>]>
731 "AUX" (OUTCHAN:CHANNEL ,OUTCHAN) RESPONSE)
732 <COND (<EMPTY? .EDATA> %<>)
733 (<AND <NOT ,L-ALWAYS-INQUIRE> <LENGTH? .EDATA 1>>
737 <PRINC "DYNAMIC LOADER: " .OUTCHAN>
738 <PRINC .WRONG .OUTCHAN>
739 <PRINC " in modules:" .OUTCHAN>
740 <REPEAT ((E:LIST .EDATA) D:<VECTOR FIX [2 STRING]> (C:FIX 1))
745 <PRINTSTRING "] call ERROR" .OUTCHAN>
747 <PRINC "Module number <ESC>: " .OUTCHAN>
748 <COND (<AND <TYPE? <SET RESPONSE <READ>> FIX>
750 <L=? .RESPONSE <LENGTH .EDATA>>>
751 <RETURN <NTH .EDATA .RESPONSE>>)>
759 <PRINTSTRING "] " .OUTCHAN>
760 <PRINTSTRING <2 .D> .OUTCHAN>
761 <SET C <+ .C 1>>)>>)>>
765 <SETG L-ALWAYS-INQUIRE <>>
767 <SETG IOB <MOBLIST <LOOKUP "INITIAL" <ROOT>>>>