mim/development/mim/vax/mimlib/abstr.mud

   1 <PACKAGE "ABSTR">
   2
   3 ;"*****************************************************************************
   4
   5  ABSTR.MUD: EDIT HISTORY                                    Machine Independent
   6
   7    COMPILATION: NOT CAREFUL, GLUEABLE
   8
   9    1JUN84  [Shane] - Created package for abstracting compiled packages.
  10    18JUL84 [Shane] - Support definition modules.
  11    19JUL84 [Shane] - Divided abstract forms into 4 collection categories.
  12                      Support USE-WHEN, INCLUDE-WHEN, USE-DEFER.
  13    25JUL84 [Shane] - Cannot abstract RPACKAGE.
  14    30JUL84 [Shane] - Group loading is optional in DESCRIBE-PACKAGE.
  15    4AUG84  [Shane] - Sort vectors in PKGINFO. Add stupid optional arguments
  16                      for ABSTR END-DEFINITIONS, PACKAGE, ENDPACKAGE.
  17    7AUG84  [Shane] - Flush group loading feature in DESCRIBE-PACKAGE. Look
  18                      for MBIN files. Use filenames package.
  19   14AUG84  [Shane] - Flushed ABSTRACT-PACKAGES, add validation of USED-DU-LIST
  20                      so that DU's are built only once if possible. USED-DU-LIST
  21                      retains state between invocations of abstraction process.
  22   16AUG84  [Shane] - Mung MSUBR IMSUBR names and code offsets to set up for
  23                      magic loading of packages in compiler when an abstracted
  24                      MSUBR is called. The magic msubr loader must be named
  25                      ABSTRACT-MSUBR-LOADER and the corresponding IMSUBR must
  26                      be named abstract-msubr-loader-IMSUBR on the ROOT oblist
  27                      for this scheme to work.
  28   26AUG84  [Shane] - Flushed FILENAMES package since no one used it except me.
  29                      FILENAMES survives as new function SEARCH and macro
  30                      EXTRACT-NM1. Moved macros, internal type definitions to
  31                      definitions ABSTR-DEFS. Flushed usage of NEWSTRUC - define
  32                      PKGINFO type with MDL primitives.
  33   28AUG84  [Shane] - Support abstraction of NEW-CHANNEL-TYPE. Remove use of
  34                      associations. SEARCH is an ENTRY. Rewrite DU-DEFINES? and
  35                      others because of compiler woes. Channel types collected
  36                      in global NEW-CHANNEL-TYPES list.
  37   31AUG84  [Shane] - Flush module oblist when we build a DU if it's around.
  38                      See ABSTR-PACKAGE, ABSTR-DEFINITIONS. Mung copy of msubr -
  39                      see ABSTR-GROVEL. Updated PRELOADED package vector. USE
  40                      ABSTR-LOADER to get name of magic IMSUBR.
  41    5SEP84  [Shane] - Support abstraction of ADD-CHANNEL-OPS: similar to
  42                      NEW-CHANNEL-TYPE except for the name. These are no
  43                      longer collected in global list. DU's now contain a list
  44                      of special forms to be added to the abstract. Added
  45                      ABSTR-GROVEL-SPECIAL which checks these forms and takes
  46                      action based on the first element of the form. Future
  47                      special forms should use this mechanism - see
  48                      ABSTR-ADD-CHANNEL-OPS, ABSTR-NEW-CHANNEL-TYPE,
  49                      REDEFINE-ENVIRONMENT, RESTORE-ENVIRONMENT for example
  50                      of how to add special forms. See ABSTR-GROVEL-SPECIAL
  51                      for example of how to process them.
  52   20FEB85  [Shane] - Added switch ABSTRACT-IGNORE? - controls whether or
  53                      not file not found events cause errors.
  54
  55  *****************************************************************************"
  56 \f
  57 <ENTRY ABSTRACT-PACKAGE DESCRIBE-PACKAGE PKGINFO PKG-NAME PKG-CODE PKG-SOURCE
  58        PKG-ABSTRACT PKG-ENTRYS PKG-RENTRYS PKG-USES PKG-EXPORTS PKG-INCLUDES
  59        PKG-TYPE ABSTRACT-CAREFUL? ABSTRACT-NOISY? SEARCH ABSTRACT-IGNORE?>
  60
  61 ;"<ABSTRACT-PACKAGE package:STRING OPT abstract:<OR STRING FALSE>>
  62   if package can be abstracted
  63      if abstract is unbound or not false
  64         returns the name of the abstract file (default: package.abstr)
  65      else
  66         returns vector of two elements:
  67         [1] list of forms representing package abstract
  68         [2] the associated oblist path
  69   else
  70      returns false describing why package cannot be abstracted."
  71
  72 ;"<DESCRIBE-PACKAGE fn:STRING OPT abstract?:<OR ATOM FALSE>>
  73   Returns a PKGINFO for package contained in fn. If abstract? is T, the
  74   PKGINFO will contain an abstract for package (if it can be abstracted),
  75   otherwise false. Default: T. Note: fn can be either a package name or a
  76   file name. See description of PKGINFO below."
  77
  78 ;"ABSTRACT-CAREFUL?:<OR ATOM FALSE> - If false, analysis of macros
  79   is inhibited. False is appropriate if no macro in the package to be
  80   abstracted references internal types, calls a non-primitive procedure, or
  81   references another package. Default: T."
  82
  83 ;"ABSTRACT-NOISY?:<OR ATOM FALSE> - If false, loading messages are
  84   suppressed. Default: T."
  85
  86 ;"ABSTRACT-IGNORE?:<OR ATOM FALSE> - If true, use of packages not found is
  87   ignored (an error message is written), else an error occurs."
  88
  89 ;"<SEARCH name:STRING oper:ATOM OPT path:LIST second-names:VECTOR>
  90   Search path (default L-SEARCH-PATH) for file named name using
  91   second-names. If not found, result is false. Otherwise, result
  92   depends on oper (NAME -> STRING file name, VECTOR -> VECTOR of STRING
  93   file name components, CHANNEL -> CHANNEL open to file."
  94
  95 <USE "SORTX" "ABSTR-LOADER">
  96
  97 <INCLUDE-WHEN <COMPILING? "ABSTR"> "ABSTR-DEFS">
  98 \f
  99 ;"*** Object Definitions. ***"
 100
 101 ;"A PKGINFO contains everything you ever wanted to know about a package or
 102   definition module. This structure is returned by DESCRIBE-PACKAGE. The
 103   meaning of the fields is as follows:
 104
 105         PKG-TYPE:       Either PACKAGE or DEFINITIONS.
 106         PKG-NAME:       Name of described package.
 107         PKG-CODE:       Name of package msubr file, if any.
 108         PKG-SOURCE:     Name of package mud file, if any.
 109         PKG-ENTRYS:     Entrys of package: sorted.
 110         PKG-RENTRYS:    Rentrys of package: sorted.
 111         PKG-USES:       Names of packages used by package: sorted.
 112         PKG-EXPORTS:    Names of packages exported by package: sorted.
 113         PKG-INCLUDES:   Names of definitions included by package: sorted.
 114         PKG-ABSTRACT:   False if package was not abstracted, else
 115                         a vector whose first element is the forms of the
 116                         abstract and whose second element is the associated
 117                         oblist path."
 118
 119 <COND (<NOT <VALID-TYPE? PKGINFO>>            ;"Who needs NEWSTRUC?"
 120        <BIND ((PKGINFO '<<PRIMTYPE VECTOR> ATOM
 121                                            STRING
 122                                            <OR FALSE !<VECTOR [5 STRING]>>
 123                                            <OR FALSE !<VECTOR [5 STRING]>>
 124                                            <VECTOR [REST ATOM]>
 125                                            <VECTOR [REST ATOM]>
 126                                            <VECTOR [REST STRING]>
 127                                            <VECTOR [REST STRING]>
 128                                            <VECTOR [REST STRING]>
 129                                            <OR FALSE !<VECTOR [2 LIST]>>>))
 130           <NEWTYPE PKGINFO VECTOR .PKGINFO>
 131           <SETG PKG-TYPE     <OFFSET 1  PKGINFO <2  .PKGINFO>>>
 132           <SETG PKG-NAME     <OFFSET 2  PKGINFO <3  .PKGINFO>>>
 133           <SETG PKG-CODE     <OFFSET 3  PKGINFO <4  .PKGINFO>>>
 134           <SETG PKG-SOURCE   <OFFSET 4  PKGINFO <5  .PKGINFO>>>
 135           <SETG PKG-ENTRYS   <OFFSET 5  PKGINFO <6  .PKGINFO>>>
 136           <SETG PKG-RENTRYS  <OFFSET 6  PKGINFO <7  .PKGINFO>>>
 137           <SETG PKG-USES     <OFFSET 7  PKGINFO <8  .PKGINFO>>>
 138           <SETG PKG-EXPORTS  <OFFSET 8  PKGINFO <9  .PKGINFO>>>
 139           <SETG PKG-INCLUDES <OFFSET 9  PKGINFO <10 .PKGINFO>>>
 140           <SETG PKG-ABSTRACT <OFFSET 10 PKGINFO <11 .PKGINFO>>>
 141           <MANIFEST PKG-TYPE PKG-NAME PKG-CODE PKG-SOURCE PKG-ENTRYS
 142                     PKG-RENTRYS PKG-USES PKG-EXPORTS PKG-INCLUDES
 143                     PKG-ABSTRACT>>)>
 144 \f
 145 ;"Internal types defined in ABSTR-DEFS."
 146
 147 <COND (<NOT <VALID-TYPE? ABSTRACTION>> <NEWTYPE ABSTRACTION VECTOR>)>
 148
 149 <COND (<NOT <VALID-TYPE? DU>> <NEWTYPE DU VECTOR>)>
 150
 151 ;"Names of preloaded packages - 1SEP84."
 152
 153 <SETG PRELOADED
 154       '["ARITH2" "SUBSTR" "FINDATOM" "MAP" "LIBRARY" "GC" "AMP" "PURIFY"
 155         "MISC-IO" "CHANNEL-OPERATION" "EDIT" "ENV" "GRLOAD" "DECLS" "INT"
 156         "HOMEDIR" "PKG" "ASOC" "PP" "TTY" "NETBASE"]
 157       '<VECTOR [REST STRING]>>
 158
 159 ;"Preserve pointers to redefined package/definitions operations."
 160
 161 <GDECL (*PACKAGE *ENDPACKAGE *RENTRY *USE *EXPORT *USE-WHEN *USE-TOTAL
 162         *USE-DEFER *INCLUDE *INCLUDE-WHEN *DEFINITIONS *END-DEFINITIONS
 163         *RPACKAGE *NEW-CHANNEL-TYPE *ADD-CHANNEL-OPS) <OR APPLICABLE FALSE>>
 164
 165 <COND
 166  (<NOT <FEATURE? "COMPILER">>
 167   <SETG *PACKAGE <AND <GASSIGNED? PACKAGE> ,PACKAGE>>
 168   <SETG *ENDPACKAGE <AND <GASSIGNED? ENDPACKAGE> ,ENDPACKAGE>>
 169   <SETG *RENTRY <AND <GASSIGNED? RENTRY> ,RENTRY>>
 170   <SETG *ENTRY <AND <GASSIGNED? RENTRY> ,ENTRY>>
 171   <SETG *USE <AND <GASSIGNED? USE> ,USE>>
 172   <SETG *EXPORT <AND <GASSIGNED? EXPORT> ,EXPORT>>
 173   <SETG *USE-WHEN <AND <GASSIGNED? USE-WHEN> ,USE-WHEN>>
 174   <SETG *USE-TOTAL <AND <GASSIGNED? USE-TOTAL> ,USE-TOTAL>>
 175   <SETG *USE-DEFER <AND <GASSIGNED? USE-DEFER> ,USE-DEFER>>
 176   <SETG *INCLUDE <AND <GASSIGNED? INCLUDE> ,INCLUDE>>
 177   <SETG *INCLUDE-WHEN <AND <GASSIGNED? INCLUDE-WHEN> ,INCLUDE-WHEN>>
 178   <SETG *DEFINITIONS <AND <GASSIGNED? DEFINITIONS> ,DEFINITIONS>>
 179   <SETG *END-DEFINITIONS <AND <GASSIGNED? END-DEFINITIONS> ,END-DEFINITIONS>>
 180   <SETG *RPACKAGE <AND <GASSIGNED? RPACKAGE> ,RPACKAGE>>
 181   <SETG *NEW-CHANNEL-TYPE
 182         <AND <GASSIGNED? NEW-CHANNEL-TYPE> ,NEW-CHANNEL-TYPE>>
 183   <SETG *ADD-CHANNEL-OPS
 184         <AND <GASSIGNED? ADD-CHANNEL-OPS> ,ADD-CHANNEL-OPS>>)>
 185 \f
 186 ;"*** Global State. ***"
 187
 188 ;"ABSTRACT-CAREFUL? - If false, macros are not checked. If it is known
 189   that macros in a package call only primitive operations and that all types
 190   in the macro are primitive or defined by entrys or rentrys then false is
 191   appropriate. Default is careful."
 192
 193 <OR <GASSIGNED? ABSTRACT-CAREFUL?> <SETG ABSTRACT-CAREFUL? T '<OR ATOM FALSE>>>
 194
 195 ;"ABSTRACT-NOISY? - Controls whether or not loading messages are printed.
 196   Default is noisy."
 197
 198 <OR <GASSIGNED? ABSTRACT-NOISY?> <SETG ABSTRACT-NOISY? T '<OR ATOM FALSE>>>
 199
 200 ;"ABSTRACT-IGNORE? - Controls behavior in the event that a package cannot be
 201   loaded. Default is careful."
 202
 203 <OR <GASSIGNED? ABSTRACT-IGNORE?> <SETG ABSTRACT-IGNORE? %<> '<OR ATOM FALSE>>>
 204
 205 ;"DU-LIST-VALID? - T iff last abstraction returned normally."
 206
 207 <SETG DU-LIST-VALID? %<> '<OR ATOM FALSE>>
 208
 209 ;"TOPLEVEL-DU - Represents the package to be abstracted: initially false."
 210
 211 <GDECL (TOPLEVEL-DU) <OR DU FALSE>>
 212
 213 ;"CURRENT-DU - Points to the DU under construction for package or definition
 214   module that is currently being evaluated."
 215
 216 <GDECL (CURRENT-DU) DU>
 217
 218 ;"USED-DU-LIST - Contains every DU ever created during abstraction
 219   process so that DUs can be reused. Initially empty."
 220
 221 ;"DU-STACK - Partially completed DUs that have been pushed because the
 222   corresponding source files used other packages for which DUs must be
 223   constructed. Initially empty."
 224
 225 <GDECL (USED-DU-LIST DU-STACK) <LIST [REST DU]>>
 226
 227 ;"ABSTRACT - Contains the body of the abstraction and its associated oblist
 228   path. Initially empty, forms are enqueued as needed during abstraction."
 229
 230 <GDECL (ABSTRACT) ABSTRACTION>
 231
 232 ;"NAME-STACK - Top is the atom currently being analyzed. Maintained by
 233   ABSTR-GROVEL for informational purposes in the event of an error."
 234
 235 ;"ABSTRACTED - Contains every atom that has been ABSTRACTED during
 236   abstraction process to break recursion and prevent duplications."
 237
 238 <GDECL (ABSTRACTED NAME-STACK) <LIST [REST ATOM]>>
 239 \f
 240 ;"*** Operations ***"
 241
 242 ;"ABSTRACT-PACKAGE - Given the name of a package or definition module to
 243   abstract, analyzes the package to determine the minimum amount of
 244   information necessary to describe the interface. Writes the information
 245   to specified file. All functions to be abstracted must be compiled.
 246   Returns the abstract (file name or forms) if successful, else false."
 247
 248 <DEFINE ABSTRACT-PACKAGE AP (NAME "OPT" OFN
 249                                   "AUX" (OCH %<>) (OBLIS .OBLIST))
 250    #DECL ((NAME) STRING (AP) <SPECIAL FRAME> (OFN) <OR FALSE STRING>
 251           (OCH) <OR <CHANNEL 'DISK> FALSE> (OBLIS) <LIST [REST OBLIST]>)
 252    <SET NAME <EXTRACT-NM1 .NAME>>
 253    <UNWIND <BIND (ABSTR)
 254               #DECL ((ABSTR) !<VECTOR [2 LIST]>)
 255               <BUILD-DU .NAME>
 256               <COND (<NOT ,TOPLEVEL-DU>     ;"Make sure we built a DU."
 257                      <BARF !,TOPLEVEL-DU ABSTRACT-PACKAGE>)>
 258               <COND (<NOT <ASSIGNED? OFN>>  ;"Then use default name."
 259                      <BIND ((NM2 "ABSTR")
 260                             (CH <CHANNEL-OPEN PARSE .NAME>))
 261                         #DECL ((NM2) <SPECIAL STRING> (CH) <CHANNEL 'PARSE>)
 262                         <SET OFN <CHANNEL-OP .CH NAME>>
 263                         <CHANNEL-CLOSE .CH>>)>
 264               <COND (.OFN
 265                      <SET OCH <CHANNEL-OPEN DISK .OFN "CREATE" "ASCII">>
 266                      <COND (<NOT .OCH>
 267                             <BARF CANT-OPEN-OUTPUT-FILE!-ERRORS
 268                                   .OFN .OCH ABSTRACT-PACKAGE>)>)>
 269               ;"Create the abstraction and associated oblist path."
 270               <SET ABSTR <ABSTR-CREATE>>
 271               <SETG TOPLEVEL-DU %<>>
 272               <CRLF>
 273               <COND (.OCH
 274                      ;"Set up oblist path for printing abstraction and do it."
 275                      <BLOCK <2 .ABSTR>>
 276                      <MAPF %<>
 277                            <FUNCTION (FROB) #DECL ((FROB) FORM)
 278                               <PRIN1 .FROB .OCH> <CRLF .OCH>>
 279                            <1 .ABSTR>>
 280                      <ENDBLOCK>
 281                      <SET OFN <CHANNEL-OP .OCH NAME>>
 282                      <CLOSE .OCH>
 283                      ;"Return the name of the abstraction file."
 284                      .OFN)
 285                     (T
 286                      ;"Return abstraction forms and oblist path."
 287                      .ABSTR)>>
 288            ;"If there was an error - try to clean up ..."
 289            <BIND () <SET OBLIST .OBLIS> <COND (.OCH <FLUSH .OCH>)>>>>
 290 \f
 291 ;"DESCRIBE-PACKAGE - Constructs and returns a PKGINFO for NAME. If ABSTRACT?
 292   is false, no abstract will be created, otherwise an abstract is attempted
 293   (the abstract will be false if the package cannot be abstracted)."
 294
 295 <DEFINE DESCRIBE-PACKAGE (NAME "OPT" (ABSTRACT? T) "AUX" (OBLIS .OBLIST))
 296    #DECL ((NAME) STRING (ABSTRACT?) <OR ATOM FALSE>
 297           (OBLIS) <LIST [REST OBLIST]>)
 298    <SET NAME <EXTRACT-NM1 .NAME>>
 299    <UNWIND <PROG ((ABSTR %<>) (OUTCHAN .OUTCHAN))
 300               #DECL ((OUTCHAN) CHANNEL (ABSTR) <OR FALSE !<VECTOR [2 LIST]>>)
 301               <BUILD-DU .NAME>
 302               <COND (<NOT ,TOPLEVEL-DU> <RETURN ,TOPLEVEL-DU:FALSE>)>
 303               <COND (.ABSTRACT?                  ;"Create abstract if desired."
 304                      <COND (<SET ABSTR <PROG AP () #DECL ((AP) <SPECIAL FRAME>)
 305                                           <ABSTR-CREATE>>>)
 306                            (,ABSTRACT-NOISY?
 307                             <CRLF>
 308                             <PRINTSTRING <STRING "Cant abstract " .NAME ":">>
 309                             <MAPF %<>
 310                                   <FUNCTION (R) <CRLF> <PRINC .R>>
 311                                   .ABSTR>)>)>
 312               <CRLF>
 313               <BIND ((TDU ,TOPLEVEL-DU) (PATH ,L-SEARCH-PATH))
 314                  #DECL ((TDU) DU (PATH) <LIST [REST <OR VECTOR STRING>]>)
 315                  <SETG TOPLEVEL-DU %<>>
 316                  <CHTYPE [<COND (<DU-IOBL .TDU> PACKAGE) (T DEFINITIONS)>
 317                           <DU-NAME .TDU>
 318                           <SEARCH .NAME VECTOR .PATH '["MBIN" "GSUBR" "MSUBR"]>
 319                           <SEARCH .NAME VECTOR .PATH '["MUD"]>
 320                           <SORTA [!<DU-ENTRIES .TDU>]>
 321                           <SORTA [!<DU-RENTRIES .TDU>]>
 322                           <SORTS <MAPF ,VECTOR ,DU-NAME <DU-USES .TDU>>>
 323                           <SORTS <MAPF ,VECTOR ,DU-NAME <DU-EXPORTS .TDU>>>
 324                           <SORTS <MAPF ,VECTOR ,DU-NAME <DU-INCLUDES .TDU>>>
 325                           .ABSTR]
 326                          PKGINFO>>>
 327            ;"If there was an error, try to clean up."
 328            <SET OBLIST .OBLIS>>>
 329 \f
 330 ;"*** Description Units (DUs) are built by following routines: First Pass. ***"
 331
 332 ;"BUILD-DU - If USED-DU-LIST is valid, and a DU for NAME is found, then
 333   it becomes TOPLEVEL-DU. Otherwise, the package corresponding to NAME is
 334   loaded, creating TOPLEVEL-DU in the process."
 335
 336 <DEFINE BUILD-DU (NAME "AUX" (ICH %<>))
 337    #DECL ((NAME) STRING (ICH) <OR CHANNEL FALSE>)
 338    <COND (<NOT <AND <GASSIGNED? DU-LIST-VALID?> ,DU-LIST-VALID?
 339                     <GASSIGNED? USED-DU-LIST>>>
 340           <SETG USED-DU-LIST '()>)>
 341    <COND (<NOT <SETG TOPLEVEL-DU <FIND-DU .NAME>>>
 342           <COND (<SET ICH <SEARCH .NAME CHANNEL>>
 343                  <SETG DU-LIST-VALID? %<>>
 344                  <UNWIND <BIND ((REDEFINE T)) #DECL ((REDEFINE) <SPECIAL ANY>)
 345                             <BLURB "Loading: " <CHANNEL-OP .ICH NAME>>
 346                             <SETG DU-STACK '()>
 347                             <REDEFINE-ENVIRONMENT>
 348                             <LOAD .ICH>
 349                             <RESTORE-ENVIRONMENT>
 350                             <CLOSE .ICH>
 351                             <GUNASSIGN CURRENT-DU>
 352                             <GUNASSIGN DU-STACK>>
 353                          <BIND ()
 354                             <RESTORE-ENVIRONMENT>
 355                             <CLOSE .ICH>
 356                             <GUNASSIGN CURRENT-DU>
 357                             <GUNASSIGN DU-STACK>>>
 358                  <SETG DU-LIST-VALID? T>)
 359                 (T
 360                  <BARF <STRING "Not found: " .NAME> BUILD-DU>
 361                  <SETG TOPLEVEL-DU .ICH>)>)>
 362    T>
 363
 364 ;"REDEFINE-ENVIRONMENT - Replace definitions of package routines with
 365   routines that manipulate global state (build DUs) as well as loading
 366   and evaluating packages (or definition modules)."
 367
 368 <DEFINE REDEFINE-ENVIRONMENT ()
 369    <SETG PACKAGE ,ABSTR-PACKAGE>
 370    <SETG ENDPACKAGE ,ABSTR-ENDPACKAGE>
 371    <SETG RENTRY ,ABSTR-RENTRY>
 372    <SETG ENTRY ,ABSTR-ENTRY>
 373    <SETG USE ,ABSTR-USE>
 374    <SETG EXPORT ,ABSTR-EXPORT>
 375    <SETG USE-WHEN ,ABSTR-USE-WHEN>
 376    <SETG USE-TOTAL ,ABSTR-USE-TOTAL>
 377    <SETG USE-DEFER ,ABSTR-USE>              ;"Disallow deferral."
 378    <SETG INCLUDE ,ABSTR-INCLUDE>
 379    <SETG INCLUDE-WHEN ,ABSTR-INCLUDE-WHEN>
 380    <SETG DEFINITIONS ,ABSTR-DEFINITIONS>
 381    <SETG END-DEFINITIONS ,ABSTR-END-DEFINITIONS>
 382    <SETG RPACKAGE ,ABSTR-RPACKAGE>
 383    <SETG NEW-CHANNEL-TYPE ,ABSTR-NEW-CHANNEL-TYPE>
 384    <SETG ADD-CHANNEL-OPS ,ABSTR-ADD-CHANNEL-OPS>
 385    T>
 386 \f
 387 ;"RESTORE-ENVIRONMENT - Restore normal definitions of package routines."
 388
 389 <DEFINE RESTORE-ENVIRONMENT ()
 390    <SETG PACKAGE ,*PACKAGE>
 391    <SETG ENDPACKAGE ,*ENDPACKAGE>
 392    <SETG RENTRY ,*RENTRY>
 393    <SETG ENTRY ,*ENTRY>
 394    <SETG USE ,*USE>
 395    <SETG EXPORT ,*EXPORT>
 396    <SETG USE-WHEN ,*USE-WHEN>
 397    <SETG USE-TOTAL ,*USE-TOTAL>
 398    <SETG USE-DEFER ,*USE-DEFER>
 399    <SETG INCLUDE ,*INCLUDE>
 400    <SETG INCLUDE-WHEN ,*INCLUDE-WHEN>
 401    <SETG DEFINITIONS ,*DEFINITIONS>
 402    <SETG END-DEFINITIONS ,*END-DEFINITIONS>
 403    <SETG RPACKAGE ,*RPACKAGE>
 404    <SETG NEW-CHANNEL-TYPE ,*NEW-CHANNEL-TYPE>
 405    <SETG ADD-CHANNEL-OPS ,*ADD-CHANNEL-OPS>
 406    T>
 407
 408 ;"ABSTR-PACKAGE - Replaces definition of PACKAGE during abstraction process.
 409   Performs the actions that PACKAGE performs, creates a DU for the package,
 410   adds the new DU to USED-DU-LIST, pushes CURRENT-DU onto DU-STACK and sets
 411   CURRENT-DU to be the new DU."
 412
 413 <DEFINE ABSTR-PACKAGE (NAME "OPT" INAME
 414                             "AUX" OBL IOBL NEW-DU (TNAME <TRANSLATED .NAME>))
 415    #DECL ((NAME INAME TNAME) STRING (OBL IOBL) <OR ATOM OBLIST FALSE>
 416           (NEW-DU) DU)
 417    <SET INAME <STRING !\I .TNAME>>
 418    <COND (<SET OBL <LOOKUP .TNAME #OBLIST PACKAGE>>     ;"Flush previous."
 419           <DROP .TNAME>
 420           <REMOVE .OBL #OBLIST PACKAGE>)>
 421    <*PACKAGE .NAME .INAME>
 422    ;"Use translated name for lookup, untranslated name for DU name!"
 423    <SET OBL <CHTYPE <LOOKUP .TNAME #OBLIST PACKAGE> OBLIST>>
 424    <SET IOBL <CHTYPE <LOOKUP .INAME .OBL> OBLIST>>
 425    <SET NEW-DU <CHTYPE [.NAME .OBL .IOBL '() '() '() '() '() '() %<>] DU>>
 426    <COND (,TOPLEVEL-DU
 427           <SETG DU-STACK (,CURRENT-DU !,DU-STACK)>)
 428          (T ;"First package is the file to be abstracted."
 429           <SETG TOPLEVEL-DU .NEW-DU>)>
 430    <SETG USED-DU-LIST (.NEW-DU !,USED-DU-LIST)>
 431    <SETG CURRENT-DU .NEW-DU>
 432    T>
 433 \f
 434 ;"ABSTR-DEFINITIONS - Replaces definition of DEFINITIONS during abstraction
 435   process. Performs the actions that DEFINITIONS performs, creates a DU for
 436   the definition module, adds the new DU to USED-DU-LIST, pushes CURRENT-DU
 437   onto DU-STACK and sets CURRENT-DU to be the new DU."
 438
 439 <DEFINE ABSTR-DEFINITIONS (NAME "AUX" OBL NEW-DU (TNAME <TRANSLATED .NAME>))
 440    #DECL ((TNAME NAME) STRING (OBL) <OR ATOM OBLIST FALSE> (NEW-DU) DU)
 441    <COND (<SET OBL <LOOKUP .TNAME #OBLIST PACKAGE>>     ;"Flush previous."
 442           <DROP .TNAME>
 443           <REMOVE .OBL #OBLIST PACKAGE>)>
 444    <*DEFINITIONS .NAME>
 445    ;"Use translated name for lookup, untranslated name for DU name!"
 446    <SET OBL <CHTYPE <LOOKUP <TRANSLATED .NAME> <MOBLIST PACKAGE>> OBLIST>>
 447    <SET NEW-DU <CHTYPE [.NAME .OBL %<> '() '() '() '() '() '() %<>] DU>>
 448    <COND (,TOPLEVEL-DU
 449           <SETG DU-STACK (,CURRENT-DU !,DU-STACK)>)
 450          (T ;"First definitions is the file to be abstracted."
 451           <SETG TOPLEVEL-DU .NEW-DU>)>
 452    <SETG USED-DU-LIST (.NEW-DU !,USED-DU-LIST)>
 453    <SETG CURRENT-DU .NEW-DU>
 454    T>
 455
 456 ;"ABSTR-USE - Replaces definition of USE during abstraction process. Performs
 457   the actions that USE performs. If a DU does not exist, the package
 458   is loaded (which creates a DU) otherwise the existing DU is used. The DU
 459   for each name is prepended to the uses list of CURRENT-DU."
 460
 461 <DEFINE ABSTR-USE ("TUPLE" NAMES)
 462    #DECL ((NAMES) <<PRIMTYPE VECTOR> [REST STRING]>)
 463    <PROG ((CDU ,CURRENT-DU) DU?)
 464       #DECL ((DU?) <OR FALSE DU> (CDU) DU)
 465       <COND (<NOT ,TOPLEVEL-DU>
 466              <BARF TOPLEVEL-MODULE-IS-NEITHER-PACKAGE-NOR-DEFINITIONS!-ERRORS
 467                    ABSTR-USE>
 468              <RETURN %<>>)>
 469       <SET NAMES
 470            <MAPF ,VECTOR
 471                  <FUNCTION (NAME)
 472                     #DECL ((NAME) STRING)
 473                     <COND (<NOT <SET DU? <FIND-DU .NAME>>>
 474                            <LOAD-PACKAGE .NAME>
 475                            <SET DU? <FIND-DU .NAME>>)>
 476                     <COND (.DU?
 477                            <DU-USES .CDU (.DU? !<DU-USES .CDU>)>
 478                            <MAPRET .NAME>)
 479                           (<AND <GASSIGNED? ABSTRACT-IGNORE?> ,ABSTRACT-IGNORE?>
 480                            <MESSAGE PACKAGE-NOT-FOUND!-ERRORS .NAME ABSTR-USE>
 481                            <MAPRET>)
 482                           (T
 483                            <BARF PACKAGE-NOT-FOUND!-ERRORS .NAME ABSTR-USE>
 484                            <MAPRET>)>>
 485                  .NAMES>>
 486       <*USE !.NAMES>>>
 487
 488 \f
 489 ;"ABSTR-INCLUDE - Replaces definition of INCLUDE during abstraction
 490   process.  Performs the actions that INCLUDE performs. If a DU does not
 491   exist, the definitions is loaded (which creates a DU) otherwise the existing
 492   DU is used. The DU for each name is prepended to the includes list of
 493   CURRENT-DU."
 494
 495 <DEFINE ABSTR-INCLUDE ("TUPLE" NAMES)
 496    #DECL ((NAMES) <<PRIMTYPE VECTOR> [REST STRING]>)
 497    <PROG ((CDU ,CURRENT-DU) DU?)
 498       #DECL ((DU?) <OR FALSE DU> (CDU) DU)
 499       <COND (<NOT ,TOPLEVEL-DU>
 500              <BARF TOPLEVEL-MODULE-IS-NEITHER-PACKAGE-NOR-DEFINITIONS!-ERRORS
 501                    ABSTR-INCLUDE>
 502              <RETURN %<>>)>
 503       <SET NAMES
 504            <MAPF ,VECTOR
 505                  <FUNCTION (NAME)
 506                     #DECL ((NAME) STRING)
 507                     <COND (<NOT <SET DU? <FIND-DU .NAME>>>
 508                            <LOAD-PACKAGE .NAME>
 509                            <SET DU? <FIND-DU .NAME>>)>
 510                     <COND (.DU?
 511                            <DU-INCLUDES .CDU (.DU? !<DU-INCLUDES .CDU>)>
 512                            <MAPRET .NAME>)
 513                           (<AND <GASSIGNED? ABSTRACT-IGNORE?> ,ABSTRACT-IGNORE?>
 514                            <MESSAGE DEFINITIONS-NOT-FOUND!-ERRORS .NAME
 515                                     ABSTR-INCLUDE>
 516                            <MAPRET>)
 517                           (T
 518                            <BARF DEFINITIONS-NOT-FOUND!-ERRORS .NAME
 519                                  ABSTR-INCLUDE>
 520                            <MAPRET>)>>
 521                  .NAMES>>
 522       <*INCLUDE !.NAMES>>
 523    T>
 524
 525 ;"ABSTR-EXPORT - Replaces definition of EXPORT during abstraction process.
 526   Performs the actions that EXPORT performs. If a DU does not exist,
 527   the package is loaded (which creates a DU) otherwise the existing DU is
 528   used. The DU for each name is prepended to the exports list of CURRENT-DU."
 529
 530 <DEFINE ABSTR-EXPORT ("TUPLE" NAMES)
 531    #DECL ((NAMES) <<PRIMTYPE VECTOR> [REST STRING]>)
 532    <PROG ((CDU ,CURRENT-DU) DU?)
 533       #DECL ((DU?) <OR FALSE DU> (CDU) DU)
 534       <COND (<NOT ,TOPLEVEL-DU>
 535              <BARF TOPLEVEL-MODULE-IS-NEITHER-PACKAGE-NOR-DEFINITIONS!-ERRORS
 536                    ABSTR-EXPORT>
 537              <RETURN %<>>)>
 538       <SET NAMES
 539            <MAPF ,VECTOR
 540                  <FUNCTION (NAME)
 541                     #DECL ((NAME) STRING)
 542                     <COND (<NOT <SET DU? <FIND-DU .NAME>>>
 543                            <LOAD-PACKAGE .NAME>
 544                            <SET DU? <FIND-DU .NAME>>)>
 545                     <COND (.DU?
 546                            <DU-EXPORTS .CDU (.DU? !<DU-EXPORTS .CDU>)>
 547                            <MAPRET .NAME>)
 548                           (<AND <GASSIGNED? ABSTRACT-IGNORE?> ,ABSTRACT-IGNORE?>
 549                            <MESSAGE PACKAGE-NOT-FOUND!-ERRORS .NAME ABSTR-EXPORT>
 550                            <MAPRET>)
 551                           (T
 552                            <BARF PACKAGE-NOT-FOUND!-ERRORS .NAME ABSTR-EXPORT>
 553                            <MAPRET>)>>
 554                  .NAMES>>
 555       <*EXPORT !.NAMES>>
 556    T>
 557
 558 ;"ABSTR-RENTRY - Replaces definition of RENTRY during abstraction process.
 559   Performs the actions that entry performs and prepends NAMES to rentry list
 560   of CURRENT-DU."
 561
 562 <DEFINE ABSTR-RENTRY ("TUPLE" NAMES "AUX" (CDU ,CURRENT-DU))
 563    #DECL ((NAMES) <<PRIMTYPE VECTOR> [REST ATOM]> (CDU) DU)
 564    <*RENTRY !.NAMES>
 565    <DU-RENTRIES .CDU (!.NAMES !<DU-RENTRIES .CDU>)>
 566    T>
 567 \f
 568 ;"ABSTR-ENTRY - Replaces definition of ENTRY during abstraction process.
 569   Performs the actions that entry performs and prepends NAMES to entry list
 570   of CURRENT-DU."
 571
 572 <DEFINE ABSTR-ENTRY ("TUPLE" NAMES "AUX" (CDU ,CURRENT-DU))
 573    #DECL ((NAMES) <<PRIMTYPE VECTOR> [REST ATOM]> (CDU) DU)
 574    <*ENTRY !.NAMES>
 575    <DU-ENTRIES .CDU (!.NAMES !<DU-ENTRIES .CDU>)>
 576    T>
 577
 578 ;"ABSTR-ENDPACKAGE - Replaces definition of ENDPACKAGE during abstraction
 579   process. Performs the actions that ENDPACKAGE performs, then sets CURRENT-DU
 580   to be the top of DU-STACK and pops DU-STACK."
 581
 582 <DEFINE ABSTR-ENDPACKAGE ("OPT" NAME "AUX" (STK ,DU-STACK))
 583    #DECL ((NAME) STRING (STK) <LIST [REST DU]>)
 584    <COND (<ASSIGNED? NAME> <*ENDPACKAGE .NAME>) (T <*ENDPACKAGE>)>
 585    <COND (<NOT <EMPTY? .STK>>           ;"Empty => CURRENT-DU == TOPLEVEL-DU."
 586           <SETG CURRENT-DU <1 .STK>>
 587           <SETG DU-STACK <REST .STK>>)>
 588    T>
 589
 590 ;"ABSTR-END-DEFINITIONS - Replaces definition of END-DEFINITIONS during
 591   abstraction process. Performs the actions that END-DEFINITIONS performs,
 592   puts the entry list into CURRENT-DU, then sets CURRENT-DU to be the top
 593   of DU-STACK and pops DU-STACK."
 594
 595 <DEFINE ABSTR-END-DEFINITIONS ("OPT" NAME
 596                                "AUX" (STK ,DU-STACK) (CDU ,CURRENT-DU)
 597                                      (L '()) (OBL <DU-OBL .CDU>))
 598    #DECL ((STK) <LIST [REST DU]> (CDU) DU (L) LIST (OBL) OBLIST)
 599    <COND (<ASSIGNED? NAME> <*END-DEFINITIONS .NAME>) (T <*END-DEFINITIONS>)>
 600    ;"Get the entry oblist - every atom in definition module is an entry."
 601    <MAPF %<>
 602          <FUNCTION (BKT)
 603             #DECL ((BKT) LIST)
 604             <MAPF %<>
 605                   <FUNCTION (ATM)
 606                      #DECL ((ATM) <PRIMTYPE ATOM>)
 607                      <COND (<==? <OBLIST? <CHTYPE .ATM ATOM>> .OBL>
 608                             <SET L (.ATM !.L)>)>>
 609                   .BKT>>
 610          ,ATOM-TABLE>
 611    <DU-ENTRIES .CDU .L>
 612    <COND (<NOT <EMPTY? .STK>>           ;"Empty => CURRENT-DU == TOPLEVEL-DU."
 613           <SETG CURRENT-DU <1 .STK>>
 614           <SETG DU-STACK <REST .STK>>)>
 615    T>
 616
 617 ;"ABSTR-USE-WHEN - Force usage to occur during abstraction."
 618
 619 <DEFINE ABSTR-USE-WHEN ('TEST "TUPLE" NAMES)
 620    #DECL ((NAMES) <<PRIMTYPE VECTOR> [REST STRING]>)
 621    <ABSTR-USE !.NAMES>>
 622
 623 ;"ABSTR-INCLUDE-WHEN - Force inclusion to occur during abstraction."
 624
 625 <DEFINE ABSTR-INCLUDE-WHEN ('TEST "TUPLE" NAMES)
 626    #DECL ((NAMES) <<PRIMTYPE VECTOR> [REST STRING]>)
 627    <ABSTR-INCLUDE !.NAMES>>
 628 \f
 629 ;"ABSTR-USE-TOTAL - Barf becuase USE-TOTAL should not appear in package."
 630
 631 <DEFINE ABSTR-USE-TOTAL ("TUPLE" JUNK)
 632    <BARF USE-TOTAL-IN-FILE!-ERRORS !.JUNK ABSTR-USE-TOTAL>
 633    %<>>
 634
 635 ;"ABSTR-RPACKAGE - Barf becuase RPACKAGE is obsolete."
 636
 637 <DEFINE ABSTR-RPACKAGE ("TUPLE" JUNK)
 638    <BARF RPACKAGE-IN-FILE!-ERRORS !.JUNK ABSTR-USE-TOTAL>
 639    %<>>
 640
 641 ;"ABSTR-NEW-CHANNEL-TYPE - Replaces definition of NEW-CHANNEL-TYPE during
 642   abstraction process. Performs the actions that NEW-CHANNEL-TYPE performs
 643   then adds the new channel type to the list of special forms of CURRENT-DU."
 644
 645 <DEFINE ABSTR-NEW-CHANNEL-TYPE (NAME INHERIT "TUPLE" SHIT "AUX" CDU DUS)
 646    #DECL ((NAME) ATOM (INHERIT) <OR FALSE ATOM <LIST [REST ATOM]>>
 647           (SHIT) <<PRIMTYPE VECTOR> [REST ATOM <OR MSUBR ATOM FALSE>]>
 648           (CDU) DU (DUS) <LIST [REST FORM]>)
 649    <*NEW-CHANNEL-TYPE .NAME .INHERIT !.SHIT>
 650    <REPEAT ((RSHIT .SHIT))
 651       #DECL ((RSHIT) <<PRIMTYPE VECTOR> [REST ATOM <OR MSUBR ATOM FALSE>]>)
 652       <COND (<EMPTY? .RSHIT> <RETURN>)
 653             (<TYPE? <2 .RSHIT> MSUBR> <2 .RSHIT <MSUBR-NAME <2 .RSHIT>>>)>
 654       <SET RSHIT <REST .RSHIT 2>>>
 655    <COND (<NOT ,TOPLEVEL-DU>
 656           <BARF TOPLEVEL-MODULE-IS-NEITHER-PACKAGE-NOR-DEFINITIONS!-ERRORS
 657                 ABSTR-NEW-CHANNEL-TYPE>)
 658          (<EMPTY? <SET DUS <DU-SPECIAL <SET CDU ,CURRENT-DU>>>>
 659           <DU-SPECIAL .CDU
 660                       (<CHTYPE (NEW-CHANNEL-TYPE .NAME .INHERIT !.SHIT)
 661                                FORM>)>)
 662          (T
 663           <PUTREST <REST .DUS <- <LENGTH .DUS> 1>>
 664                    (<CHTYPE (NEW-CHANNEL-TYPE .NAME .INHERIT !.SHIT) FORM>)>)>
 665    T>
 666
 667 ;"ABSTR-ADD-CHANNEL-OPS - Replaces definition of ADD-CHANNEL-OPS during
 668   abstraction process. Performs the actions that ADD-CHANNEL-OPS performs
 669   then adds the new channel type to the list of special forms of CURRENT-DU."
 670
 671 <DEFINE ABSTR-ADD-CHANNEL-OPS (NAME "TUPLE" SHIT "AUX" CDU DUS)
 672    #DECL ((NAME) ATOM (CDU) DU (DUS) <LIST [REST FORM]>
 673           (SHIT) <<PRIMTYPE VECTOR> [REST ATOM <OR MSUBR ATOM FALSE>]>)
 674    <*ADD-CHANNEL-OPS .NAME !.SHIT>
 675    <REPEAT ((RSHIT .SHIT))
 676       #DECL ((RSHIT) <<PRIMTYPE VECTOR> [REST ATOM <OR MSUBR ATOM FALSE>]>)
 677       <COND (<EMPTY? .RSHIT> <RETURN>)
 678             (<TYPE? <2 .RSHIT> MSUBR> <2 .RSHIT <MSUBR-NAME <2 .RSHIT>>>)>
 679       <SET RSHIT <REST .RSHIT 2>>>
 680    <COND (<NOT ,TOPLEVEL-DU>
 681           <BARF TOPLEVEL-MODULE-IS-NEITHER-PACKAGE-NOR-DEFINITIONS!-ERRORS
 682                 ABSTR-ADD-CHANNEL-OPS>)
 683          (<EMPTY? <SET DUS <DU-SPECIAL <SET CDU ,CURRENT-DU>>>>
 684           <DU-SPECIAL .CDU
 685                       (<CHTYPE (ADD-CHANNEL-OPS .NAME !.SHIT) FORM>)>)
 686          (T
 687           <PUTREST <REST .DUS <- <LENGTH .DUS> 1>>
 688                    (<CHTYPE (ADD-CHANNEL-OPS .NAME !.SHIT) FORM>)>)>
 689    T>
 690 \f
 691 ;"LOAD-PACKAGE - Find and load package named NAME, choking if not found.
 692   Employs the package system to open a channel to appropriate file."
 693
 694 <DEFINE LOAD-PACKAGE (NAME "AUX" (ICH <L-OPEN .NAME>))
 695    #DECL ((NAME) STRING (ICH) <OR CHANNEL FALSE>)
 696    <COND (.ICH
 697           <BLURB "Loading: " <CHANNEL-OP .ICH NAME>>
 698           <UNWIND <LOAD .ICH> <CLOSE .ICH>>
 699           <CLOSE .ICH>)
 700          (<AND <GASSIGNED? ABSTRACT-IGNORE?> ,ABSTRACT-IGNORE?> %<>)
 701          (T <BARF <STRING "Not found: " .NAME> LOAD-PACKAGE> %<>)>
 702    T>
 703
 704 ;"TRANSLATED - If NAME is translated by the library system, return the
 705   translated name, otherwise return NAME."
 706
 707 <DEFINE TRANSLATED (NAME)
 708    #DECL ((NAME) STRING)
 709    <REPEAT ((TRANSLATIONS ,L-TRANSLATIONS))
 710       #DECL ((TRANSLATIONS) <LIST [REST STRING]>)
 711       <COND (<EMPTY? .TRANSLATIONS>
 712              <RETURN .NAME>)
 713             (<=? .NAME <1 .TRANSLATIONS>>
 714              <RETURN <2 .TRANSLATIONS>>)
 715             (T
 716              <SET TRANSLATIONS <REST .TRANSLATIONS 2>>)>>>
 717
 718 ;"FIND-DU - Search USED-DU-LIST for DU named NAME, returning the DU if found.
 719   Else, if NAME is the name of preloaded package, create a dummy DU for
 720   preloaded package and return it. Otherwise, return false."
 721
 722 <DEFINE FIND-DU (NAME)
 723    #DECL ((NAME) STRING)
 724    <REPEAT ((USED ,USED-DU-LIST))
 725       #DECL ((USED) <LIST [REST DU]>)
 726       <COND (<EMPTY? .USED>
 727              <BIND ((P <MEMBER .NAME ,PRELOADED>))
 728                 #DECL ((P) <OR FALSE <VECTOR STRING>>)
 729                 <COND (.P <RETURN <CREATE-PRELOADED-DU <1 .P>>>)
 730                       (T <RETURN %<>>)>>)
 731             (<=? .NAME <DU-NAME <1 .USED>>>
 732              <RETURN <1 .USED>>)
 733             (T
 734              <SET USED <REST .USED>>)>>>
 735
 736 ;"CREATE-PRELOADED-DU - Creates and returns a dummy DU for NAME where NAME
 737   is the name of a preloaded package. The oblist, internal oblist, and name
 738   slots are set appropriately, but the entries, rentries, uses, and exports
 739   are empty. Adds created DU to USED-DU-LIST."
 740
 741 <DEFINE CREATE-PRELOADED-DU (NAME "AUX" OBL IOBL PDU)
 742    #DECL ((NAME) STRING (OBL IOBL) <OR ATOM OBLIST FALSE> (PDU) DU)
 743    <COND (<AND <SET OBL <LOOKUP .NAME <MOBLIST PACKAGE>>>
 744                <SET OBL <CHTYPE .OBL OBLIST>>>
 745           <COND (<SET IOBL <LOOKUP <STRING !\I .NAME> .OBL>>
 746                  <SET IOBL <CHTYPE .IOBL OBLIST>>)>
 747           <SET PDU <CHTYPE [.NAME .OBL .IOBL '() '() '() '() '() '() %<>] DU>>
 748           <SETG USED-DU-LIST (.PDU !,USED-DU-LIST)>
 749           .PDU)
 750          (T
 751           <BARF PRELOADED-PKG-NOT-LOADED!-ERRORS .NAME CREATE-PRELOADED-DU>
 752           %<>)>>
 753 \f
 754 ;"*** Following routines implement analysis of DUs: Second Pass. ***"
 755
 756 ;"ABSTR-CREATE - Analyze the package corresponding to TOPLEVEL-DU. If no error
 757   arises during analysis, returns a vector of two elements: the first is the
 758   forms of the abstract and the second is the associated oblist path. Assumes
 759   global state is appropriately initialized."
 760
 761 <DEFINE ABSTR-CREATE ("AUX" (TDU ,TOPLEVEL-DU)
 762                             (ABSTRACT <SETG ABSTRACT <NEW-ABSTRACTION>>)
 763                             (PRELOADED ,PRELOADED) BODY TAIL PATH STRINGS)
 764    #DECL ((ABSTRACT) ABSTRACTION (PRELOADED) <VECTOR [REST STRING]>
 765           (BODY TAIL) <LIST ANY> (TDU) DU (PATH) <LIST [REST OBLIST]>
 766           (STRINGS) <LIST [REST STRING]>)
 767    <BLURB "Abstracting: " <DU-NAME .TDU>>
 768    <SETG NAME-STACK '()>
 769    <SETG ABSTRACTED '()>
 770    ;"Grovel over every entry and rentry atom in package, adding information
 771      to ABSTRACT when necessary. Create the body of the abstraction. Grovel
 772      over special forms."
 773    <UNWIND <BIND ()
 774               <MAPF %<>
 775                     <FUNCTION (A) #DECL ((A) ATOM) <ABSTR-GROVEL .A>>
 776                     (!<DU-RENTRIES .TDU> !<DU-ENTRIES .TDU>)>
 777               <ABSTR-GROVEL-SPECIAL <DU-SPECIAL .TDU>>>
 778            <BIND ()
 779               <GUNASSIGN NAME-STACK>
 780               <GUNASSIGN ABSTRACT>
 781               <GUNASSIGN ABSTRACTED>
 782               <MAPF %<> <FUNCTION (UDU) #DECL ((UDU) DU) <UNMARK-DU .UDU>>
 783                     ,USED-DU-LIST>>>
 784    <GUNASSIGN NAME-STACK>
 785    <GUNASSIGN ABSTRACT>
 786    <GUNASSIGN ABSTRACTED>
 787    ;"Cons up the body of the abstraction, simultaneously setting up
 788      oblist path as if we were inside the abstraction."
 789    <COND (<DU-IOBL .TDU>
 790           <SET TAIL <SET BODY (<CHTYPE (PACKAGE <DU-NAME .TDU>) FORM>)>>
 791           <PACKAGE <DU-NAME .TDU>>)
 792          (T
 793           <SET TAIL <SET BODY (<CHTYPE (DEFINITIONS <DU-NAME .TDU>) FORM>)>>
 794           <DEFINITIONS <DU-NAME .TDU>>)>
 795    <COND (<AND <NOT <EMPTY? <DU-ENTRIES .TDU>>> <DU-IOBL .TDU>>
 796           <PUTREST .TAIL
 797                    <SET TAIL (<CHTYPE (ENTRY !<DU-ENTRIES .TDU>) FORM>)>>)>
 798    <COND (<NOT <EMPTY? <DU-RENTRIES .TDU>>>
 799           <PUTREST .TAIL
 800                    <SET TAIL (<CHTYPE (RENTRY !<DU-RENTRIES .TDU>) FORM>)>>)>
 801    <SET STRINGS <MAPF ,LIST
 802                       <FUNCTION (EDU)
 803                          #DECL ((EDU) DU)
 804                          ;"Exported packages dont need to be used."
 805                          <UNMARK-DU .EDU>
 806                          <MAPRET <DU-NAME .EDU>>>
 807                       <DU-EXPORTS .TDU>>>
 808    <COND (<NOT <EMPTY? .STRINGS>>
 809           <PUTREST .TAIL <SET TAIL (<CHTYPE (EXPORT !.STRINGS) FORM>)>>
 810           <EXPORT !.STRINGS>)>
 811 \f
 812    <SET STRINGS <MAPF ,LIST
 813                       <FUNCTION (UDU)
 814                          #DECL ((UDU) DU)
 815                          ;"Use marked and preloaded packages."
 816                          <COND (<OR <DU-MARKED? .UDU>
 817                                     <MEMQ <DU-NAME .UDU> .PRELOADED>>
 818                                 <UNMARK-DU .UDU>
 819                                 <MAPRET <DU-NAME .UDU>>)
 820                                (T
 821                                 <MAPRET>)>>
 822                       <DU-USES .TDU>>>
 823    <COND (<NOT <EMPTY? .STRINGS>>
 824           <PUTREST .TAIL <SET TAIL (<CHTYPE (USE !.STRINGS) FORM>)>>
 825           <USE !.STRINGS>)>
 826    <SET STRINGS <MAPF ,LIST
 827                       <FUNCTION (IDU)
 828                          #DECL ((IDU) DU)
 829                          ;"Include marked and preloaded definitions."
 830                          <COND (<OR <DU-MARKED? .IDU>
 831                                     <MEMQ <DU-NAME .IDU> .PRELOADED>>
 832                                 <UNMARK-DU .IDU>
 833                                 <MAPRET <DU-NAME .IDU>>)
 834                                (T
 835                                 <MAPRET>)>>
 836                       <DU-INCLUDES .TDU>>>
 837    <COND (<NOT <EMPTY? .STRINGS>>
 838           <PUTREST .TAIL <SET TAIL (<CHTYPE (INCLUDE !.STRINGS) FORM>)>>
 839           <INCLUDE !.STRINGS>)>
 840    <COND (<NOT <LENGTH? <A-TYPES .ABSTRACT> 1>>     ;"Ignore leading atom."
 841           <PUTREST .TAIL <REST <A-TYPES .ABSTRACT>>>
 842           <SET TAIL <A-TTAIL .ABSTRACT>>)>
 843    <COND (<NOT <LENGTH? <A-GVALS .ABSTRACT> 1>>     ;"Ignore leading atom."
 844           <PUTREST .TAIL <REST <A-GVALS .ABSTRACT>>>
 845           <SET TAIL <A-GTAIL .ABSTRACT>>)>
 846    <COND (<NOT <EMPTY? <A-DECLS .ABSTRACT>>>
 847           <PUTREST .TAIL
 848                    <SET TAIL (<CHTYPE (GDECL !<A-DECLS .ABSTRACT>) FORM>)>>)>
 849    <COND (<NOT <EMPTY? <A-CONST .ABSTRACT>>>
 850           <PUTREST .TAIL
 851                    <SET TAIL
 852                         (<CHTYPE (MANIFEST !<A-CONST .ABSTRACT>) FORM>)>>)>
 853    <COND (<NOT <EMPTY? <DU-SPECIAL .TDU>>>
 854           <PUTREST .TAIL <SET TAIL <LIST !<DU-SPECIAL .TDU>>>>
 855           <SET TAIL <REST .TAIL <- <LENGTH .TAIL> 1>>>)>
 856    <SET PATH <LIST !.OBLIST>>               ;"Hang onto copy of oblist path."
 857    <COND (<DU-IOBL .TDU>
 858           <PUTREST .TAIL (<CHTYPE '(ENDPACKAGE) FORM>)>
 859           <ENDPACKAGE>)
 860          (T
 861           <PUTREST .TAIL (<CHTYPE '(END-DEFINITIONS) FORM>)>
 862           <END-DEFINITIONS>)>
 863    ;"Return body of abstract and associated oblist path."
 864    [.BODY .PATH]>
 865 \f
 866 ;"ABSTR-GROVEL - Determines what information about NAME must be included in
 867   abstract. NAME should be an entry or rentry of TOPLEVEL-DU or on its internal
 868   oblist. NAME is marked ABSTRACTED to prevent cycles and duplications.
 869   This routine preserves the gvals of msubrs, macros, manifested GVALs that
 870   are not structured (except offsets are allowed). Type decls and gdecls
 871   (GDECL, PUT-DECL, NEWTYPE) are preserved."
 872
 873 <DEFINE ABSTR-GROVEL AG (NAME "AUX" VAL)
 874    #DECL ((NAME) ATOM (VAL) ANY (AG) FRAME)
 875    ;"Skip if already done or it is IMSUBR (means we are in DEFINITIONS)."
 876    <COND (<OR <MEMQ .NAME ,ABSTRACTED>
 877               <AND <GASSIGNED? .NAME> <TYPE? ,.NAME IMSUBR>>>
 878           <RETURN T .AG>)>
 879    <SETG NAME-STACK (.NAME !,NAME-STACK)>            ;"Push name onto stack."
 880    <SETG ABSTRACTED (.NAME !,ABSTRACTED)>             ;"Mark as abstracted."
 881    <COND (<OR <VALID-TYPE? .NAME> <GET-DECL .NAME>>
 882           <SET VAL <OR <GET-DECL .NAME> <TYPEPRIM .NAME>>>
 883           ;"NAME is a new type or an abbreviation for a type (PUT-DECL)."
 884           <GROVEL-DECL .VAL>
 885           <SET VAL <CHTYPE (QUOTE .VAL) FORM>>
 886           <COND (<NEWTYPE-ATOM? .NAME>
 887                  <ENQ-TYPE ,ABSTRACT
 888                            <CHTYPE (NEWTYPE .NAME <TYPEPRIM .NAME> .VAL) FORM>>)
 889                 (T
 890                  <ENQ-TYPE ,ABSTRACT <CHTYPE (PUT-DECL .NAME .VAL) FORM>>)>)>
 891    <COND (<AND <GBOUND? .NAME> <NOT <MANIFEST? .NAME>>>
 892           <COND (<SET VAL <GET-DECL <GBIND .NAME %<>>>>
 893                  <GROVEL-DECL .VAL>         ;"NAME has been gdecled."
 894                  <ENQ-DECL ,ABSTRACT .NAME .VAL>)>)>
 895    <COND (<GASSIGNED? .NAME>
 896           <SET VAL ,.NAME>
 897           <COND (<AND <MANIFEST? .NAME>
 898                       <NOT <TYPE? .VAL OFFSET>> <STRUCTURED? .VAL>>
 899                  <BARF CANT-ABSTRACT-MANIFESTED-STRUCTURE!-ERRORS
 900                        .NAME ABSTR-GROVEL>)
 901                 (<TYPE? .VAL FUNCTION>
 902                  <BARF CANT-ABSTRACT-UNCOMPILED-FUNCTION!-ERRORS .NAME
 903                        ABSTR-GROVEL>)
 904                 (<TYPE? .VAL MSUBR>
 905                  <COND (<==? <MSUBR-NAME .VAL> .NAME>
 906                         <MAPF %<>           ;"Analyze msubr argument decls."
 907                               <FUNCTION (DCL)
 908                                  <COND (<NOT <TYPE? .DCL STRING>>
 909                                         <GROVEL-DECL .DCL>)>>
 910                               <MSUBR-ARG-DECL .VAL>:<PRIMTYPE LIST>>
 911                         ;"Copy MSUBR with new magic IMSUBR name."
 912                         <SET VAL <CHTYPE <VECTOR !.VAL> MSUBR>> ;"Mung copy."
 913                         <IMSUBR-NAME .VAL <IMSUBR-NAME ,ABSTRACT-MSUBR-LOADER>>
 914                         <IMSUBR-OFFSET .VAL 0>  ;"In case it was glued."
 915                         <ENQ-GVAL ,ABSTRACT .NAME .VAL>)
 916                        (T                   ;"Preserve alias msubr names."
 917                         <IF-NEEDED <MSUBR-NAME .VAL>>
 918                         <ENQ-GVAL ,ABSTRACT .NAME <GVAL <MSUBR-NAME .VAL>>>)>)
 919                 (<TYPE? .VAL MACRO>
 920                  <GROVEL-MACRO <MACRO-BODY .VAL>>
 921                  <ENQ-GVAL ,ABSTRACT .NAME .VAL>)
 922                 (<TYPE? .VAL OFFSET>        ;"Analyze offset argument decl."
 923                  <COND (<GET-DECL .VAL>
 924                         <GROVEL-DECL <GET-DECL .VAL>>)>
 925                  <COND (<ELEMENT-DECL .VAL> ;"Analyze offset element decl."
 926                         <GROVEL-DECL <ELEMENT-DECL .VAL>>)>)
 927                 (<AND <NEWTYPE-OBJECT? .VAL> <MANIFEST? .NAME>>
 928                  <GROVEL-DECL <TYPE .VAL>>)>)>
 929    <COND (<MANIFEST? .NAME>                 ;"Setg (if needed) and manifest."
 930           <COND (<GASSIGNED? .NAME> <ENQ-GVAL ,ABSTRACT .NAME .VAL>)>
 931           <ENQ-CONST ,ABSTRACT .NAME>)>
 932    <SETG NAME-STACK <REST ,NAME-STACK>>     ;"Pop name stack."
 933    T>
 934 \f
 935 ;"ABSTR-GROVEL-SPECIAL - Handle special forms in TOPLEVEL-DU on form by form
 936   basis. Currently, NEW-CHANNEL-TYPE and ADD-CHANNEL-OPS. The first element
 937   of the form determines the action taken."
 938
 939 <DEFINE ABSTR-GROVEL-SPECIAL (SPFORMS)
 940    #DECL ((SPFORMS) <LIST [REST <FORM ATOM>]>)
 941    <REPEAT (SPFORM KIND TEMP)
 942       #DECL ((SPFORM) FORM (KIND) ATOM)
 943       <COND (<EMPTY? .SPFORMS> <RETURN>)>
 944       <SET KIND <1 <SET SPFORM <1 .SPFORMS>>>>
 945       <SET SPFORMS <REST .SPFORMS>>
 946       <COND (<==? .KIND NEW-CHANNEL-TYPE>
 947              ;"Grovel over channel types we inherit from."
 948              <COND (<TYPE? <SET TEMP <3 .SPFORM>> ATOM>
 949                     <IF-NEEDED .TEMP>)
 950                    (T
 951                     <MAPF %<>
 952                           ,IF-NEEDED
 953                           .TEMP:<<PRIMTYPE LIST> [REST ATOM]>>)>)
 954             (<==? .KIND ADD-CHANNEL-OPS>
 955              ;"Check out the channel type we are augmenting."
 956              <IF-NEEDED <2 .SPFORM>>)>>
 957    T>
 958
 959 ;"GROVEL-DECL - Analyzes a DECL pattern fringe, abstracting ATOMs where
 960   necessary by invoking IF-NEEDED for ATOMs which represent types."
 961
 962 <DEFINE GROVEL-DECL (DCL)
 963    #DECL ((DCL) <OR ATOM FORM SEGMENT VECTOR>)
 964    <COND (<TYPE? .DCL ATOM>
 965           ;"If it is a newtype or an abbreviation, then analyze if necessary."
 966           <COND (<OR <NEWTYPE-ATOM? .DCL> <GET-DECL .DCL>> <IF-NEEDED .DCL>)>)
 967          (<TYPE? .DCL FORM SEGMENT>
 968           ;"Either quoted or composite."
 969           <COND (<==? <1 .DCL> QUOTE>
 970                  <COND (<STRUCTURED? <2 .DCL>>
 971                         <BARF CANT-ABSTRACT-QUOTED-STRUCTURE-DECL!-ERRORS .DCL
 972                               GROVEL-DECL>)
 973                        (<NEWTYPE-OBJECT? <2 .DCL>>
 974                         ;"Exact non-structured type - analyze its decl."
 975                         <GROVEL-DECL <TYPE <2 .DCL>>>)
 976                        (<TYPE? <2 .DCL> ATOM>
 977                         ;"Maybe an atom from another module."
 978                         <IF-NEEDED <2 .DCL>>)>)
 979                 (T
 980                  ;"Composite type - analyze the parts of the decl."
 981                  <MAPF %<> ,GROVEL-DECL .DCL>)>)
 982          (T
 983           ;"Element specification (e.g. [REST ...]), analyze element decls."
 984           <MAPF %<> ,GROVEL-DECL <REST .DCL>>)>
 985    T>
 986 \f
 987 ;"GROVEL-MACRO - Analyze the body of a macro (compiled or not). If the macro
 988   is compiled, include a setg for the imsubr of the compiled macro in the
 989   abstract. Analysis is inhibited if ABSTRACT-CAREFUL? is false."
 990
 991 <DEFINE GROVEL-MACRO (BODY)
 992    #DECL ((BODY) <OR MSUBR <PRIMTYPE LIST>>)
 993    <COND (<TYPE? .BODY MSUBR>
 994           <COND (<NOT <MEMQ <IMSUBR-NAME .BODY> ,ABSTRACTED>>
 995                  ;"If package is glued, we dont want to setg the imsubr twice."
 996                  <ENQ-GVAL ,ABSTRACT <IMSUBR-NAME .BODY> <MSUBR-IMSUBR .BODY>>
 997                  <SETG ABSTRACTED (<IMSUBR-NAME .BODY> !,ABSTRACTED)>
 998                  <COND (,ABSTRACT-CAREFUL?
 999                         <MAPF %<>
1000                               <FUNCTION (DCL) #DECL ((DCL) ANY)
1001                                  <COND (<TYPE? .DCL ATOM FORM SEGMENT VECTOR>
1002                                         <GROVEL-DECL .DCL>)>>
1003                               <MSUBR-ARG-DECL .BODY>:<PRIMTYPE LIST>>
1004                         <GROVEL-MACRO-COMP <MSUBR-IMVECTOR .BODY>>)>)
1005                 (T
1006                  <MESSAGE "Glued package contains compiled macros"
1007                           GROVEL-MACRO>)>)
1008          (,ABSTRACT-CAREFUL?
1009           <MAPF %<> ,GROVEL-MACRO-PART-EVAL .BODY:<PRIMTYPE LIST>>)>
1010    T>
1011
1012 ;"GROVEL-MACRO-FORM - Analyzes a form in a macro. Inspects the first element
1013   of the form, barfing if it is not a primitive atom or fix. Analyzes rest of the
1014   form in an quoted context or a evaluated context depending on whether or not
1015   the first element is QUOTE or some other primitive atom, respectively."
1016
1017 <DEFINE GROVEL-MACRO-FORM (F "AUX" FIRST)
1018    #DECL ((F) FORM (FIRST) ANY)
1019    <COND (<NOT <EMPTY? .F>>
1020           <COND (<TYPE? <SET FIRST <1 .F>> ATOM FIX>
1021                  <COND (<==? .FIRST QUOTE>
1022                         <GROVEL-MACRO-PART-QUOTE <REST .F>>)
1023                        (<OR <TYPE? .FIRST FIX> <PRIMITIVE? .FIRST>>
1024                         <GROVEL-MACRO-PART-EVAL <REST .F>>)
1025                        (T
1026                         <BARF CANT-ABSTRACT-IN-MACRO!-ERRORS .FIRST .F
1027                               GROVEL-MACRO-FORM>)>)
1028                 (T
1029                  <BARF CANT-ABSTRACT-IN-MACRO!-ERRORS .FIRST .F
1030                        GROVEL-MACRO-FORM>)>)>
1031    T>
1032
1033 ;"GROVEL-MACRO-PART-EVAL - Analyzes part of a macro in evaluated context. The
1034   first element of every form is required to be a primitive atom. Dives into
1035   interesting structures, abstracting newtypes and atoms."
1036
1037 <DEFINE GROVEL-MACRO-PART-EVAL (EP)
1038    #DECL ((EP) ANY)
1039    <COND (<NEWTYPE-OBJECT? .EP> <GROVEL-DECL <TYPE .EP>>)>
1040    <COND (<STRUCTURED? .EP>
1041           <COND (<TYPE? .EP FORM>
1042                  <GROVEL-MACRO-FORM .EP>)
1043                 (<==? <PRIMTYPE .EP> LIST>
1044                  <MAPF %<> ,GROVEL-MACRO-PART-EVAL .EP:<PRIMTYPE LIST>>)
1045                 (<==? <PRIMTYPE .EP> VECTOR>
1046                  <MAPF %<> ,GROVEL-MACRO-PART-EVAL .EP:<PRIMTYPE VECTOR>>)>)
1047          (<TYPE? .EP ATOM> <IF-NEEDED .EP>)>
1048    T>
1049 \f
1050 ;"GROVEL-MACRO-PART-QUOTE - Analyzes part of a macro in quoted context.
1051   Dives into  interesting structures, abstracting newtypes and atoms.
1052   Allows anything as first element of a form because it will not be evaluated."
1053
1054 <DEFINE GROVEL-MACRO-PART-QUOTE (QP)
1055    #DECL ((QP) ANY)
1056    <COND (<NEWTYPE-OBJECT? .QP> <GROVEL-DECL <TYPE .QP>>)>
1057    <COND (<STRUCTURED? .QP>
1058           <COND (<==? <PRIMTYPE .QP> LIST>
1059                  <MAPF %<> ,GROVEL-MACRO-PART-QUOTE .QP:<PRIMTYPE LIST>>)
1060                 (<==? <PRIMTYPE .QP> VECTOR>
1061                  <MAPF %<> ,GROVEL-MACRO-PART-QUOTE .QP:<PRIMTYPE VECTOR>>)>)
1062          (<TYPE? .QP ATOM> <IF-NEEDED .QP>)>
1063    T>
1064
1065 ;"GROVEL-MACRO-COMP - Beginning with the mvector of a compiled macro (see
1066   GROVEL-MACRO) descend to the fringe, analyzing types in the process."
1067
1068 <DEFINE GROVEL-MACRO-COMP (THING)
1069    #DECL ((THING) <OR <PRIMTYPE LIST> <PRIMTYPE VECTOR>>)
1070    <COND (<NEWTYPE-OBJECT? .THING> <GROVEL-DECL <TYPE .THING>>)>
1071    <COND (<==? <PRIMTYPE .THING> LIST>
1072           <MAPF %<> ,GROVEL-MACRO-COMP-PART .THING:<PRIMTYPE LIST>>)
1073          (<==? <PRIMTYPE .THING> VECTOR>
1074           <MAPF %<> ,GROVEL-MACRO-COMP-PART .THING:<PRIMTYPE VECTOR>>)>
1075    T>
1076
1077 ;"GROVEL-MACRO-PART-COMP - Check out the parts of the structures given to
1078   GROVEL-MACRO-COMP. If an atom is found which is gassigned but not manifest
1079   and it is not primitive, then an error occurs."
1080
1081 <DEFINE GROVEL-MACRO-COMP-PART (FROB)
1082    #DECL ((FROB) ANY)
1083    <COND (<MEMQ <PRIMTYPE .FROB> '[LIST VECTOR]>
1084           <GROVEL-MACRO-COMP .FROB>)
1085          (<TYPE? .FROB ATOM>
1086           <COND (<MANIFEST? .FROB>
1087                  <IF-NEEDED .FROB>)
1088                 (<AND <GASSIGNED? .FROB> <NOT <PRIMITIVE? .FROB>>>
1089                  <BARF CANT-ABSTRACT-IN-MACRO!-ERRORS .FROB
1090                        GROVEL-MACRO-COMP-PART>)
1091                 (<OR <NEWTYPE-ATOM? .FROB> <GET-DECL .FROB>>
1092                  <IF-NEEDED .FROB>)>)
1093          (<NEWTYPE-OBJECT? .FROB>
1094           <GROVEL-DECL <TYPE .FROB>>)>
1095    T>
1096
1097 ;"PRIMITIVE? - Returns false if NAME is not on known oblist or
1098   if NAME is a rentry defined by something which is not preloaded."
1099
1100 <DEFINE PRIMITIVE? (NAME "AUX" NOBL)
1101    #DECL ((NAME) ATOM (NOBL) <OR OBLIST FALSE>)
1102    <COND (<SET NOBL <OBLIST? .NAME>>
1103           <OR <==? .NOBL #OBLIST ERRORS>
1104               <AND <==? .NOBL #OBLIST ROOT>
1105                    ;"Note - Preloaded packages not found here because DUs
1106                      for preloaded packages contain no rentries. Assume
1107                      preloaded packages as primitive."
1108                    <NOT <MAPF %<>
1109                               <FUNCTION (UDU) #DECL ((UDU) DU)
1110                                  <COND (<MEMQ .NAME <DU-RENTRIES .UDU>>
1111                                         <MAPLEAVE T>)>>
1112                               ,USED-DU-LIST>>>>)
1113          (T
1114           <BARF ATOM-NOT-ON-ANY-OBLIST!-ERRORS .NAME PRIMITIVE?>
1115           %<>)>>
1116 \f
1117 ;"DU-DEFINES? - If DU has not been SEEN, then if NAME is defined by DU or
1118   by any DUs exported by DU, then non-false is returned. Includes DUs explored
1119   in SEEN to break cyles in usage of packages."
1120
1121 <DEFINE DU-DEFINES? (NAME NOBL DU SEEN)
1122    #DECL ((NAME) ATOM (NOBL) OBLIST (DU) DU (SEEN) <LIST [REST DU]>)
1123    <COND (<MEMQ .DU .SEEN> %<>)
1124          (T
1125           <SET SEEN (.DU !.SEEN)>
1126           <COND (<==? .NOBL <DU-OBL .DU>> T)
1127                 (<AND <==? .NOBL #OBLIST ROOT> <MEMQ .NAME <DU-RENTRIES .DU>>> T)
1128                 (T
1129                  <REPEAT ((DUX <DU-EXPORTS .DU>))
1130                     #DECL ((DUX) <LIST [REST DU]>)
1131                     <COND (<EMPTY? .DUX>
1132                            <RETURN %<>>)
1133                           (<DU-DEFINES? .NAME .NOBL <SET DU <1 .DUX>> .SEEN>
1134                            <RETURN T>)
1135                           (T
1136                            <SET SEEN (.DU !.SEEN)>
1137                            <SET DUX <REST .DUX>>)>>)>)>>
1138
1139 ;"IF-NEEDED - If NAME is defined by TDU, recursively invokes ABSTR-GROVEL
1140   on NAME. Else, if NAME is defined by a DU used by TDU, then that DU is
1141   marked so that it will be used in abstract. Else, if NAME is on root
1142   oblist it is assumed primitive (or preloaded), otherwise an error occurs."
1143
1144 <DEFINE IF-NEEDED (NAME "AUX" (NOBL <OBLIST? .NAME>) (TDU ,TOPLEVEL-DU))
1145    #DECL ((NAME) ATOM (NOBL) <OR OBLIST FALSE> (TDU) DU)
1146    <COND (.NOBL
1147           ;"Abstract the atom if it belongs to TOPLEVEL-DU."
1148           <COND (<OR <==? .NOBL <DU-OBL .TDU>>
1149                      <==? .NOBL <DU-IOBL .TDU>>
1150                      <MEMQ .NAME <DU-RENTRIES .TDU>>>
1151                  <ABSTR-GROVEL .NAME>)
1152                 (T
1153                  <OR <MAPF %<>
1154                            <FUNCTION (DU) #DECL ((DU) DU)
1155                               <COND (<DU-DEFINES? .NAME .NOBL .DU (.TDU)>
1156                                      <MARK-DU .DU>
1157                                      <MAPLEAVE T>)>>
1158                            (!<DU-EXPORTS .TDU>
1159                             !<DU-INCLUDES .TDU>
1160                             !<DU-USES .TDU>)>
1161                      <==? .NOBL #OBLIST ROOT>
1162                      <==? .NOBL #OBLIST ERRORS>
1163                      <BARF ATOM-NOT-ON-KNOWN-OBLIST!-ERRORS .NAME
1164                            IF-NEEDED>>)>)
1165          (T
1166           <BARF ATOM-NOT-ON-ANY-OBLIST!-ERRORS .NAME IF-NEEDED>)>
1167    T>
1168 \f
1169 ;"BARF - Returns false from the frame named AP if AP is a legal frame,
1170   otherwise error. The error handler for the abstraction package."
1171
1172 <DEFINE BARF ("TUPLE" BARFAGE)
1173    #DECL ((BARFAGE) <<PRIMTYPE VECTOR> ANY>)
1174    <COND (<AND <GASSIGNED? NAME-STACK> <NOT <EMPTY? ,NAME-STACK>>>
1175           <BIND ((WHO <STRING "While working on " <SPNAME <1 ,NAME-STACK>>>)
1176                  (PUKE (ABSTRACTION-ERROR!-ERRORS .WHO !.BARFAGE)))
1177              #DECL ((WHO) STRING (PUKE) LIST)
1178              <COND (<AND <ASSIGNED? AP> <LEGAL? .AP>>
1179                     <RETURN <CHTYPE .PUKE FALSE> .AP>)
1180                    (T
1181                     <ERROR !.PUKE>)>>)
1182          (<AND <ASSIGNED? AP> <LEGAL? .AP>>
1183           <RETURN <CHTYPE (!.BARFAGE) FALSE> .AP>)
1184          (T
1185           <ERROR !.BARFAGE>)>
1186    %<>>
1187
1188 ;"MESSAGE - Prints BARFAGE to OUTCHAN."
1189
1190 <DEFINE MESSAGE ("TUPLE" BARFAGE)
1191    #DECL ((BARFAGE) <<PRIMTYPE VECTOR> [REST ANY]>)
1192    <BIND ((OUTCHAN .OUTCHAN))
1193       #DECL ((OUTCHAN) CHANNEL)
1194       <CRLF>
1195       <PRINC "*** Warning ***">
1196       <MAPF %<>
1197             <FUNCTION (FROB)
1198                <CRLF> <PRINC .FROB>>
1199             .BARFAGE>>>
1200
1201 ;"ALESS? - Return T if pname of A1 is greater than pname of A2."
1202
1203 <DEFINE ALESS? (A1 A2)
1204    #DECL ((A1 A2) ATOM)
1205    <==? <STRCOMP <SPNAME .A1> <SPNAME .A2>> 1>>
1206 \f
1207 ;"SEARCH - Find a filename in the library search path. Only files
1208   are considered - libraries are not consulted. If OPER = VECTOR,
1209   a vector of 5 elements is returned = [FN NM1 NM2 DEV SNM].
1210   If OPER = NAME, the file name is returned. If OPER = CHANNEL a channel
1211   open to the file is returned."
1212
1213 <DEFINE SEARCH (NAME OPER
1214                 "OPT" (PATH ,L-SEARCH-PATH) (NAMES ,L-SECOND-NAMES)
1215                 "AUX" ODEV OSNM)
1216    #DECL ((NAME) STRING (OPER) ATOM (PATH) LIST (NAMES) <VECTOR [REST STRING]>
1217           (ODEV OSNM) STRING)
1218    <COND (<ASSIGNED? SNM> <SET OSNM .SNM>)
1219          (<GASSIGNED? SNM> <SET OSNM ,SNM>)
1220          (T <SET OSNM "">)>
1221    <COND (<ASSIGNED? DEV> <SET ODEV .DEV>)
1222          (<GASSIGNED? DEV> <SET ODEV ,DEV>)
1223          (T <SET ODEV "">)>
1224    <REPEAT (SPEC DEV SNM (RESULT %<>))
1225       #DECL ((SPEC) <OR VECTOR STRING> (DEV SNM) <SPECIAL STRING>
1226              (RESULT) <OR STRING VECTOR <CHANNEL 'DISK> FALSE>)
1227       <COND (<OR .RESULT <EMPTY? .PATH>> <RETURN .RESULT>)>
1228       <SET SPEC <1 .PATH>>
1229       <COND (<TYPE? .SPEC VECTOR>
1230              <COND (<==? <LENGTH .SPEC> 2>
1231                     <SET DEV <1 .SPEC>>
1232                     <SET SNM <2 .SPEC>>)
1233                    (T
1234                     <COND (<EMPTY? .ODEV> <UNASSIGN DEV>)
1235                           (T <SET DEV .ODEV>)>
1236                     <COND (<EMPTY? .OSNM> <UNASSIGN SNM>)
1237                           (T <SET SNM .OSNM>)>)>
1238              <REPEAT ((RNAMES .NAMES) NM2 CH)
1239                 #DECL ((RNAMES) <VECTOR [REST STRING]> (NM2) <SPECIAL STRING>
1240                        (CH) <OR <CHANNEL 'DISK> FALSE>)
1241                 <COND (<EMPTY? .RNAMES> <RETURN>)>
1242                 <SET NM2 <1 .RNAMES>>
1243                 <COND (<SET CH <OPEN "READ" .NAME>>
1244                        <COND (<==? .OPER VECTOR>
1245                               <SET RESULT [<CHANNEL-OP .CH NAME>
1246                                            <CHANNEL-OP .CH NM1>
1247                                            <CHANNEL-OP .CH NM2>
1248                                            <CHANNEL-OP .CH DEV>
1249                                            <CHANNEL-OP .CH SNM>]>
1250                               <CLOSE .CH>)
1251                              (<==? .OPER NAME>
1252                               <SET RESULT <CHANNEL-OP .CH NAME>>
1253                               <CLOSE .CH>)
1254                              (T
1255                               <SET RESULT .CH>)>
1256                        <RETURN>)>
1257                 <SET RNAMES <REST .RNAMES>>>)>
1258       <SET PATH <REST .PATH>>>>
1259
1260 <ENDPACKAGE>