mim/development/mim/vax/npck.mud

   1
   2 ; " This is the PACKAGE handling routines, written in MIM. "
   3 ; " For documentaton, see The MDL Programming environment [Lebling 80]. "
   4
   5 <BLOCK (<ROOT>)>
   6
   7 PACKAGE-MODE
   8
   9 PACKAGE
  10
  11 RPACKAGE
  12
  13 ENTRY
  14
  15 RENTRY
  16
  17 SURVIVOR
  18
  19 EXTERNAL
  20
  21 USE
  22
  23 USE-WHEN
  24
  25 USE-TOTAL
  26
  27 USE-DEBUG
  28
  29 USE-DEFER
  30
  31 EXPORT
  32
  33 INCLUDE
  34
  35 INCLUDE-WHEN
  36
  37 INCLUDE-DEBUG
  38
  39 COMPILING?
  40
  41 DEBUGGING?
  42
  43 DEFINITIONS
  44
  45 END-DEFINITIONS
  46
  47 DROP
  48
  49 NULL-OBLIST
  50
  51 ENDPACKAGE
  52
  53 L-SEARCH-PATH
  54
  55 L-SECOND-NAMES
  56
  57 L-OPEN
  58
  59 L-FLOAD
  60
  61 L-LOAD
  62
  63 L-LOADER
  64
  65 L-NO-FILES
  66 \f
  67 L-NO-MAGIC
  68
  69 L-ALWAYS-INQUIRE
  70
  71 L-UNUSE
  72
  73 UNUSE
  74
  75 L-GASSIGNED?
  76
  77 L-NOISY
  78
  79 L-VERY-NOISY
  80
  81 L-TRANSLATIONS
  82
  83 L-USE-ABSTRACTS?
  84
  85 TRANSLATE
  86
  87 UNTRANSLATE
  88
  89 TRANSLATIONS
  90
  91 IN-COLLECTION
  92
  93 OBLIST
  94
  95 IOBLIST
  96
  97 DISMISS     ;"NPCK is loaded before INT."
  98
  99 <MOBLIST PACKAGE>
 100
 101 <MOBLIST PKG!-PACKAGE>
 102
 103 <BLOCK (<MOBLIST IPKG!-PKG!-PACKAGE> <MOBLIST PKG!-PACKAGE> <ROOT>)>
 104
 105 <PARSE "SEARCH!-PKG!-PACKAGE">
 106
 107 ;" USED BY L PACKAGE "
 108
 109 <SETG PKG!-PACKAGE .OBLIST>
 110
 111 <SETG PKG-OB <MOBLIST PACKAGE>>
 112
 113 <SETG COL-OB <MOBLIST RPACKAGE>>
 114
 115 <SETG LAST-SEARCH-VAL <>>
 116
 117 <GDECL (LAST-SEARCH-VAL) <OR STRING CHANNEL VECTOR FALSE>>
 118 \f
 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"
 122
 123 <GDECL (L-SECOND-NAMES) VECTOR
 124        (L-SEARCH-PATH) <LIST [REST <OR STRING VECTOR>]>>
 125
 126 <SETG L-NO-FILES <>>
 127
 128 <SETG L-NOISY T>
 129
 130 <SETG L-VERY-NOISY <>>
 131
 132 <OR <GASSIGNED? L-TRANSLATIONS> <SETG L-TRANSLATIONS ()>>
 133
 134 ;"THIS SHOULD BE SETG'ED TO T IN COMPILERS."
 135
 136 <OR <GASSIGNED? L-USE-ABSTRACTS?> <SETG L-USE-ABSTRACTS? <>>>
 137
 138 <PACKAGE "LIBRARY">
 139
 140 <ENTRY PACKAGE-FIND ENTRY-FIND DEFER-FIND FILE-FIND LIBRARY-OPEN
 141        PARSE-LIBRARY-NAME>
 142
 143 <RENTRY PUBLIC-LIBRARY>
 144
 145 <ENDPACKAGE>
 146
 147 <USE "LIBRARY">
 148
 149 <PACKAGE "SUBSTITUTE">
 150
 151 <ENTRY SUBSTITUTE>
 152
 153 <ENDPACKAGE>
 154
 155 <USE "SUBSTITUTE">
 156 \f
 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> %<>)
 166                    "NAME" FL)
 167    <COND (<AND .TSTR
 168                <SET TMP <LOOKUP .TSTR ,PKG-OB>>
 169                <GASSIGNED? .TMP>
 170                <NOT <GETPROP <SET TL ,.TMP> NOT-LOADED>>>
 171           <RETURN .TMP .FL>)>
 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>)>
 176    <SET CH .RESULT>
 177    <COND (<OR ,L-NOISY ,L-VERY-NOISY>
 178           <PRINC "/">
 179           <PRINC .STR>
 180           <COND (<N==? .STR .TSTR>
 181                  <PRINC !\=>
 182                  <PRINC .TSTR>)>
 183           <COND (<AND ,L-VERY-NOISY ,LAST-SEARCH-VAL>
 184                  <PRINC !\=>
 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>>)
 188                           (T <PRINC .STR>)>>
 189                  <CRLF>)
 190                 (T <PRINC !\ >)>)>
 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>>
 195                      <APPLY .LOADER .CH>
 196                      <AND <CHANNEL-OPEN? .CH> <CLOSE .CH>>)
 197                     (<LOAD .CH>
 198                      <CLOSE .CH>)>
 199               <COND (.TSTR
 200                      <OR <SET TMP <LOOKUP .TSTR .PKO>>
 201                          <BIND ()
 202                             <SET TMP <INSERT .TSTR .PKO>>
 203                             <SETG .TMP .OBLIS>
 204                             .TMP>>
 205                      .TMP)
 206                     (T)>>
 207            <BIND ()
 208               <SET OBLIST .OBLIS>
 209               <AND <CHANNEL-OPEN? .CH> <CLOSE .CH>>>>>
 210 \f
 211 <DEFINE PACKAGE-DO-OPEN (FNM:STRING
 212                          "OPT" (LSN:<OR STRING <VECTOR [REST STRING]>>
 213                                 ,L-SECOND-NAMES)
 214                          "AUX" CH:<OR CHANNEL FALSE> NM2:<SPECIAL STRING>
 215                          "NAME" PDO)
 216    <COND (,L-USE-ABSTRACTS?
 217           <SET NM2 "ABSTR">
 218           <COND (<SET CH <OPEN "READ" .FNM>> <RETURN .CH .PDO>)>)>
 219    <COND (<TYPE? .LSN STRING>
 220           <SET LSN [.LSN]>)>
 221    <MAPF %<>
 222          <FUNCTION (NM:STRING)
 223             <SET NM2 .NM>
 224             <COND (<SET CH <OPEN "READ" .FNM>> <MAPLEAVE>)>>
 225          .LSN>
 226    .CH>
 227
 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>)
 233          (<SET OSNM "">)>
 234    <COND (<ASSIGNED? DEV> <SET ODEV .DEV>)
 235          (<GASSIGNED? DEV> <SET ODEV ,DEV>)
 236          (<SET ODEV "">)>
 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>)
 240             (<SET SNM .OSNM>)>
 241       <COND (<EMPTY? .ODEV> <UNASSIGN DEV>)
 242             (<SET DEV .ODEV>)>
 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>
 249                     <RETURN .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>
 254                     <RETURN .RESULT>)
 255                    (<AND <==? .LACTION DEFER-FIND>
 256                          <GASSIGNED? DEFER-FIND>
 257                          <SET RESULT <DEFER-FIND .IND .SPEC>>>
 258                     <SETG LAST-SEARCH-VAL .RESULT>
 259                     <RETURN .RESULT>)>)
 260             (<NOT .L-NO-FILES>
 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>
 268                     <RETURN .RESULT>)>)>
 269       <SET L <REST .L>>>>
 270
 271 <DEFINE L-OPEN (PACKAGE:STRING)
 272    <SEARCH .PACKAGE ,L-SEARCH-PATH FILE-FIND>>
 273 \f
 274 <DEFINE L-FLOAD (PACKAGE:STRING "AUX" CHN:<OR CHANNEL FALSE>)
 275    <COND (<SET CHN <L-OPEN .PACKAGE>>
 276           <UNWIND <BIND ()
 277                      <LOAD .CHN>
 278                      <CLOSE .CHN>
 279                      "DONE">
 280                   <COND (<CHANNEL-OPEN? .CHN> <CLOSE .CHN>)>>)
 281          (<ERROR FILE-NOT-FOUND!-ERRORS .PACKAGE L-FLOAD>)>>
 282
 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))
 286    <COND (.TNAME
 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>
 295    .ATM>
 296
 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))
 302    <COND (.TNAME
 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>
 314    .ATM>
 315
 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)
 320    <COND (.TNAME
 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>
 331    .ATM>
 332
 333 <DEFINE SURVIVOR ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]>)
 334    T>
 335
 336 <DEFINE RENTRY ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> "VALUE" ATOM)
 337    <DO-ENTRY .NAMES <ROOT>>>
 338 \f
 339 <DEFINE ENTRY ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST ATOM]> "VALUE" ATOM)
 340    <COND (<NOT <GETPROP <2 .OBLIST> DEFINITIONS>>
 341           <DO-ENTRY .NAMES <2 .OBLIST>>)>>
 342
 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>)>
 348    <REPEAT ()
 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>)>>>
 357
 358 <DEFINE DO-EXPORTS (PKNAME:ATOM
 359                     "AUX" (L:<OR LIST FALSE> <GETPROP .PKNAME EXPORT>))
 360    <COND (<AND .L <NOT <EMPTY? .L>>>
 361           <USE !.L>)>>
 362
 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>>)
 369                 (T
 370                  <PUTPROP .PCK EXPORT <LIST !.NAMES>>)>)>
 371    .VAL>
 372
 373 <DEFINE INCLUDE-WHEN ('FOO "TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
 374    <COND (<EVAL .FOO> <INCLUDE !.NAMES>)>>
 375
 376 <DEFINE USE-WHEN ('FOO "TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
 377    <COND (<EVAL .FOO> <USE !.NAMES>)>>
 378
 379 <DEFINE USE-DEBUG ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
 380                    "AUX" (DEBUGGING?:<SPECIAL ANY> T))
 381    <USE !.NAMES>>
 382
 383 <DEFINE INCLUDE-DEBUG ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>
 384                        "AUX" (DEBUGGING?:<SPECIAL ANY> T))
 385    <INCLUDE !.NAMES>>
 386
 387 <DEFINE COMPILING? (X) T>
 388
 389 <DEFINE DEBUGGING? (X)
 390    <AND <ASSIGNED? DEBUGGING?> .DEBUGGING?>>
 391 \f
 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>)
 401             (<==? .PK T>)
 402             (<NOT <GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>>
 403              <ERROR NOT-A-DEFINITION-MODULE!-ERRORS .PK INCLUDE>
 404              <SET PK %<>>)
 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>>)>)
 409                    (T
 410                     <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (.OBL)>)>)>
 411       <COND (.PK
 412              <DO-EXPORTS .PK>)>>>
 413
 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>)
 423             (<==? .PK T>)
 424             (<GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>
 425              <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .PK USE>
 426              <SET PK %<>>)
 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>>)>)
 431                    (T
 432                     <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (.OBL)>)>)>
 433       <COND (.PK
 434              <DO-EXPORTS .PK>)>>>
 435 \f
 436 <DEFINE USE-DEFER ("TUPLE" NAMES:<<PRIMTYPE VECTOR> [REST STRING]>)
 437    <COND (,L-NO-MAGIC <USE !.NAMES>)
 438          (T
 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>
 447                     <USE .NAME>)
 448                    (<TYPE? .RESULT VECTOR>
 449                     <COND (<==? <1 .RESULT> PACKAGE>
 450                            <SET OBL <MOBLIST <PACKAGE <4 .RESULT>>>>
 451                            <MAPF %<>
 452                                  <FUNCTION (E:STRING) <ENTRY <PARSE .E>>>
 453                                  <2 .RESULT>:<LIST [REST STRING]>>
 454                            <MAPF %<>
 455                                  <FUNCTION (R:STRING)
 456                                     <PUTPROP <RENTRY <PARSE .R>>
 457                                              USE-DEFER <REST .RESULT 3>>>
 458                                  <3 .RESULT>:<LIST [REST STRING]>>
 459                            <ENDPACKAGE>
 460                            <USE .NAME>
 461                            <PUTPROP .OBL USE-DEFER <REST .RESULT 3>>
 462                            <COND (<GASSIGNED? <SET OBL <CHTYPE .OBL ATOM>>>
 463                                   <PUTPROP ,.OBL NOT-LOADED NOT-LOADED>)>)
 464                           (T
 465                            <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .NAME USE-DEFER>)>)
 466                    (T
 467                     <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>)>>)>>
 468
 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>
 479              <AGAIN>)
 480             (<==? .PK T>)
 481             (<GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>
 482              <ERROR NOT-A-PROGRAM-MODULE!-ERRORS .PK USE-TOTAL>
 483              <AGAIN>)
 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>>)>)
 489                    (T
 490                     <PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>>
 491                              (.OBL)>)>)>
 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>>)>)
 499                    (T
 500                     <PUTREST <REST .OBLIS
 501                                    <- <LENGTH .OBLIS> 1>> (.IOBL)>)>)>
 502       <COND (.PK
 503              <DO-EXPORTS .PK>)>>>
 504 \f
 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>
 513           <USE <1 .TMP>>
 514           <COND (<NOT <GASSIGNED? .ATM>>
 515                  <ERROR PACKAGE "PACKAGE DID NOT DEFINE FUNCTION">)>
 516           T)>>
 517
 518 <SETG EXTERNAL ,USE>
 519
 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>>>)>)>>>
 538
 539 <DEFINE END-DEFINITIONS ("OPT" (PKNM:<OR FALSE ATOM STRING> %<>))
 540    <ENDPACKAGE .PKNM>>
 541
 542 <DEFINE ENDPACKAGE ("OPT" (PKNM:<OR FALSE ATOM STRING> %<>)
 543                     "AUX" (OBLIS:<LIST [REST OBLIST]> .OBLIST) PK:<OR ATOM FALSE>)
 544    <REPEAT ()
 545       <COND (<SET PK <GETPROP .OBLIS IN-COLLECTION>>
 546              <PUTPROP .OBLIS IN-COLLECTION>
 547              <ENDBLOCK>
 548              <SET OBLIS .OBLIST>
 549              .PK)
 550             (<TYPE? .PKNM ATOM> <RETURN>)
 551             (T
 552              <ERROR UNMATCHED-ENDPACKAGE-OR-ENDCOLLECTION!-ERRORS>
 553              <RETURN>)>
 554       <COND (<OR <NOT .PKNM> <=? <SPNAME .PK> .PKNM>> <RETURN>)>>>
 555 \f
 556 <DEFINE L-UNUSE (STR:<OR STRING FALSE>
 557                  "AUX" TMP ATM:<OR OBLIST FALSE> IATM:<OR OBLIST FALSE>)
 558    <SET STR <TRANSLATE? .STR>>
 559    <COND (<NOT .STR>)
 560          (<AND <SET TMP <LOOKUP .STR ,PKG-OB>> <GASSIGNED? .TMP>>
 561           <SET ATM <MOBLIST .TMP>>
 562           <DROP .STR>
 563           <SET IATM <GETPROP .TMP IOBLIST>>
 564           <MAPF %<>
 565                 <FUNCTION (L:LIST)
 566                    <MAPF %<>
 567                          <FUNCTION (A:<OR ATOM LINK>)
 568                             <COND (<OR <==? <OBLIST? .A> .ATM>
 569                                        <==? <OBLIST? .A> .IATM>>
 570                                    <REMOVE .A>)>>
 571                          .L>>
 572                 ,ATOM-TABLE>
 573           <GUNASSIGN .TMP>
 574           <PUTPROP .TMP IOBLIST>
 575           <REMOVE .TMP ,PKG-OB>
 576           "PACKAGE REMOVED")
 577          (T #FALSE ("NOT PACKAGE OR DATUM"))>>
 578
 579 <SETG UNUSE ,L-UNUSE>
 580
 581 <DEFINE TRANSLATE? (NAME:STRING
 582                     "AUX" (L:<LIST [REST STRING <OR STRING FALSE>]>
 583                            ,L-TRANSLATIONS))
 584    <REPEAT ()
 585       <COND (<EMPTY? .L> <RETURN .NAME>)
 586             (<=? <1 .L>:STRING .NAME> <RETURN <2 .L>>)>
 587       <SET L <REST .L 2>>>>
 588
 589 <DEFINE TRANSLATE (FROM:STRING TO:<OR FALSE STRING>
 590                    "AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
 591                           ,L-TRANSLATIONS) (OUTCHAN:CHANNEL ,OUTCHAN))
 592    <REPEAT ()
 593       <COND (<EMPTY? .L>
 594              <SETG L-TRANSLATIONS (.FROM .TO !,L-TRANSLATIONS)>
 595              <RETURN>)
 596             (<=? <1 .L>:STRING .FROM> <PUT .L 2 .TO> <RETURN>)>
 597       <SET L <REST .L 2>>>
 598    <PRINC .FROM>
 599    <PRINC " --> ">
 600    <PRINC .TO>
 601    <CRLF>>
 602
 603 <DEFINE UNTRANSLATE ("OPT" (NAME:STRING "")
 604                      "AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
 605                             ,L-TRANSLATIONS))
 606    <COND (<EMPTY? .NAME>
 607           <SETG L-TRANSLATIONS '()>
 608           <PRINC "All gone">
 609           <CRLF>)
 610          (T
 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>
 615                     <COND (<==? .L .L1>
 616                            <SETG L-TRANSLATIONS <REST .L 2>>)
 617                           (<PUTREST <REST .L2> <REST .L1 2>>)>
 618                     <RETURN .NAME>)>
 619              <SET L2 .L1>
 620              <SET L1 <REST .L1 2>>>)>>
 621 \f
 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>)
 625          (T
 626           <REPEAT ()
 627              <PRINC <1 .L>>
 628              <PRINC " --> ">
 629              <PRINC <2 .L>>
 630              <CRLF>
 631              <COND (<EMPTY? <SET L <REST .L 2>>> <RETURN>)>>)>>
 632
 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>)>>
 642
 643 <DEFINE TRY-OOPS (WRONG:ATOM FRM:FRAME
 644                   "AUX" RIGHT:<OR ATOM FALSE> (PNAME:STRING <SPNAME .WRONG>)
 645                         (OUTCHAN:CHANNEL ,OUTCHAN))
 646    <MAPF %<>
 647          <FUNCTION (POSS:<OR ATOM LINK>)
 648             <COND (<AND <TYPE? .POSS ATOM>
 649                         <=? <SPNAME .POSS> .PNAME>
 650                         <GASSIGNED? .POSS>
 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)."
 654                    <SET RIGHT .POSS>
 655                    <MAPLEAVE>)>>
 656          <NTH ,ATOM-TABLE:VECTOR
 657               <HASH-NAME .PNAME <LENGTH ,ATOM-TABLE:VECTOR>>>:LIST>
 658    <COND (<ASSIGNED? RIGHT>
 659           <COND (,L-NOISY
 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>
 666                  <CRLF .OUTCHAN>)>
 667           <COND (<OBLIST? .RIGHT>
 668                  <SET PNAME <SPNAME <CHTYPE <OBLIST? .RIGHT> ATOM>>>
 669                  <MAYBE-USE/INCLUDE .RIGHT .WRONG .PNAME>)>
 670           <DISMISS ,.RIGHT .FRM>)>>
 671
 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>
 676                <USE <1 .DEFER>>
 677                <GASSIGNED? .WRONG>>
 678           <DISMISS ,.WRONG .FRM>)>>
 679 \f
 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>)>
 686       <SET SPEC <1 .L-SP>>
 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>>>)
 696                           (T
 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>)>)>)>>>
 701
 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>
 711                  <INCLUDE .OBNAME>)
 712                 (<==? .OBL <OBLIST? .RIGHT>>
 713                  <USE .OBNAME>)
 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>>
 719                <GASSIGNED? .OBL>
 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>>)
 726                 (T
 727                  <SETG .WRONG ,.RIGHT>)>)>
 728    .RIGHT>
 729 \f
 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>>
 734           <1 .EDATA>)
 735          (T
 736           <CRLF .OUTCHAN>
 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))
 741              <COND (<EMPTY? .E>
 742                     <CRLF .OUTCHAN>
 743                     <PRINC !\[ .OUTCHAN>
 744                     <PRINC .C .OUTCHAN>
 745                     <PRINTSTRING "] call ERROR" .OUTCHAN>
 746                     <CRLF .OUTCHAN>
 747                     <PRINC "Module number <ESC>: " .OUTCHAN>
 748                     <COND (<AND <TYPE? <SET RESPONSE <READ>> FIX>
 749                                 <G? .RESPONSE 0>
 750                                 <L=? .RESPONSE <LENGTH .EDATA>>>
 751                            <RETURN <NTH .EDATA .RESPONSE>>)>
 752                     <RETURN %<>>)
 753                    (T
 754                     <SET D <1 .E>>
 755                     <SET E <REST .E>>
 756                     <CRLF .OUTCHAN>
 757                     <PRINC !\[ .OUTCHAN>
 758                     <PRINC .C .OUTCHAN>
 759                     <PRINTSTRING "] " .OUTCHAN>
 760                     <PRINTSTRING <2 .D> .OUTCHAN>
 761                     <SET C <+ .C 1>>)>>)>>
 762
 763 <SETG L-NO-MAGIC <>>
 764
 765 <SETG L-ALWAYS-INQUIRE <>>
 766
 767 <SETG IOB <MOBLIST <LOOKUP "INITIAL" <ROOT>>>>
 768
 769 <ENDBLOCK>
 770
 771 <ENDBLOCK>
 772
 773 <SET OBLIST ,OBLIST>