mim/development/mim/vax/mimlib/l-query.mud

   1 <PACKAGE "L-QUERY">
   2
   3 ;"****************************************************************************
   4
   5   This file defines a query facility for the LIBRARY system: listing names of
   6   packages, entries, counts of same, findatom, etc. Both network and local
   7   libraries can be queried. See definition of library records (long, short)
   8   in LIBRARY.FORMAT.
   9
  10   L-QUERY.MUD: EDIT HISTORY                                Machine Independent
  11
  12   COMPILATION: XMIMC L-QUERY /NC <SET EXPFLOAD T>
  13
  14   JUN84   [Shane] - Created.
  15   11OCT84 [Shane] - Commented, cleaned up.
  16   21OCT84 [Shane] - New protocols.
  17   29OCT84 [Shane] - L-DOC optionally (default) prints documentation files. Flush
  18                     some internal functions. Create some shareable internal
  19                     functions. Rewrite some kludges.
  20   ***************************************************************************"
  21
  22 <ENTRY L-LISTPE L-DOC L-FILES L-LISTE L-LISTP L-COUNTE L-COUNTP L-LISTU
  23        L-FINDATOM>
  24
  25 <USE "LIBRARY">
  26
  27 <INCLUDE-WHEN <COMPILING? "L-QUERY">
  28               "L-DEFS" !<IFSYS ("VAX" '("L-NETDEFS" "NETDEFS")) ("TOPS20" ())>>
  29
  30 <IFSYS ("VAX" <USE "NETBASE">)>
  31
  32 %%<PRINC "+L-QUERY-BASE "> <L-FLOAD "L-QUERY-BASE">     ;"Splice into code."
  33
  34 %%<CRLF>
  35 \f
  36 ;"L-DOC --
  37   Effect:   If PKG is documented in library denoted LIBS, the documentation
  38             is printed on OUTCHAN. If the documentation is a file, the name of
  39             the file is printed in standard format (and if PRINT-FILE? is non-
  40             false, the contents of the file is printed as well). If PKG is in
  41             library denoted by LIBS but not documented, a message to the effect
  42             is printed.
  43   Modifies: OUTCHAN.
  44   Returns:  T if PKG is found, FALSE otherwise."
  45
  46 <DEFINE L-DOC (PKG:STRING
  47                "OPT" (LIBS:STRING ,PUBLIC-LIBRARY)
  48                      (PRINT-FILE?:<OR ATOM FALSE> T)
  49                      (OUTCHAN:CHANNEL .OUTCHAN)
  50                "AUX" (LIBC:<OR CHANNEL FALSE> %<>)
  51                      (DOC:<OR CHANNEL FALSE> %<>))
  52    <UNWIND
  53     <PROG ((RECORD:UVECTOR <STACK <IUVECTOR ,MAXREC>>) DEV:<SPECIAL STRING>
  54            PREFIX:<OR VECTOR STRING> RINFO:FIX DOCLEN:FIX DOCSTR:STRING
  55            SNM:<SPECIAL STRING> FN:<CHANNEL 'PARSE>)
  56        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
  57               <RETURN %<>>)
  58              (<NOT <LQ-GET-RECORD .PKG .LIBC .RECORD %<>>>    ;"Short record"
  59               <CLOSE .LIBC>
  60               <RETURN %<>>)>
  61        <SET PREFIX <MAKE-PREFIX .LIBC>>     ;"Path specification."
  62        <CLOSE .LIBC>
  63        <SET RINFO <1 .RECORD>>              ;"Record information."
  64        <SET DOCLEN <NTH .RECORD <+ <BYTE0 .RINFO> 2>>>  ;"File name sizes."
  65        <SET RECORD                          ;"Move to start of documentation."
  66             <REST .RECORD <+ <BYTE0 .RINFO> <BYTE0 .DOCLEN> <BYTE1 .DOCLEN>
  67                              <BYTE2 .DOCLEN> 2>>>
  68        <COND (<0? <SET DOCLEN <BYTE3 .DOCLEN>>> ;"Doc length is high byte."
  69               <PRINTSTRING "No documentation provided." .OUTCHAN>
  70               <CRLF .OUTCHAN>
  71               <RETURN>)>
  72        <COND (<TESTBIT .RINFO ,RINFO-DFN? %<>>  ;"Documentation string, no file."
  73               <SET DOCSTR <UV2S .RECORD .DOCLEN>>)
  74              (<TYPE? .PREFIX STRING>        ;"Network library path spec."
  75               <SET DOCSTR <STRING .PREFIX <UV2S .RECORD .DOCLEN>>>)
  76              (T                             ;"Local library file spec."
  77               <SET DEV <1 .PREFIX>>
  78               <SET SNM <2 .PREFIX>>
  79               <SET FN <CHANNEL-OPEN 'PARSE <UV2S .RECORD .DOCLEN>>>
  80               <SET DOCSTR <CHANNEL-OP .FN NAME ,NO-GENERATION>>
  81               <CLOSE .FN>)>
  82        <PRINTSTRING .DOCSTR .OUTCHAN>
  83        <COND (<AND .PRINT-FILE? <TESTBIT .RINFO ,RINFO-DFN?>>
  84               ;"Get the documentation file from LIBS and print it."
  85               <COND (<SET DOC <FILE-FIND <UV2S .RECORD .DOCLEN> .LIBS>>
  86                      <CRLF .OUTCHAN>
  87                      <FILECOPY .DOC .OUTCHAN>
  88                      <CLOSE .DOC>)
  89                     (T
  90                      <PRINTSTRING "Cant open documentation file." .OUTCHAN>)>)>
  91        <CRLF .OUTCHAN>>
  92     <BIND () <AND .LIBC <CHANNEL-OPEN? .LIBC> <CLOSE .LIBC>>
  93              <AND .DOC <CHANNEL-OPEN? .DOC> <CLOSE .DOC>>>>>
  94 \f
  95 ;"L-FILES --
  96   Effect:   If PKG is found in library denoted by LIBS, the names of the files
  97             associated with the PKG are printed on OUTCHAN in standard format.
  98   Modifies: OUTCHAN.
  99   Returns:  T if PKG is found, otherwise FALSE."
 100
 101 <DEFINE L-FILES (PKG:STRING
 102                  "OPT" (LIBS:STRING ,PUBLIC-LIBRARY)
 103                        (OUTCHAN:CHANNEL .OUTCHAN)
 104                  "AUX" (LIBC:<OR CHANNEL FALSE> %<>))
 105    <UNWIND
 106     <PROG ((RECORD:UVECTOR <STACK <IUVECTOR ,MAXREC>>) DEV:<SPECIAL STRING>
 107            PREFIX:<OR VECTOR STRING> FNSIZES:FIX RINFO:FIX
 108            SNM:<SPECIAL STRING>)
 109        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 110               <RETURN %<>>)
 111              (<NOT <LQ-GET-RECORD .PKG .LIBC .RECORD %<>>>
 112               <CLOSE .LIBC>
 113               <RETURN %<>>)>
 114        <SET PREFIX <MAKE-PREFIX .LIBC>>     ;"Path specification."
 115        <CLOSE .LIBC>
 116        <SET RINFO <1 .RECORD>>              ;"Record information."
 117        <SET FNSIZES <NTH .RECORD <+ <BYTE0 .RINFO> 2>>> ;"File name sizes."
 118        <SET RECORD <REST .RECORD <+ <BYTE0 .RINFO> 2>>> ;"Move to names."
 119        <COND (<TESTBIT .RINFO ,RINFO-DFN? %<>>  ;"If no doc file, mask doc size."
 120               <SET FNSIZES <GETBITS .FNSIZES <BITS 24 0>>>)>
 121        <REPEAT (FNSIZE:FIX FN:<CHANNEL 'PARSE>)
 122           <COND (<G? <SET FNSIZE <BYTE0 .FNSIZES>> 0>
 123                  <COND (<TYPE? .PREFIX STRING>  ;"Network file."
 124                         <PRINTSTRING .PREFIX .OUTCHAN>
 125                         <PRINTSTRING <UV2S .RECORD .FNSIZE> .OUTCHAN>)
 126                        (T                   ;"Local file."
 127                         <SET DEV <1 .PREFIX>>
 128                         <SET SNM <2 .PREFIX>>
 129                         <SET FN <CHANNEL-OPEN PARSE <UV2S .RECORD .FNSIZE>>>
 130                         <PRINTSTRING <CHANNEL-OP .FN NAME ,NO-GENERATION> .OUTCHAN>
 131                         <CHANNEL-CLOSE .FN>)>
 132                  <CRLF .OUTCHAN>
 133                  <SET RECORD <REST .RECORD .FNSIZE>>)>
 134           <COND (<0? <SET FNSIZES <LSH .FNSIZES -8>>> <RETURN>)>>>
 135     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 136
 137 ;"MAKE-PREFIX --
 138   Effect:   Construct specification of library directory: a string specifying
 139             host directory if LIBC is NETWORK channel, otherwise a vector
 140             containing DEV, SNM if LIBC is local channel.
 141   Returns:  Path specification for LIBC.
 142   Requires: LIBC is not closed."
 143
 144 <DEFINE MAKE-PREFIX (LIBC:CHANNEL)
 145    <PROG ()
 146       <IFSYS ("VAX"
 147               ;"Network => UNIX: host:hostdir/"
 148               <COND (<REMOTE? .LIBC>
 149                      <RETURN <STRING ,SERVER-NAME ":" ,SERVER-DIR "/">>)>)>
 150       ;"Local: [DEV SNM]"
 151       <RETURN [<CHANNEL-OP .LIBC:DSK DEV> <CHANNEL-OP .LIBC:DSK SNM>]>>>
 152 \f
 153 ;"L-LISTPE --
 154   Effect:   If PKG is found in LIBRARY denoted by LIBS, the names of all the
 155             entrys and rentrys of PKG are printed together with type information
 156             on OUTCHAN.
 157   Returns:  T if PKG is found, otherwise FALSE.
 158   Modifies: OUTCHAN."
 159
 160 <DEFINE L-LISTPE (PKG:STRING
 161                   "OPT" (LIBS:STRING ,PUBLIC-LIBRARY)
 162                         (OUTCHAN:CHANNEL .OUTCHAN)
 163                   "AUX" (LIBC:<OR CHANNEL FALSE> %<>))
 164    <UNWIND
 165     <PROG ((RECORD:UVECTOR <STACK <IUVECTOR ,MAXREC>>)
 166            (S:STRING <STACK <ISTRING ,MAXSTRS>>) (PRINTED:FIX 0)
 167            ERCNT:FIX DELTAE:FIX RINFO:FIX)
 168        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 169               <RETURN %<>>)
 170              (<NOT <LQ-GET-RECORD .PKG .LIBC .RECORD>>
 171               <CLOSE .LIBC>
 172               <RETURN %<>>)>
 173        <CLOSE .LIBC>
 174        <SET RINFO <1 .RECORD>>              ;"Record information."
 175        <COND (<TESTBIT .RINFO ,RINFO-PKG?>  ;"PACKAGE or DEFINITIONS?"
 176               <PRINTSTRING "Package:" .OUTCHAN>)
 177              (T
 178               <PRINTSTRING "Definitions:" .OUTCHAN>)>
 179        <INDENT-TO 14 .OUTCHAN>              ;"Print module name."
 180        <PRINTSTRING .S .OUTCHAN <UV2SS <REST .RECORD> .S <BYTE0 .RINFO>>>
 181        <CRLF .OUTCHAN>
 182        <SET DELTAE <NTH .RECORD <+ <BYTE0 .RINFO> 3>>>
 183        <SET ERCNT <RHALF .DELTAE>>          ;"R/ENTRY count."
 184        <SET DELTAE <LHALF .DELTAE>>         ;"Distance to entry list."
 185        <PRINTSTRING "Entries:" .OUTCHAN>    ;"Print entries."
 186        <INDENT-TO 14 .OUTCHAN>
 187        <REPEAT ((COUNT:FIX .ERCNT) (DELTA:FIX .DELTAE) ERTYPE:FIX)
 188           <COND (<0? .COUNT>
 189                  <COND (<0? .PRINTED>
 190                         <PRINTSTRING "None." .OUTCHAN>
 191                         <CRLF .OUTCHAN>)>
 192                  <RETURN>)>
 193           <SET ERTYPE <NTH .RECORD <+ .DELTA 1>>>
 194           <COND (<TESTBIT .ERTYPE ,ERTYP-ENTRY?>        ;"Entry?"
 195                  <SET PRINTED <+ .PRINTED 1>>
 196                  <INDENT-TO 14 .OUTCHAN>
 197                  <PRINT-ENTRY <REST .RECORD .DELTA> .S .OUTCHAN T>
 198                  <CRLF .OUTCHAN>)>
 199           <SET COUNT <- .COUNT 1>>
 200           <SET DELTA <+ .DELTA <BYTE0 .ERTYPE> 1>>>
 201        <PRINTSTRING "Rentries:" .OUTCHAN>
 202        <COND (<==? .PRINTED .ERCNT>         ;"Print rentries if any."
 203               <INDENT-TO 14 .OUTCHAN>
 204               <PRINTSTRING "None." .OUTCHAN>
 205               <CRLF .OUTCHAN>
 206               <RETURN>)>
 207        <REPEAT ((COUNT:FIX <- .ERCNT .PRINTED>) (DELTA:FIX .DELTAE) ERTYPE:FIX)
 208           <SET ERTYPE <NTH .RECORD <+ .DELTA 1>>>
 209           <COND (<TESTBIT .ERTYPE ,ERTYP-ENTRY? %<>>    ;"Rentry?"
 210                  <INDENT-TO 14 .OUTCHAN>
 211                  <PRINT-ENTRY <REST .RECORD .DELTA> .S .OUTCHAN T>
 212                  <CRLF .OUTCHAN>
 213                  <COND (<0? <SET COUNT <- .COUNT 1>>>
 214                         <RETURN>)>)>
 215           <SET DELTA <+ .DELTA <BYTE0 .ERTYPE> 1>>>>
 216     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 217 \f
 218 ;"PRINT-ENTRY --
 219   Effect:   Prints descriptive information about entry descriptor at head of
 220             U (should be record rested to entry descriptor). The name of the
 221             entry followed by a space is printed to OUTCHAN. If VERBOSE? is
 222             non-false, then type information is also printed. S is buffer.
 223   Modifies: S, OUTCHAN
 224   Requires: U is library record rested to entry descriptor word.
 225             size(S) >= MAXSTRS."
 226
 227 <DEFINE PRINT-ENTRY (U:UVECTOR S:STRING OUTCHAN:CHANNEL VERBOSE?:<OR ATOM FALSE>
 228                      "AUX" (ERTYPE:FIX <1 .U>) FIELD:FIX)
 229    <PRINTSTRING .S .OUTCHAN <UV2SS <REST .U> .S <BYTE0 .ERTYPE>>>
 230    <PRINTSTRING " " .OUTCHAN>
 231    <COND (.VERBOSE?
 232           <COND (<N==? <SET FIELD <GETBITS .ERTYPE <BITS 4 8>>> 0>
 233                  <PRINTSTRING "Gassigned " .OUTCHAN>)>
 234           <COND (<TESTBIT .ERTYPE ,ERTYP-MANIFEST?>
 235                  <PRINTSTRING "Manifest " .OUTCHAN>)>
 236           <COND (<AND <G? .FIELD 0> <L=? .FIELD 7>>
 237                  <PRINC <NTH ,L-ERTYPES:VECTOR .FIELD> .OUTCHAN>
 238                  <PRINTSTRING " " .OUTCHAN>)
 239                 (<TESTBIT .ERTYPE ,ERTYP-APPLICABLE?>
 240                  <PRINTSTRING "Applicable " .OUTCHAN>)>
 241           <COND (<TESTBIT .ERTYPE ,ERTYP-TYPE?>
 242                  <PRINTSTRING "Type " .OUTCHAN>)>)>
 243    T>
 244
 245 ;"L-COUNTP --
 246   Effect:   Fetch count of number of packages or definitions contained in
 247             library denoted by LIBS.
 248   Returns:  Package count if successful, otherwise FALSE."
 249
 250 <DEFINE L-COUNTP ("OPT" (LIBS:STRING ,PUBLIC-LIBRARY)
 251                   "AUX" (LIBC:<OR CHANNEL FALSE> %<>))
 252    <UNWIND
 253     <PROG ((STATS:<OR FALSE <UVECTOR [2 FIX]>> <STACK <IUVECTOR 2>>))
 254        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 255               <RETURN %<>>)>
 256        <SET STATS <GET-LIBRARY-STATISTICS .LIBC .STATS>>
 257        <CLOSE .LIBC>
 258        <COND (.STATS <2 .STATS>)>>
 259     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 260
 261 ;"L-COUNTE --
 262   Effect:   Fetch count of number of entries or rentries contained in
 263             library denoted by LIBS.
 264   Returns:  Entry count if successful, otherwise FALSE."
 265
 266 <DEFINE L-COUNTE ("OPT" (LIBS:STRING ,PUBLIC-LIBRARY)
 267                   "AUX" (LIBC:<OR CHANNEL FALSE> %<>))
 268    <UNWIND
 269     <PROG ((STATS:<OR FALSE <UVECTOR [2 FIX]>> <STACK <IUVECTOR 2>>))
 270        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 271               <RETURN %<>>)>
 272        <SET STATS <GET-LIBRARY-STATISTICS .LIBC .STATS>>
 273        <CLOSE .LIBC>
 274        <COND (.STATS <1 .STATS>)>>
 275     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 276 \f
 277 ;"GET-LIBRARY-STATISTICS --
 278   Effect:   Fetch library counts from LIBC into STATS.
 279   Modifies: LIBC, STATS
 280   Returns:  STATS = ![packages entries!] if successful, otherwise FALSE.
 281   Requires: Server is waiting for request if LIBC is NETWORK channel."
 282
 283 <DEFINE GET-LIBRARY-STATISTICS (LIBC:CHANNEL STATS:<UVECTOR [2 FIX]>)
 284    <PROG ()
 285       <IFSYS ("VAX"
 286               ;"Network - send request and read."
 287               <COND (<REMOTE? .LIBC>
 288                      <1 .STATS ,COUNT-REQUEST>
 289                      <CHANNEL-OP .LIBC:NET WRITE-BUFFER .STATS 1>
 290                      <COND (<NET-UVECTOR-IN .LIBC .STATS 2> <RETURN .STATS>)
 291                            (T <RETURN %<>>)>)>)>
 292       ;"Local, access to counts and read."
 293       <CHANNEL-OP .LIBC:DSK ACCESS ,DIR-LERCNT>
 294       <COND (<CHANNEL-OP .LIBC:DSK READ-BUFFER .STATS 2> .STATS)>>>
 295
 296
 297 ;"L-LISTE --
 298   Effect:   Print the names of every entry or rentry in every package or
 299             definitions in library denoted by LIBS to outchan.
 300   Modifies: OUTCHAN."
 301
 302 <DEFINE L-LISTE ("OPT" (LIBS:STRING ,PUBLIC-LIBRARY) (OUTCHAN:CHANNEL .OUTCHAN)
 303                  "AUX" (LIBC:<OR CHANNEL FALSE> %<>))
 304    <UNWIND
 305     <PROG ((STATE:<OR UVECTOR FALSE> <STACK <IUVECTOR 3>>))
 306        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 307               <RETURN %<>>)
 308              (<NOT <SET STATE <LQ-MAP-RECORDS .LIBC .STATE>>>
 309               <CLOSE .LIBC>
 310               <RETURN %<>>)>
 311        <REPEAT ((RECORD:UVECTOR <STACK <IUVECTOR ,MAXREC>>)
 312                 (S:STRING <STACK <ISTRING ,MAXSTRS>>))
 313           <COND (<LQ-NEXT-RECORD .LIBC .STATE .RECORD>
 314                  <CRLF .OUTCHAN>
 315                  <LISTE .RECORD .S .OUTCHAN>)
 316                 (T
 317                  <CLOSE .LIBC>
 318                  <CRLF .OUTCHAN>
 319                  <RETURN>)>>>
 320     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 321 \f
 322 ;"LISTE --
 323   Effect:   Print the name of RECORD and whether it represents a package or
 324             definitions. The print all the entries followed by all the
 325             rentries to OUTCHAN.
 326   Modifies: S, OUTCHAN.
 327   Requires: RECORD is properly formatted record as defined in LIBRARY.FORMAT,
 328             size(S) >= MAXSTRS."
 329
 330 <DEFINE LISTE (RECORD:UVECTOR S:STRING OUTCHAN:CHANNEL "NAME" LISTE
 331                "AUX" (RINFO:FIX <1 .RECORD>) (PRINTED:FIX 0) DELTAE:FIX ERCNT:FIX)
 332    <COND (<TESTBIT .RINFO ,RINFO-PKG?>      ;"PACKAGE or DEFINITIONS?"
 333           <PRINTSTRING "Package:" .OUTCHAN>)
 334          (T
 335           <PRINTSTRING "Definitions:" .OUTCHAN>)>
 336    <INDENT-TO 14 .OUTCHAN>                  ;"Print module name."
 337    <PRINTSTRING .S .OUTCHAN <UV2SS <REST .RECORD> .S <BYTE0 .RINFO>>>
 338    <CRLF .OUTCHAN>
 339    <SET DELTAE <NTH .RECORD <+ <BYTE0 .RINFO> 3>>>
 340    <SET ERCNT <RHALF .DELTAE>>              ;"R/ENTRY count."
 341    <SET DELTAE <LHALF .DELTAE>>             ;"Distance to entry list."
 342    <PRINTSTRING "Entries:" .OUTCHAN>        ;"Print entries."
 343    <INDENT-TO 14 .OUTCHAN>
 344    <REPEAT ((COUNT:FIX .ERCNT) (DELTA:FIX .DELTAE)
 345             ERTYPE:FIX NAMLEN:FIX)
 346       <COND (<0? .COUNT>
 347              <COND (<0? .PRINTED>
 348                     <PRINTSTRING "None." .OUTCHAN>)>
 349              <CRLF .OUTCHAN>
 350              <RETURN>)>
 351       <SET ERTYPE <NTH .RECORD <+ .DELTA 1>>>
 352       <COND (<TESTBIT .ERTYPE ,ERTYP-ENTRY?>    ;"Entry?"
 353              <SET PRINTED <+ .PRINTED 1>>
 354              <SET NAMLEN <UV2SS <REST .RECORD <+ .DELTA 1>> .S <BYTE0 .ERTYPE>>>
 355              ;"Dont overflow right margin."
 356              <COND (<G? <+ <M-HPOS .OUTCHAN> .NAMLEN 1> 79>
 357                     <CRLF .OUTCHAN>
 358                     <INDENT-TO 14 .OUTCHAN>)>
 359              <PRINTSTRING .S .OUTCHAN .NAMLEN>
 360              <PRINTSTRING " " .OUTCHAN>)>
 361       <SET COUNT <- .COUNT 1>>
 362       <SET DELTA <+ .DELTA <BYTE0 .ERTYPE> 1>>>
 363    <PRINTSTRING "Rentries:" .OUTCHAN>
 364    <INDENT-TO 14 .OUTCHAN>
 365    <COND (<==? .PRINTED .ERCNT>             ;"Print rentries if any."
 366           <INDENT-TO 14 .OUTCHAN>
 367           <PRINTSTRING "None." .OUTCHAN>
 368           <CRLF .OUTCHAN>
 369           <RETURN T .LISTE>)>
 370    <REPEAT ((COUNT:FIX <- .ERCNT .PRINTED>) (DELTA:FIX .DELTAE)
 371             ERTYPE:FIX NAMLEN:FIX)
 372       <SET ERTYPE <NTH .RECORD <+ .DELTA 1>>>
 373       <COND (<TESTBIT .ERTYPE ,ERTYP-ENTRY? %<>>        ;"Rentry?"
 374              <SET NAMLEN <UV2SS <REST .RECORD <+ .DELTA 1>> .S <BYTE0 .ERTYPE>>>
 375              ;"Dont overflow right margin."
 376              <COND (<G? <+ <M-HPOS .OUTCHAN> .NAMLEN 1> 79>
 377                     <CRLF .OUTCHAN>
 378                     <INDENT-TO 14 .OUTCHAN>)>
 379              <PRINTSTRING .S .OUTCHAN .NAMLEN>
 380              <PRINTSTRING " " .OUTCHAN>
 381              <COND (<0? <SET COUNT <- .COUNT 1>>>
 382                     <CRLF .OUTCHAN>
 383                     <RETURN>)>)>
 384       <SET DELTA <+ .DELTA <BYTE0 .ERTYPE> 1>>>
 385    T>
 386 \f
 387 ;"L-LISTP --
 388   Effect:   Print the names of all the packages and definitions in library
 389             denoted by LIBS to OUTCHAN.
 390   Modifies: OUTCHAN."
 391
 392 <DEFINE L-LISTP ("OPT" (LIBS:STRING ,PUBLIC-LIBRARY) (OUTCHAN:CHANNEL .OUTCHAN)
 393                  "AUX" (LIBC:<OR CHANNEL FALSE> %<>))
 394    <UNWIND
 395     <PROG ((STATE:<OR UVECTOR FALSE> <STACK <IUVECTOR 3>>))
 396        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 397               <RETURN %<>>)
 398              (<NOT <SET STATE <LQ-MAP-RECORDS .LIBC .STATE %<>>>>
 399               <CLOSE .LIBC>
 400               <RETURN %<>>)>
 401        <CRLF .OUTCHAN>
 402        <REPEAT ((RECORD:UVECTOR <STACK <IUVECTOR ,MAXREC>>)
 403                 (NAME:STRING <STACK <ISTRING ,MAXSTRS>>) NAMLEN:FIX)
 404           <COND (<LQ-NEXT-RECORD .LIBC .STATE .RECORD %<>>
 405                  <SET NAMLEN <UV2SS <REST .RECORD> .NAME <BYTE0 <1 .RECORD>>>>
 406                  <COND (<G? <+ <M-HPOS .OUTCHAN> .NAMLEN 1> 79>
 407                         <CRLF .OUTCHAN>)>
 408                  <PRINTSTRING .NAME .OUTCHAN .NAMLEN>
 409                  <PRINTSTRING " " .OUTCHAN>)
 410                 (T
 411                  <CLOSE .LIBC>
 412                  <CRLF .OUTCHAN>
 413                  <RETURN>)>>>
 414     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 415
 416 ;"L-FINDATOM --
 417   Effect:   Every entry or rentry in library denoted by LIBS whose pname matches
 418             SPECSTR is printed to OUTCHAN with associated type information.
 419             * in SPECSTR denotes zero or more characters, all other characters
 420             represent themselves. There is no quote for * (tough shit).
 421   Modifies: OUTCHAN."
 422
 423 <DEFINE L-FINDATOM (SPECSTR:STRING
 424                     "OPT" (LIBS:STRING ,PUBLIC-LIBRARY)
 425                           (OUTCHAN:CHANNEL .OUTCHAN)
 426                     "AUX" (LIBC:<OR CHANNEL FALSE> %<>))
 427    <UNWIND
 428     <PROG ((STATE:<OR UVECTOR FALSE> <STACK <IUVECTOR 3>>))
 429        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 430               <RETURN %<>>)
 431              (<NOT <SET STATE <LQ-MAP-RECORDS .LIBC .STATE>>>
 432               <CLOSE .LIBC>
 433               <RETURN %<>>)>
 434        <CRLF .OUTCHAN>
 435        <REPEAT ((RECORD:UVECTOR <STACK <IUVECTOR ,MAXREC>>)
 436                 (S:STRING <STACK <ISTRING ,MAXSTRS>>))
 437           <COND (<LQ-NEXT-RECORD .LIBC .STATE .RECORD>
 438                  <MATCH-AND-PRINT .RECORD .SPECSTR .S .OUTCHAN>)
 439                 (T
 440                  <CRLF .OUTCHAN>
 441                  <CLOSE .LIBC>
 442                  <RETURN>)>>>
 443     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 444 \f
 445 ;"MATCH-AND-PRINT --
 446   Effect:   Prints the names of any entrys or rentrys in RECORD which match
 447             SPECSTR along with type information. The name of the package or
 448             definitions is printed if there is at least one match.
 449   Modifies: S, OUTCHAN
 450   Requires: RECORD is properly formatted library record as defined in
 451             LIBRARY.FORMAT, size(S) >= MAXSTRS."
 452
 453 <DEFINE MATCH-AND-PRINT (RECORD:UVECTOR SPECSTR:STRING S:STRING OUTCHAN:CHANNEL)
 454    <REPEAT ((DELTA:FIX <+ <LHALF <NTH .RECORD <+ <BYTE0 <1 .RECORD>> 3>>> 1>)
 455             (ERCNT:FIX <RHALF <NTH .RECORD <+ <BYTE0 <1 .RECORD>> 3>>>)
 456             (BLURB?:<OR ATOM FALSE> %<>) MATCH?:<OR ATOM FALSE> ERLEN:FIX)
 457       <COND (<==? .ERCNT 0> <RETURN>)>      ;"Until every name considered."
 458       <SET ERLEN <BYTE0 <NTH .RECORD .DELTA>>>  ;"Pname length in words."
 459       <SET MATCH? %<>>                      ;"Non-false => found match."
 460       <REPEAT ((SHIFT:FIX 0) (WPTR:FIX 0) (WILD?:<OR STRING FALSE> %<>)
 461                W:FIX B:CHARACTER)
 462          <REPEAT ()                         ;"Find next non-wild (not *)."
 463             <COND (<OR <EMPTY? .SPECSTR> <N==? <1 .SPECSTR> !\*>>
 464                    <RETURN>)
 465                   (T
 466                    <SET WILD? .SPECSTR>     ;"WILD? = SPECSTR rested to wild."
 467                    <SET SPECSTR <REST .SPECSTR>>)>>
 468          <COND (<G? <SET SHIFT <+ .SHIFT 8>> 0> ;"All bytes in this word done?"
 469                 <SET SHIFT -24>             ;"If all words done, set W to nulls."
 470                 <COND (<G? <SET WPTR <+ .WPTR 1>> .ERLEN> <SET W 0>)
 471                       (T <SET W <NTH .RECORD <+ .DELTA .WPTR>>>)>)>
 472          <SET B <CHAR <BYTE0 <LSH .W .SHIFT>>>> ;"Next char in pname."
 473          <COND (<==? .B <CHAR 0>>           ;"Null => end of pname."
 474                 <SET MATCH? <EMPTY? .SPECSTR>>  ;"Must match every character."
 475                 <RETURN>)
 476                (<EMPTY? .SPECSTR>           ;"If SPECSTR is empty."
 477                 <COND (.WILD?               ;"And last character is wild."
 478                        <COND (<==? <NTH .WILD? <LENGTH .WILD?>> !\*>
 479                               <SET MATCH? T>    ;"Then we have a match."
 480                               <RETURN>)
 481                              (T
 482                               <SET SPECSTR .WILD?>      ;"Otherwise we back up."
 483                               <SET SHIFT <- .SHIFT 8>>)>)       ;"And reconsider."
 484                       (T                    ;"If there is no wild, then no match."
 485                        <RETURN>)>)
 486                (<==? .B <1 .SPECSTR>>       ;"Does it match current character?"
 487                 <SET SPECSTR <REST .SPECSTR>>)
 488                (.WILD?                      ;"If not, back up if wild."
 489                 <SET SPECSTR .WILD?>)
 490                (T                           ;"Else there is no match."
 491                 <RETURN>)>>
 492       <COND (.MATCH?                        ;"Did we find a match?"
 493              <COND (<NOT .BLURB?>           ;"If this is the first."
 494                     <SET BLURB? T>          ;"Say what module this is."
 495                     <CRLF .OUTCHAN>
 496                     <PRINTSTRING "In " .OUTCHAN>
 497                     <COND (<TESTBIT <1 .RECORD> ,RINFO-PKG?>
 498                            <PRINTSTRING "package " .OUTCHAN>)
 499                           (T
 500                            <PRINTSTRING "definitions " .OUTCHAN>)>
 501                     <PRINTSTRING .S .OUTCHAN
 502                                  <UV2SS <REST .RECORD> .S <BYTE0 <1 .RECORD>>>>
 503                     <PRINC !\: .OUTCHAN>
 504                     <CRLF .OUTCHAN>)>
 505              <INDENT-TO 3 .OUTCHAN>
 506              <PRINT-ENTRY <REST .RECORD <- .DELTA 1>> .S .OUTCHAN T>
 507              <CRLF .OUTCHAN>)>
 508       <SET ERCNT <- .ERCNT 1>>
 509       <SET SPECSTR <TOP .SPECSTR>>
 510       <SET DELTA <+ .DELTA .ERLEN 1>>>>
 511 \f
 512 ;"L-LISTU --
 513   Effect:   Print the names of all the modules in library denoted by LIBS which
 514             reference module named TARGETS.
 515   Modifies: OUTCHAN."
 516
 517 <DEFINE L-LISTU (TARGETS:STRING
 518                  "OPT" (LIBS:STRING ,PUBLIC-LIBRARY) (OUTCHAN:CHANNEL .OUTCHAN)
 519                  "AUX" (LIBC:<OR CHANNEL FALSE> %<>)
 520                        (TARGETU:UVECTOR <STACK <IUVECTOR <LENGTHW .TARGETS>>>))
 521    <UNWIND
 522     <PROG ((STATE:<OR UVECTOR FALSE> <STACK <IUVECTOR 3>>))
 523        <S2UV .TARGETS .TARGETU>             ;"TARGETS as binary string."
 524        <COND (<NOT <SET LIBC <LIBRARY-OPEN .LIBS>>>
 525               <RETURN %<>>)
 526              (<NOT <SET STATE <LQ-MAP-RECORDS .LIBC .STATE>>>
 527               <CLOSE .LIBC>
 528               <RETURN %<>>)>
 529        <REPEAT ((RECORD:UVECTOR <STACK <IUVECTOR ,MAXREC>>)
 530                 (S:STRING <STACK <ISTRING ,MAXSTRS>>) UXICNT:FIX DELTA:FIX)
 531           <COND (<LQ-NEXT-RECORD .LIBC .STATE .RECORD>
 532                  <SET UXICNT <NTH .RECORD <+ <BYTE0 <1 .RECORD>> 4>>>
 533                  <SET DELTA <+ <LHALF .UXICNT> 1>>      ;"Distance to UXI list."
 534                  <SET UXICNT <RHALF .UXICNT>>   ;"Length of UXI list."
 535                  <REPEAT (UXI:FIX COMP:FIX UXILEN:FIX)
 536                     <COND (<0? .UXICNT> <RETURN>)>
 537                     <SET UXILEN <BYTE0 <SET UXI <NTH .RECORD .DELTA>>>>
 538                     <SET COMP <UVCOMP .TARGETU <REST .RECORD .DELTA>
 539                                       <LENGTH .TARGETU> .UXILEN>>
 540                     <COND (<==? .COMP 0>    ;"Match?"
 541                            <COND (<TESTBIT <1 .RECORD> ,RINFO-PKG?>
 542                                   <PRINTSTRING "Package " .OUTCHAN>)
 543                                  (T
 544                                   <PRINTSTRING "Definitions " .OUTCHAN>)>
 545                            <PRINTSTRING .S .OUTCHAN     ;"Module name."
 546                                         <UV2SS <REST .RECORD> .S
 547                                                <BYTE0 <1 .RECORD>>>>
 548                            <COND (<TESTBIT .UXI ,UXI-USED?>
 549                                   <PRINTSTRING " uses " .OUTCHAN>)
 550                                  (<TESTBIT .UXI ,UXI-INCLUDED?>
 551                                   <PRINTSTRING " includes " .OUTCHAN>)
 552                                  (T
 553                                   <PRINTSTRING " exports " .OUTCHAN>)>
 554                            <PRINTSTRING .TARGETS .OUTCHAN>
 555                            <CRLF .OUTCHAN>
 556                            <RETURN>)
 557                           (<==? .COMP 1>    ;"Less than?"
 558                            <SET UXICNT <- .UXICNT 1>>
 559                            <SET DELTA <+ .DELTA .UXILEN 1>>)
 560                           (T                ;"Greater, we can stop looking."
 561                            <RETURN>)>>)
 562                 (T
 563                  <CLOSE .LIBC>
 564                  <RETURN>)>>>
 565     <COND (<AND .LIBC <CHANNEL-OPEN? .LIBC>> <CLOSE .LIBC>)>>>
 566 \f
 567 ;"LQ-MAP-RECORDS --
 568   Effect:   Sets up STATE for mapping over every record in LIBC.
 569   Returns:  STATE if successful, FALSE otherwise.
 570   Modifies: STATE, LIBC
 571   Note:     If LIBC is NETWORK, the MAP-RECORDS request is made followed
 572             by a request for the next record (with short bit determined
 573             by value of LONG?. The request word is placed into STATE for
 574             following requests."
 575
 576 <DEFINE LQ-MAP-RECORDS (LIBC:CHANNEL STATE:UVECTOR
 577                         "OPT" (LONG?:<OR ATOM FALSE> T))
 578    <PROG ()
 579       <IFSYS ("VAX"
 580               ;"Network => MAP-RECORDS. If that succeeds then NEXT-RECORD."
 581               <COND (<REMOTE? .LIBC>
 582                      <1 <SET STATE <REST .STATE>> ,MAP-RECORDS-REQUEST>
 583                      <CHANNEL-OP .LIBC:NET WRITE-BUFFER .STATE 1>
 584                      <SET STATE <REST .STATE>>
 585                      <COND (<AND <GET-REMOTE-RESPONSE .LIBC .STATE>
 586                                  <==? <1 .STATE> ,ACK>>
 587                             ;"Request next and set up for following call."
 588                             <1 .STATE
 589                                <COND (.LONG? ,MAP-NEXT-RECORD)
 590                                      (T <ORB ,MAP-NEXT-RECORD
 591                                              ,MAP-SHORT-RECORD>)>>
 592                             <CHANNEL-OP .LIBC:NET WRITE-BUFFER .STATE 1>
 593                             <RETURN .STATE>)
 594                            (T <RETURN %<>>)>)>)>
 595       ;"Local library."
 596       <RETURN <MAP-RECORDS .LIBC .STATE>>>>
 597
 598 ;"LQ-NEXT-RECORD --
 599   Effect:   Fetches the next record from LIBC in map sequence if there is one.
 600   Modifies: LIBC, STATE, RECORD
 601   Returns:  T if record was read into RECORD, else FALSE.
 602   Requires: size(RECORD) >= size(record), STATE is descriptor created by
 603             LQ-MAP-RECORDS and modified only by LQ-NEXT-RECORD.
 604   Note:     LONG? has no effect if library is network because that has
 605             already been taken into account in STATE. The next record
 606             is requested as soon as a record is received."
 607
 608 <DEFINE LQ-NEXT-RECORD (LIBC:CHANNEL STATE:UVECTOR RECORD:UVECTOR
 609                         "OPT" (LONG?:<OR ATOM FALSE> T))
 610    <PROG ()
 611       <IFSYS ("VAX"
 612               ;"Network => record waiting. Request next after reception."
 613               <COND (<REMOTE? .LIBC>
 614                      <COND (<GET-REMOTE-RECORD .LIBC .RECORD>
 615                             ;"Request next record."
 616                             <CHANNEL-OP .LIBC:NET WRITE-BUFFER .STATE>
 617                             <RETURN>)
 618                            (T <RETURN %<>>)>)>)>
 619       ;"Local."
 620       <BIND ((NEXT:<OR FALSE FIX> <NEXT-RECORD .LIBC .STATE>))
 621          <RETURN <AND .NEXT <GET-ADDRESSED-RECORD .NEXT .LIBC .RECORD .LONG?>>>>>>
 622 \f
 623 ;"LQ-GET-RECORD --
 624   Effect:   Fetch record named NAME into RECORD from LIBC.
 625   Modifies: RECORD, LIBC
 626   Returns:  T if record was fetched, otherwise FALSE.
 627   Requires: If LIBC is network channel, no request has been made yet
 628             (the server will hang up when this request is processed)."
 629
 630 <DEFINE LQ-GET-RECORD (NAME:STRING LIBC:CHANNEL RECORD:UVECTOR
 631                        "OPT" (LONG?:<OR ATOM FALSE> T))
 632    <PROG ()
 633       <IFSYS ("VAX"
 634               ;"Network => send record request with name."
 635               <COND (<REMOTE? .LIBC>
 636                      <1 .RECORD
 637                         <ORB <LSH <LENGTH .NAME> 8> ,RECORD-REQUEST
 638                              <COND (.LONG? 0) (T ,RECORD-SHORT)>>>
 639                      <CHANNEL-OP .LIBC:NET WRITE-BUFFER .RECORD 1>
 640                      <CHANNEL-OP .LIBC:NET WRITE-BUFFER .NAME>
 641                      <COND (<GET-REMOTE-RECORD .LIBC .RECORD> <RETURN>)
 642                            (T <RETURN %<>>)>)>)>
 643       ;"Local."
 644       <RETURN <GET-NAMED-RECORD .NAME .LIBC .RECORD .LONG?>>>>
 645
 646 ;"UVCOMP --
 647   Effect:  Compare two binary strings (8-BIT ASCII UVECTORS). L1, L2 is
 648            number of valid words in UV1, UV2 respectively.
 649   Returns: 1 if UV1 sorts before UV2. 0 if UV1 matches UV2. -1 if
 650            UV1 sorts after UV2.
 651   Note:   NULL byte is interpreted as end of string."
 652
 653 <DEFINE UVCOMP (UV1:UVECTOR UV2:UVECTOR
 654                 "OPT" (L1:FIX <LENGTH .UV1>) (L2:FIX <LENGTH .UV2>))
 655    <REPEAT (W1:FIX W2:FIX)
 656       <COND (<==? <SET W1 <1 .UV1>> <SET W2 <1 .UV2>>>
 657              <SET L1 <- .L1 1>>
 658              <SET L2 <- .L2 1>>
 659              <COND (<OR <==? .L1 0> <==? .L2 0>>
 660                     <COND (<==? .L1 0>
 661                            <COND (<==? .L2 0> <RETURN 0>) (T <RETURN -1>)>)
 662                           (T <RETURN 1>)>)
 663                    (T
 664                     <SET UV1 <REST .UV1>>
 665                     <SET UV2 <REST .UV2>>)>)
 666             (T
 667              <BIND (B1:FIX B2:FIX)
 668                 <COND (<N==? <SET B1 <BYTE3 .W1>> <SET B2 <BYTE3 .W2>>>)
 669                       (<N==? <SET B1 <BYTE2 .W1>> <SET B2 <BYTE2 .W2>>>)
 670                       (<N==? <SET B1 <BYTE1 .W1>> <SET B2 <BYTE1 .W2>>>)
 671                       (T
 672                        <SET B1 <BYTE0 .W1>>
 673                        <SET B2 <BYTE0 .W2>>)>
 674                 <COND (<L? .B1 .B2> <RETURN -1>) (T <RETURN 1>)>>)>>>
 675
 676 <ENDPACKAGE>