mim/development/mim/vax/mimlib/lup-base.mud

   1 ;"*****************************************************************************
   2   This file defines library update primitives for use with a resident library
   3   file. Both the server and LUP use these procedures (spliced in at compile
   4   time). See LIBRARY.FORMAT for definition of binary formats of record and
   5   library.
   6
   7   LUP-BASE.MUD: EDIT HISTORY                                Machine Independent
   8
   9   COMPILATION: Spliced in at compile time.
  10
  11     JUN84 [Shane] - Created.
  12   18OCT84 [Shane] - Commented, cleaned up.
  13   28OCT84 [Shane] - Add LUPI-INSTALL.
  14    9OCT84 [Shane] - Add LUPI-ADD-FILE, LUPI-FILE-EXISTS?, LUPI-DEL-FILE
  15   ****************************************************************************"
  16
  17 <COND (<NOT <VALID-TYPE? LIBLOCK>> <NEWTYPE LIBLOCK VECTOR>)>   ;"See L-DEFS."
  18
  19 ;"LUPI-KEY -- Is the LIBLOCK when an update is in progress."
  20
  21 <OR <GASSIGNED? LUPI-KEY> <SETG LUPI-KEY %<> '<OR FALSE LIBLOCK>>>
  22
  23 ;"LUPI-ABORT --
  24   Effect:   Aborts an update in progress. Deletes all temporary files
  25             generated, writes message to log file, and unlocks library.
  26   Modifies: K."
  27
  28 <DEFINE LUPI-ABORT ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY)
  29                           NAME:STRING CH:<CHANNEL 'DISK>)
  30    <COND (.K
  31           <MAPF %<> ,DELFILE <LL-TMP-FILES .K>>
  32           <COND (<CHANNEL-OPEN? <SET CH <LL-LOG .K>>>
  33                  <PRINTSTRING "*** Update aborted." .CH>
  34                  <CRLF .CH>
  35                  <CLOSE .CH>)>
  36           <COND (<CHANNEL-OPEN? <SET CH <LL-NEW .K>>>
  37                  <SET NAME <CHANNEL-OP .CH:DSK NAME>>
  38                  <CLOSE .CH>)
  39                 (T
  40                  <SET NAME <CHANNEL-NAME .CH>>)>
  41           <DELFILE .NAME>
  42           <IFSYS ("VAX"                     ;"Undo the soft lock under UNIX."
  43                   <COND (<CHANNEL-OPEN? <SET CH <LL-OLD .K>>>
  44                          <CALL SYSCALL FLOCK <CHANNEL-OP .CH:DSK FILE-HANDLE>
  45                                ,UNLOCK-FILE>)>)>
  46           <SETG LUPI-KEY %<>>
  47           T)>>
  48
  49 ;"LUPI-GENTEMP --
  50   Effect:   Generate a unique file name for the library directory:
  51             LIBTMPnnn.TEMP if the library is locked.
  52   Returns:  Filename.
  53   Modifies: K."
  54
  55 <DEFINE LUPI-GENTEMP ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
  56    <COND (.K
  57           <PROG ((DEV:<SPECIAL STRING> <CHANNEL-OP <LL-OLD .K>:DSK DEV>)
  58                  (SNM:<SPECIAL STRING> <CHANNEL-OP <LL-OLD .K>:DSK SNM>)
  59                  (NM2:<SPECIAL STRING> "TEMP") (SUFFIX:FIX <LL-SUFFIX .K>)
  60                  (NAME:STRING <STACK <ISTRING 32>>)
  61                  FN:<CHANNEL 'PARSE>)
  62              ;"Increment the suffix. I2S returns NAME rested to digits."
  63              <LL-SUFFIX .K <+ .SUFFIX 1>>
  64              <SUBSTRUC "LIBTMP" 0 6 <SET NAME <BACK <I2S .SUFFIX .NAME> 6>>>
  65              <SET FN <CHANNEL-OPEN PARSE .NAME>>
  66              <SET NAME <CHANNEL-OP .FN NAME>>
  67              <CLOSE .FN>
  68              <RETURN .NAME>>)>>
  69 \f
  70 ;"LUPI-LOCK --
  71   Effect:   Locks library corresponding to LIB. Creates the LIBLOCK and
  72             writes message to LOG. The contents of the library is copied
  73             and all update actions affect the copy.
  74   Returns:  The locked active library.
  75   Modifies: LOG.
  76   Note:     The default for the log file is NM1.LOG where NM1 is first name
  77             of library file in library directory."
  78
  79 <DEFINE LUPI-LOCK (LIB:<CHANNEL 'DISK>
  80                    "OPT" (LOG:<OR <CHANNEL 'DISK> FALSE> %<>)
  81                    "AUX" (NEW:<OR <CHANNEL 'DISK> FALSE> %<>))
  82    <PROG ((DEV:<SPECIAL STRING> <CHANNEL-OP .LIB DEV>)
  83           (SNM:<SPECIAL STRING> <CHANNEL-OP .LIB SNM>)
  84           (NM1:<SPECIAL STRING> <CHANNEL-OP .LIB NM1>)
  85           (NM2:<SPECIAL STRING> <CHANNEL-OP .LIB NM2>)
  86           (NAME:STRING <CHANNEL-OP .LIB NAME>)
  87           FN:<CHANNEL 'PARSE>)
  88       ;"Check to see if user already has library locked."
  89       <COND (<AND <GASSIGNED? LUPI-KEY> ,LUPI-KEY>
  90              <RETURN #FALSE ("LOCKED")>)>
  91       <IFSYS ("VAX"
  92               ;"Soft lock under UNIX."
  93               <COND (<NOT <CALL SYSCALL FLOCK <CHANNEL-OP .LIB FILE-HANDLE>
  94                                 ,LOCK-FILE>>
  95                      <RETURN #FALSE ("LOCKED")>)>)
  96              ("TOPS20"
  97               ;"Thawed under TOPS20."
  98               <COND (<SET NEW <CHANNEL-OPEN DISK .NAME "MODIFY" "BINARY">>
  99                      <CLOSE .LIB>
 100                      <SET LIB .NEW>)
 101                     (T
 102                      <RETURN #FALSE ("LOCKED")>)>)>
 103       ;"Open the log file if we were not given one. Recreate if needed."
 104       <COND (<NOT .LOG>
 105              <SET NM2 "LOG">
 106              <SET FN <CHANNEL-OPEN PARSE .NM1>>
 107              <SET NAME <CHANNEL-OP .FN NAME>>
 108              <CLOSE .FN>
 109              <COND (<SET LOG <CHANNEL-OPEN DISK .NAME "MODIFY" "ASCII">>
 110                     <CHANNEL-OP .LOG ACCESS <FILE-LENGTH .LOG>>)
 111                    (<SET LOG <CHANNEL-OPEN DISK .NAME "CREATE" "ASCII">>
 112                     <CLOSE .LOG>
 113                     <SET LOG <CHANNEL-OPEN DISK .NAME "MODIFY" "ASCII">>
 114                     <PRINTSTRING "*** " .LOG>
 115                     <PRINTSTRING <DTIME> .LOG>
 116                     <PRINTSTRING " Log file recreated." .LOG>
 117                     <CRLF .LOG>)>)>
 118       ;"Copy the library to temporary file."
 119       <SET NM2 "TEMP">
 120       <SET FN <CHANNEL-OPEN PARSE "LIBTMP0">>
 121       <SET NAME <CHANNEL-OP .FN NAME>>
 122       <CLOSE .FN>
 123       <COND (<SET NEW <CHANNEL-OPEN DISK .NAME "CREATE" "BINARY">>
 124              <CHANNEL-OP .LIB:DSK ACCESS 0>
 125              <REPEAT ((B:<UVECTOR [REST FIX]> <STACK <IUVECTOR 512>>) N:FIX)
 126                 <SET N <OR <CHANNEL-OP .LIB:DSK READ-BUFFER .B> 0>>
 127                 <CHANNEL-OP .NEW:DSK WRITE-BUFFER .B .N>
 128                 <COND (<L? .N <LENGTH .B>> <RETURN>)>>
 129              ;"Make the key and say library is locked."
 130              <SETG LUPI-KEY <CHTYPE [.LIB .NEW .LOG () () () 1] LIBLOCK>>
 131              <PRINTSTRING "*** " .LOG>
 132              <PRINTSTRING <DTIME> .LOG>
 133              <PRINTSTRING " Library locked." .LOG>
 134              <CRLF .LOG>
 135              .LIB)>>>
 136
 137 ;"LUPI-COMMIT --
 138   Effect:   Deletes files that have been deleted from library. Renames
 139             temporary files to destinations for files that have been
 140             added to library. Renames temporary library to library and
 141             releases lock. All accompanied by messages to log file.
 142   Modifies: K, LOG."
 143
 144 <DEFINE LUPI-COMMIT ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY) LOG:<CHANNEL 'DISK>)
 145    <COND (.K
 146           <SET LOG <LL-LOG .K>>
 147           ;"Delete files."
 148           <MAPF %<>
 149                 <FUNCTION (NAME:STRING)
 150                    <PRINTSTRING "    Deleting file " .LOG>
 151                    <PRINTSTRING .NAME .LOG>
 152                    <CRLF .LOG>
 153                    <DELFILE .NAME>>
 154                 <LL-DEL-FILES .K>>
 155           ;"Rename temporary files."
 156           <MAPF %<>
 157                 <FUNCTION (FROM:STRING TO:STRING)
 158                    <PRINTSTRING "    Adding file " .LOG>
 159                    <PRINTSTRING .TO .LOG>
 160                    <CRLF .LOG>
 161                    <RENAME .FROM .TO>>
 162                 <LL-TMP-FILES .K>
 163                 <LL-ADD-FILES .K>>
 164           ;"Rename temporary library, flushing old library."
 165           <BIND ((OLD:STRING <CHANNEL-OP <LL-OLD .K>:DSK NAME>)
 166                  (NEW:STRING <CHANNEL-OP <LL-NEW .K>:DSK NAME>))
 167              <CLOSE <LL-NEW .K>>
 168              <CLOSE <LL-OLD .K>>
 169              <IFSYS ("TOPS20" <DELFILE .OLD>)>
 170              <RENAME .NEW .OLD>
 171              <PRINTSTRING "*** Update completed." .LOG>
 172              <CRLF .LOG>
 173              <CLOSE .LOG>
 174              <SETG LUPI-KEY %<>>
 175              T>)>>
 176 \f
 177 ;"LUPI-INSTALL --
 178   Effect:   Deletes files that have been deleted from library. Renames
 179             temporary files to destinations for files that have been
 180             added to library. Renames temporary library to library but
 181             retains lock. All accompanied by messages to log file.
 182   Modifies: K, LOG."
 183
 184 <DEFINE LUPI-INSTALL ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY) LOG:<CHANNEL 'DISK>)
 185    <COND (.K
 186           <SET LOG <LL-LOG .K>>
 187           ;"Delete files."
 188           <MAPF %<>
 189                 <FUNCTION (NAME:STRING)
 190                    <PRINTSTRING "    Deleting file " .LOG>
 191                    <PRINTSTRING .NAME .LOG>
 192                    <CRLF .LOG>
 193                    <DELFILE .NAME>>
 194                 <LL-DEL-FILES .K>>
 195           ;"Rename temporary files."
 196           <MAPF %<>
 197                 <FUNCTION (FROM:STRING TO:STRING)
 198                    <PRINTSTRING "    Adding file " .LOG>
 199                    <PRINTSTRING .TO .LOG>
 200                    <CRLF .LOG>
 201                    <RENAME .FROM .TO>>
 202                 <LL-TMP-FILES .K>
 203                 <LL-ADD-FILES .K>>
 204           ;"Rename temporary library, flushing old library, locking new."
 205           <BIND ((OLD:STRING <CHANNEL-OP <LL-OLD .K>:DSK NAME>)
 206                  (NEW:STRING <CHANNEL-OP <LL-NEW .K>:DSK NAME>)
 207                  CH:<OR <CHANNEL 'DISK> FALSE>)
 208              <CLOSE <LL-NEW .K>>
 209              <CLOSE <LL-OLD .K>>
 210              <IFSYS ("TOPS20" <DELFILE .OLD>)>
 211              <RENAME .NEW .OLD>
 212              <PRINTSTRING "*** Installed." .LOG>
 213              <CRLF .LOG>
 214              <SETG LUPI-KEY %<>>
 215              ;"Small window here where someone else could grab library."
 216              <COND (<AND <SET CH <CHANNEL-OPEN DISK .OLD "READ" "BINARY">>
 217                          <LUPI-LOCK .CH .LOG>>)
 218                    (T
 219                     <AND .CH <CLOSE .CH>>
 220                     <CLOSE .LOG>
 221                     %<>)>>)>>
 222 \f
 223 ;"LUPI-CREATE --
 224   Effect:  Create a library named NAME with default second name LIBMIM.
 225            Creates associated log file.
 226   Returns: Full library name."
 227
 228 <DEFINE LUPI-CREATE ("OPT" (NAME:STRING "LIBMIM") (NBKTS:FIX ,INITIAL-BUCKETS)
 229                      "AUX" (LIB:<OR <CHANNEL 'DISK> FALSE> %<>)
 230                            (LOG:<OR <CHANNEL 'DISK> FALSE> %<>))
 231    <SET NBKTS <NEXT-PRIME .NBKTS>>
 232    <PROG ((DIR:<UVECTOR [REST FIX]> <STACK <IUVECTOR <+ .NBKTS ,DIR-HDRLEN> 0>>)
 233           (NM2:<SPECIAL STRING> "LBIN")
 234           (FN:<CHANNEL 'PARSE> <CHANNEL-OPEN PARSE .NAME>))
 235       <SET NAME <CHANNEL-OP .FN NAME>>
 236       <CLOSE .FN>
 237       ;"If it exists, ask user what to do."
 238       <COND (<SET LIB <CHANNEL-OPEN DISK .NAME "READ" "BINARY">>
 239              <COND (<ERROR LIBRARY-FILE-EXISTS!-ERRORS
 240                            ERRET-T-TO-CLOBBER-EXISTING-LIBRARY!-ERRORS
 241                            <SET NAME <CHNNEL-OP .LIB NAME>>
 242                            LUPI-CREATE>
 243                     <CLOSE .LIB>
 244                     <DELFILE .NAME>)
 245                    (T
 246                     <RETURN %<>>)>)>
 247       ;"Create library directory and log file."
 248       <COND (<SET LIB <CHANNEL-OPEN DISK .NAME "CREATE" "BINARY">>
 249              <PROG ((SNM:<SPECIAL STRING> <CHANNEL-OP .LIB SNM>)
 250                     (DEV:<SPECIAL STRING> <CHANNEL-OP .LIB DEV>))
 251                 <SET NM2 "LOG">
 252                 <SET FN <CHANNEL-OPEN PARSE <CHANNEL-OP .LIB NM1>>>
 253                 <SET NAME <CHANNEL-OP .FN NAME>>
 254                 <CLOSE .FN>
 255                 <SET LOG <CHANNEL-OPEN DISK .NAME "CREATE" "ASCII">>>
 256              ;"Hash table size and end of file pointer."
 257              <PUT .DIR <+ ,DIR-TABSIZ 1> .NBKTS>
 258              <PUT .DIR <+ ,DIR-EOFPTR 1> <LENGTH .DIR>>
 259              <CHANNEL-OP .LIB WRITE-BUFFER .DIR>
 260              <SET NAME <CHANNEL-OP .LIB NAME>>
 261              <CLOSE .LIB>
 262              <PRINTSTRING "*** " .LOG>
 263              <PRINTSTRING <DTIME> .LOG>
 264              <PRINTSTRING " Library created" .LOG>
 265              <CRLF .LOG>
 266              <CLOSE .LOG>
 267              .NAME)
 268             (T
 269              <ERROR CANT-OPEN-LIBRARY-FILE!-ERRORS .NAME .LIB LUPI-CREATE>
 270              .LIB)>>>
 271 \f
 272 ;"LUPI-ADD-PACK --
 273   Effect:   Adds RECORD to shadow library. The names in TMP are the names
 274             of the temporary files involved in the transaction. The names
 275             in ADD are the destination file names. The order MUST be the
 276             same. Writes message to log file.
 277   Modifies: K."
 278
 279 <DEFINE LUPI-ADD-PACK (RECORD:<UVECTOR [REST FIX]> ADD:LIST TMP:LIST
 280                        "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
 281    <COND (<AND .K
 282                <==? <LENGTH .ADD> <LENGTH .TMP>>        ;"Just in case."
 283                <ADD-RECORD .RECORD <LL-NEW .K>>>
 284           <BIND ((LLADD:LIST <LL-ADD-FILES .K>)
 285                  (LLTMP:LIST <LL-TMP-FILES .K>)
 286                  (LLSIZE:FIX <LENGTH .LLTMP>)
 287                  (LOG:<CHANNEL 'DISK> <LL-LOG .K>)
 288                  (NAME:STRING <STACK <ISTRING ,MAXSTRS>>))
 289              ;"Splice file names onto existing lists."
 290              <COND (<==? .LLSIZE 0>
 291                     <LL-TMP-FILES .K .TMP>
 292                     <LL-ADD-FILES .K .ADD>)
 293                    (<NOT <EMPTY? .TMP>>
 294                     <PUTREST <REST .LLTMP <- .LLSIZE 1>> .TMP>
 295                     <PUTREST <REST .LLADD <- .LLSIZE 1>> .ADD>)>
 296              <PRINTSTRING "    Adding record " .LOG>
 297              <PRINTSTRING .NAME .LOG
 298                           <UV2SS <REST .RECORD> .NAME <BYTE0 <1 .RECORD>>>>
 299              <CRLF .LOG>>)>>
 300
 301 ;"LUPI-ADD-FILE --
 302   Effect:   Adds an auxiliary file to the library directory (such as a runtime
 303             help file). TMP is the name of the temporary file obtained from
 304             LUPI-GENTEMP and ADD is the name the file should be renamed to when
 305             the library is installed.
 306   Modifies: K."
 307
 308 <DEFINE LUPI-ADD-FILE (TMP:STRING ADD:STRING
 309                        "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
 310    <COND (.K
 311           <LL-TMP-FILES .K (.TMP !<LL-TMP-FILES .K>)>
 312           <LL-ADD-FILES .K (.ADD !<LL-ADD-FILES .K>)>
 313           T)>>
 314
 315 ;"LUPI-DEL-FILE --
 316   Effect:   Adds the name of an auxiliary file (in the library directory) to
 317             the list of files to be deleted when the modified library is
 318             installed.
 319   Modifies: K."
 320
 321 <DEFINE LUPI-DEL-FILE (DEL:STRING "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
 322    <COND (.K
 323           <PROG ((OLD:<CHANNEL 'DISK> <LL-OLD .K>)
 324                  (DEV:<SPECIAL STRING> <CHANNEL-OP .OLD DEV>)
 325                  (SNM:<SPECIAL STRING> <CHANNEL-OP .OLD SNM>)
 326                  (FN:<CHANNEL 'PARSE> <CHANNEL-OPEN PARSE .DEL>)
 327                  (NM2:<SPECIAL STRING> <CHANNEL-OP .FN NM2>))
 328              <SET DEL <CHANNEL-OP .FN NM1>>
 329              <CLOSE .FN>
 330              <CHANNEL-OPEN PARSE .DEL>
 331              <SET DEL <CHANNEL-OP .FN NAME>>
 332              <CLOSE .FN>
 333              <LL-DEL-FILES .K (.DEL !<LL-DEL-FILES .K>)>
 334              T>)>>
 335 \f
 336 ;"LUPI-DEL-PACK --
 337   Effect:   Deletes record named PACKAGE from shadow library and adds the
 338             file names in record to delete list (if they correspond to files
 339             in the library directory.
 340   Modifies: K."
 341
 342 <DEFINE LUPI-DEL-PACK (PACKAGE:STRING "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
 343    <COND
 344     (.K
 345      <PROG ((FILES:VECTOR <STACK <IVECTOR 4 %<>>>)
 346             (LLDEL:LIST <LL-DEL-FILES .K>)
 347             (LOG:<CHANNEL 'DISK> <LL-LOG .K>)
 348             (NEW:<CHANNEL 'DISK> <LL-NEW .K>)
 349             (DEV:<SPECIAL STRING> <CHANNEL-OP .NEW DEV>)
 350             (SNM:<SPECIAL STRING> <CHANNEL-OP .NEW SNM>)
 351             FN:<CHANNEL 'PARSE>)
 352         <COND
 353          (<REMOVE-RECORD .PACKAGE .NEW .FILES>
 354           ;"Map over the files REMOVE-RECORD found, adding them to
 355             delete list if they are in the library directory. This
 356             will always happen unless the library contains explicit
 357             path name (those without paths must be in the library
 358             directory and will be parsed as such)."
 359           <MAPF
 360            %<>
 361            <FUNCTION (NAME:<OR STRING FALSE>)
 362               <COND (.NAME
 363                      <SET FN <CHANNEL-OPEN PARSE .NAME>>
 364                      <COND (<AND <=? <CHANNEL-OP .FN DEV>:STRING .DEV>
 365                                  <=? <CHANNEL-OP .FN SNM>:STRING .SNM>>
 366                             <SET LLDEL
 367                                  (<CHANNEL-OP .FN NAME ,NO-GENERATION> !.LLDEL)>)>
 368                      <CLOSE .FN>)>>
 369            .FILES>
 370           <LL-DEL-FILES .K .LLDEL>
 371           <PRINTSTRING "    Removing record " .LOG>
 372           <PRINTSTRING .PACKAGE .LOG>
 373           <CRLF .LOG>
 374           T)>>)>>
 375
 376 ;"LUPI-GC --
 377   Effect:   Compact shadow library, reclaiming any holes in the file. The
 378             old shadow library is closed and the garbage collected shadow
 379             library becomes the shadow library. Writes message to log file.
 380             NBKTS suggests the number of buckets to use.
 381   Modifies: K."
 382
 383 <DEFINE LUPI-GC ("OPT" (NBKTS:FIX ,INITIAL-BUCKETS)
 384                  "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
 385    <COND (.K
 386           <BIND ((NEW:<CHANNEL 'DISK> <LL-NEW .K>)
 387                  (NAME:STRING <LUPI-GENTEMP>)
 388                  (LOG:<CHANNEL 'DISK> <LL-LOG .K>)
 389                  NNEW:<OR FALSE <CHANNEL 'DISK>>)
 390              <COND (<AND <SET NNEW <CHANNEL-OPEN DISK .NAME "CREATE" "BINARY">>
 391                          <GC-LIB .NEW .NNEW .NBKTS>>
 392                     <SET NAME <CHANNEL-OP .NEW NAME>>
 393                     <FLUSH .NEW>
 394                     <DELFILE .NAME>
 395                     <LL-NEW .K .NNEW>
 396                     <PRINTSTRING "*** Library GC" .LOG>
 397                     <CRLF .LOG>
 398                     T)
 399                    (.NNEW
 400                     <FLUSH .NNEW>
 401                     <DELFILE .NAME>
 402                     %<>)>>)>>
 403 \f
 404 ;"NPRIME? -- Returns T iff N is not prime."
 405
 406 <DEFINE NPRIME? (N:FIX)
 407    #DECL ((N) FIX)
 408    <REPEAT ((D:FIX 2) (SQ:FIX <FIX <+ <SQRT <FLOAT .N>>:FLOAT 1.0>>))
 409       <COND (<G? .D .SQ> <RETURN %<>>)
 410             (<==? <MOD .N .D> 0> <RETURN .D>)>
 411       <SET D <+ .D 1>>>>
 412
 413 ;"NEXT-PRIME -- Returns next prime larger than X."
 414
 415 <DEFINE NEXT-PRIME (X:FIX)
 416    <REPEAT () <COND (<NOT <NPRIME? <SET X <+ .X 1>>>> <RETURN .X>)>>>
 417
 418 ;"ALLOCATE --
 419   Effect:   Allocates AMT storage in LIB. The storage is taken from the free
 420             list if possible otherwise storage is allocated at the end of
 421             the file.
 422   Modifies: LIB
 423   Returns:  Address of allocated storage block."
 424
 425 <DEFINE ALLOCATE (LIB:<CHANNEL 'DISK> AMT:FIX
 426                   "AUX" BSIZE:FIX BADDR:FIX BPRED:FIX BSUCC:FIX SIZE:FIX
 427                         ADDR:FIX SUCC:FIX PRED:FIX)
 428    <SETADR .LIB <SET PRED ,DIR-FRELST>>     ;"Move to free list."
 429    <SET ADDR <RDWRD .LIB>>                  ;"Address of first block."
 430    <SET BADDR <RDWRD .LIB>>                 ;"Best address initially EOF."
 431    <SET BSIZE *77777777*>                   ;"Best size initially max."
 432    <SET BPRED 0>                            ;"No predecessor."
 433    <SET BSUCC 0>                            ;"No successor."
 434    <COND (<N==? .ADDR 0>                    ;"Not end of list?"
 435           <SETADR .LIB .ADDR>               ;"Go to block descriptor."
 436           <SET SIZE <RDWRD .LIB>>           ;"Its size."
 437           <SET SUCC <RDWRD .LIB>>           ;"Its cdr."
 438           <REPEAT ()                        ;"Cruise the list."
 439              <COND (<OR <==? .SIZE .AMT>    ;"Better tnan best so far?"
 440                         ;"Must be at least 2 words bigger."
 441                         <AND <G=? .SIZE <+ .AMT 2>> <L? .SIZE .BSIZE>>>
 442                     <SET BSIZE .SIZE>       ;"Yep, set best variables."
 443                     <SET BPRED .PRED>
 444                     <SET BSUCC .SUCC>
 445                     <SET BADDR .ADDR>)>
 446              ;"If end of list or exact, we can do no better."
 447              <COND (<OR <0? .SUCC> <==? .BSIZE .AMT>>
 448                     <RETURN>)
 449                    (T
 450                     <SET PRED <+ .ADDR 1>>  ;"Move to next block."
 451                     <SETADR .LIB <SET ADDR .SUCC>>
 452                     <SET SIZE <RDWRD .LIB>>
 453                     <SET SUCC <RDWRD .LIB>>)>>)>
 454    <COND (<==? .BPRED 0>                    ;"0 -- eof, bump eof pointer."
 455           <SETADR .LIB ,DIR-EOFPTR>
 456           <WRWRD .LIB <+ .BADDR .AMT>>)
 457          (T
 458           <SETADR .LIB .BPRED>              ;"Got a block from list."
 459           <COND (<==? .BSIZE .AMT>          ;"Exact, just splice out."
 460                  <WRWRD .LIB .BSUCC>)
 461                 (T                          ;"Carve out a piece."
 462                  <WRWRD .LIB <SET ADDR <+ .BADDR .AMT>>>
 463                  <SETADR .LIB .ADDR>        ;"Splice in reduced block."
 464                  <WRWRD .LIB <- .BSIZE .AMT>>
 465                  <WRWRD .LIB .BSUCC>)>)>
 466    <COND (<G? <+ .BADDR .AMT> *77777777*>   ;"File address < 24 bits."
 467           <ERROR LIBRARY-SPACE-EXHAUSTED!-ERRORS .BADDR ALLOCATE>
 468           %<>)
 469          (T
 470           .BADDR)>>
 471 \f
 472 ;"FREE --
 473   Effect:   Deallocate AMT storage beginning at address START. The block
 474             is spliced into the FREE list in storage order.
 475   Modifies: LIB."
 476
 477 <DEFINE FREE (LIB:<CHANNEL 'DISK> START:FIX AMT:FIX
 478               "AUX" (END:FIX <+ .START .AMT>) (PAIR <STACK <UVECTOR .AMT 0>>)
 479                     PRED:FIX SUCC:FIX)
 480    <SETADR .LIB <SET PRED ,DIR-FRELST>>     ;"Move to free list."
 481    <COND (<==? <SET SUCC <RDWRD .LIB>> 0>   ;"If none, its easy."
 482           <SETADR .LIB ,DIR-FRELST>
 483           <WRWRD .LIB .START>
 484           <SETADR .LIB .START>
 485           <WRBUF .LIB .PAIR>)
 486          (T                                 ;"Find where block belongs."
 487           <REPEAT (SIZE:FIX)
 488              <SETADR .LIB .SUCC>            ;"Move to successor."
 489              <RDBUF .LIB .PAIR>             ;"Get descriptor."
 490              <COND (<==? .START <+ .SUCC <SET SIZE <1 .PAIR>>>>
 491                     ;"Block is adjacent to end of SUCC, compact."
 492                     <COND (<==? .END <2 .PAIR>>
 493                            ;"Block exactly fills hole between SUCC and
 494                              and its successor, compact all three."
 495                            <SET AMT <+ .SIZE .AMT>>     ;"Add block to SUCC."
 496                            <SETADR .LIB <2 .PAIR>>      ;"Move to SUCC's cdr."
 497                            <RDBUF .LIB .PAIR>           ;"Get its size."
 498                            <SET SIZE <1 .PAIR>>)>       ;"and its successor."
 499                     <1 .PAIR <+ .SIZE .AMT>> ;"Add the words we are freeing."
 500                     <SETADR .LIB .SUCC>      ;"Move to SUCC."
 501                     <WRBUF .LIB .PAIR>       ;"And mung in the new descriptor."
 502                     <RETURN>)
 503                    (<==? .END .SUCC>
 504                     ;"SUCC is adjacent to end of block, compact."
 505                     <SETADR .LIB .START>
 506                     ;"SUCC's successor becomes block's successor,
 507                       add SUCC's size to block's size, mung in new descriptor
 508                       and mung SUCC's predecessor.."
 509                     <WRBUF .LIB <1 .PAIR <+ .SIZE .AMT>>>
 510                     <SETADR .LIB .PRED>
 511                     <WRWRD .LIB .START>
 512                     <RETURN>)
 513                    (<L? .START .SUCC>
 514                     ;"Block belongs before SUCC, mung SUCC's predecessor and
 515                       point block at SUCC."
 516                     <SETADR .LIB .START>
 517                     <WRBUF .LIB <1 <2 .PAIR .SUCC> .AMT>>
 518                     <SETADR .LIB .PRED>
 519                     <WRWRD .LIB .START>
 520                     <RETURN>)
 521                    (<==? <2 .PAIR> 0>
 522                     ;"Block belongs after SUCC, point SUCC at block."
 523                     <SETADR .LIB <+ .SUCC 1>>
 524                     <WRWRD .LIB .START>
 525                     <SETADR .LIB .START>
 526                     <WRBUF .LIB <1 <2 .PAIR 0> .AMT>>
 527                     <RETURN>)
 528                    (T                        ;"Keep looking."
 529                     <SET PRED <+ .SUCC 1>>
 530                     <SET SUCC <2 .PAIR>>)>>)>
 531    T>
 532 \f
 533 ;"ADD-RECORD --
 534   Effect:   Adds RECORD to LIB. The directory is pointed at RECORD and all of its
 535             entrys.
 536   Modifies: LIB
 537   Requires: RECORD is a properly formatted library record as defined in
 538             LIBRARY.FORMAT."
 539
 540 <DEFINE ADD-RECORD (RECORD:<UVECTOR [REST FIX]> LIB:<CHANNEL 'DISK> "NAME" ADD-RECORD
 541                     "AUX" TMP:FIX RECADDR:FIX ADDR:FIX ERCNT:FIX DELTA:FIX
 542                           NBKTS:FIX
 543                           (STATS:<UVECTOR [REST FIX]> <STACK <IUVECTOR 2>>))
 544    <COND (<G? <SET TMP <LHALF <1 .RECORD>>> <LENGTH .RECORD>>
 545           <ERROR BAD-RECORD!-ERRORS "Incorrect RECLEN" .TMP <LENGTH .RECORD>
 546                  ADD-RECORD>
 547           <RETURN %<> .ADD-RECORD>)>
 548    <SET RECADDR <ALLOCATE .LIB .TMP>>        ;"Get some space."
 549    <SETADR .LIB .RECADDR>                    ;"Move to allocated address."
 550    <WRBUF .LIB .RECORD .TMP>                 ;"Write the record."
 551    <SETADR .LIB ,DIR-TABSIZ>                 ;"Get size of hash table."
 552    <SET NBKTS <RDWRD .LIB>>
 553    <SETADR .LIB ,DIR-LERCNT>                 ;"Get entry, package counts."
 554    <RDBUF .LIB .STATS>
 555    <SET TMP <BYTE0 <1 .RECORD>>>             ;"Length of record name."
 556    <SET ADDR <HASH-UV <REST .RECORD> .NBKTS .TMP>>
 557    <ADD-POINTER .LIB .ADDR .RECADDR ,BKT-P>  ;"Point bucket at RECORD."
 558    <SET TMP <NTH .RECORD <+ .TMP 3>>>        ;"Entry count, distance to list."
 559    <SET ERCNT <RHALF .TMP>>
 560    <SET DELTA <LHALF .TMP>>
 561    <2 <1 .STATS <+ <1 .STATS> .ERCNT>> <+ <2 .STATS> 1>>
 562    <SETADR .LIB ,DIR-LERCNT>                 ;"Update statistics."
 563    <WRBUF .LIB .STATS>
 564    <REPEAT ()                                ;"Hash entrys, add pointers."
 565       <COND (<0? .ERCNT> <RETURN>)>
 566       <SET TMP <BYTE0 <NTH .RECORD <+ .DELTA 1>>>>
 567       <SET ADDR <HASH-UV <REST .RECORD <+ .DELTA 1>> .NBKTS .TMP>>
 568       <ADD-POINTER .LIB .ADDR <+ .RECADDR .DELTA> ,BKT-E>
 569       <SET ERCNT <- .ERCNT 1>>
 570       <COND (<G? <SET DELTA <+ .DELTA .TMP 1>> <LENGTH .RECORD>>
 571              <ERROR BAD-RECORD!-ERRORS "Incorrect DELTAP" .DELTA
 572                     <LENGTH .RECORD> ADD-RECORD>
 573              <RETURN %<>>)>>>
 574 \f
 575 ;"ADD-POINTER --
 576   Effect:   Points the bucket FROM at address TO with MASK bits set in
 577             bucket pointer (either BKT-P or BKT-E).
 578   Modifies: LIB
 579   Requires: FROM is address of BUCKET that was obtained from hasher, TO
 580             is the address of a package or entry record, MASK is a legal
 581             bucket mask."
 582
 583 <DEFINE ADD-POINTER (LIB:<CHANNEL 'DISK> FROM:FIX TO:FIX MASK:FIX "AUX" TMP:FIX)
 584    <SETADR .LIB .FROM>
 585    <COND (<0? <SET TMP <RDWRD .LIB>>>        ;"Empty bucket."
 586           <SETADR .LIB .FROM>
 587           <WRWRD .LIB <ORB .TO .MASK>>)
 588          (T                                  ;"Single or list."
 589           <BIND ((PAIR:<UVECTOR [REST FIX]> <STACK <IUVECTOR 2>>) ADDR:FIX)
 590              <SET ADDR <ALLOCATE .LIB 2>>    ;"Get cons cell."
 591              <COND (<TESTBIT .TMP ,BKT-M %<>>
 592                     ;"It was single item. We have to get a cons cell for
 593                       existing pointer and link FROM to the list of two
 594                       items."
 595                     <2 <1 .PAIR .TMP> <SET TMP <ALLOCATE .LIB 2>>>
 596                     <SETADR .LIB .FROM>      ;"Point to list."
 597                     <WRWRD .LIB <ORB ,BKT-M .ADDR>>
 598                     <SETADR .LIB .ADDR>      ;"Old pointer."
 599                     <WRBUF .LIB .PAIR>
 600                     <2 <1 .PAIR <ORB .TO .MASK>> 0>
 601                     <SETADR .LIB .TMP>       ;"New pointer."
 602                     <WRBUF .LIB .PAIR>)
 603                    (T                        ;"Cons onto existing list."
 604                     <SETADR .LIB .FROM>
 605                     <WRWRD .LIB <ORB ,BKT-M .ADDR>>
 606                     <2 <1 .PAIR <ORB .MASK .TO>> <ADDRESS .TMP>>
 607                     <SETADR .LIB .ADDR>
 608                     <WRBUF .LIB .PAIR>)>>)>>
 609 \f
 610 ;"REMOVE-RECORD --
 611   Effect:   Removes record named PACKAGE from LIB. Removes all pointers to
 612             record from directory, freeing the space. Gets names of files
 613             associated with record.
 614   Modifies: LIB, FILES
 615   Returns:  Vector of file names associated with record."
 616
 617 <DEFINE REMOVE-RECORD (PACKAGE:STRING LIB:<CHANNEL 'DISK>
 618                        "OPT" (FILES:VECTOR <IVECTOR 4 %<>>)
 619                        "AUX" (BUFFER:<UVECTOR [REST FIX]> <STACK <IUVECTOR ,MAXREC>>)
 620                              (PDNLEN:FIX <LENGTHW .PACKAGE>)
 621                              (STATS:<UVECTOR [REST FIX]> <STACK <IUVECTOR 2>>)
 622                              RECADDR:FIX NBKTS:FIX RINFO:FIX
 623                        "NAME" REMOVE-RECORD)
 624    <SET BUFFER <REST .BUFFER <- <LENGTH .BUFFER> .PDNLEN>>>
 625    <SETADR .LIB ,DIR-TABSIZ>                 ;"Get size of hash table."
 626    <SET NBKTS <RDWRD .LIB>>
 627    <SETADR .LIB ,DIR-LERCNT>                 ;"Get package, entry count."
 628    <RDBUF .LIB .STATS>
 629    <BIND ((COMPARE:<UVECTOR [REST FIX]> <STACK <IUVECTOR .PDNLEN>>)
 630           (BKT:FIX <HASH-SUV .PACKAGE .NBKTS .BUFFER>))
 631       <SETADR .LIB .BKT>                     ;"Look for pointer to record."
 632       <SET RECADDR <RDWRD .LIB>>
 633       <COND (<TESTBIT .RECADDR ,BKT-P>
 634              ;"Single package pointer. Move to record and compare names."
 635              <SETADR .LIB <SET RECADDR <ADDRESS .RECADDR>>>
 636              <SET RINFO <RDWRD .LIB>>        ;"Contains name length."
 637              <COND (<==? <BYTE0 .RINFO> .PDNLEN>
 638                     ;"Same length, is it the name?"
 639                     <RDBUF .LIB .COMPARE>
 640                     <COND (<N=? .COMPARE .BUFFER>
 641                            <RETURN %<> .REMOVE-RECORD>)>)
 642                    (T
 643                     <RETURN %<> .REMOVE-RECORD>)>)
 644             (<TESTBIT .RECADDR ,BKT-M>
 645              ;"List, move through list examining package records."
 646              <SETADR .LIB <ADDRESS .RECADDR>>
 647              <REPEAT ((PAIR:<UVECTOR [REST FIX]> <STACK <IUVECTOR 2>>) CDR:FIX)
 648                 <RDBUF .LIB .PAIR>
 649                 <SET RECADDR <1 .PAIR>>
 650                 <COND (<TESTBIT .RECADDR ,BKT-P>           ;"Package?"
 651                        <SETADR .LIB <SET RECADDR <ADDRESS .RECADDR>>>
 652                        <SET RINFO <RDWRD .LIB>>
 653                        <COND (<==? <BYTE0 .RINFO> .PDNLEN> ;"Same name?"
 654                               <RDBUF .LIB .COMPARE>
 655                               <COND (<=? .COMPARE .BUFFER>
 656                                      <RETURN>)>)>)>
 657                 <COND (<==? <SET CDR <2 .PAIR>> 0>         ;"Empty list?"
 658                        <RETURN %<> .REMOVE-RECORD>)
 659                       (T
 660                        <SETADR .LIB .CDR>)>>)
 661             (T
 662              <RETURN %<> .REMOVE-RECORD>)>
 663       <SET BUFFER <TOP .BUFFER>>             ;"Get the record."
 664       <SETADR .LIB .RECADDR>
 665       <RDBUF .LIB .BUFFER <LHALF .RINFO>>    ;"We got record info above."
 666       <REMOVE-POINTER .LIB .BKT .RECADDR>    ;"Flush package pointer."
 667       <FREE .LIB .RECADDR <LHALF .RINFO>>>   ;"Free the record space."
 668 \f
 669    <BIND (ERCNT:FIX FSIZES:FIX DELTA:FIX)
 670       <SET BUFFER <REST .BUFFER <+ .PDNLEN 1>>>
 671       ;"Get sizes of file names."
 672       <COND (<TESTBIT .RINFO ,RINFO-DFN?>    ;"Is there a doc file?"
 673              <SET FSIZES <1 .BUFFER>>)
 674             (T                               ;"No, mask out doc length."
 675              <SET FSIZES <ANDB *77777777* <1 .BUFFER>>>)>
 676       <SET ERCNT <RHALF <2 .BUFFER>>>        ;"Count of entries."
 677       <SET DELTA <LHALF <2 .BUFFER>>>        ;"Distance to entries."
 678       <SET BUFFER <REST .BUFFER 3>>
 679       <MAPR %<>                              ;"Get the file names."
 680             <FUNCTION (FV:VECTOR "AUX" (FSIZE:FIX <BYTE0 .FSIZES>))
 681                <SET FSIZES <LSH .FSIZES -8>>
 682                <COND (<N==? .FSIZE 0>
 683                       <1 .FV <UV2S .BUFFER .FSIZE>>
 684                       <SET BUFFER <REST .BUFFER .FSIZE>>)
 685                      (T
 686                       <1 .FV %<>>)>>
 687             .FILES>
 688       ;"Update library package, entry counts."
 689       <2 <1 .STATS <- <1 .STATS> .ERCNT>> <- <2 .STATS> 1>>
 690       <SETADR .LIB ,DIR-LERCNT>
 691       <WRBUF .LIB .STATS 2>
 692       <SET BUFFER <REST <TOP .BUFFER> .DELTA>>
 693       <REPEAT (ERLEN:FIX ADDR:FIX BKT:FIX)   ;"Remove pointers to entries."
 694          <COND (<0? .ERCNT> <RETURN .FILES>)>
 695          <SET ADDR <+ .RECADDR <- <LENGTH <TOP .BUFFER>> <LENGTH .BUFFER>>>>
 696          <SET ERLEN <BYTE0 <1 .BUFFER>>>
 697          <SET BKT <HASH-UV <REST .BUFFER> .NBKTS .ERLEN>>
 698          <REMOVE-POINTER .LIB .BKT .ADDR>
 699          <SET ERCNT <- .ERCNT 1>>
 700          <SET BUFFER <REST .BUFFER <+ .ERLEN 1>>>>>>
 701 \f
 702 ;"REMOVE-POINTER --
 703   Effect:   Deletes pointer to ADDR found in BKT. If the pointer is in cons,
 704             its storage is freed.
 705   Modifies: LIB
 706   Requires: BKT is the address of a bucket in the hash table, ADDR is present
 707             in BKT."
 708
 709 <DEFINE REMOVE-POINTER (LIB:<CHANNEL 'DISK> BKT:FIX ADDR:FIX "AUX" LAST:FIX)
 710    <SETADR .LIB .BKT>
 711    <COND (<==? <ADDRESS <SET LAST <RDWRD .LIB>>> .ADDR>
 712           <SETADR .LIB .BKT>                 ;"ADDR was only thing in bucket"
 713           <WRWRD .LIB 0>)
 714          (<TESTBIT .LAST ,BKT-M>             ;"List?"
 715           <SET LAST <ADDRESS .LAST>>         ;"Cruise the list."
 716           <REPEAT ((PAIR:<UVECTOR [REST FIX]> <STACK <UVECTOR 0 0>>) (PRED:FIX .BKT))
 717              <SETADR .LIB .LAST>             ;"Get a cons."
 718              <RDBUF .LIB .PAIR>              ;"And check its car for ADDR."
 719              <COND (<==? <ADDRESS <1 .PAIR>> .ADDR>
 720                     <FREE .LIB .LAST 2>      ;"Give away the cons."
 721                     <SET LAST <2 .PAIR>>     ;"Check out the cdr."
 722                     <COND (<==? .LAST 0>     ;"Nil?"
 723                            <SETADR .LIB .PRED>
 724                            <WRWRD .LIB 0>    ;"Predecessor gets nil."
 725                            <COND (<N==? .PRED .BKT>
 726                                   ;"If this was last in list of two items, move
 727                                     car of remaining cons to bucket."
 728                                   <SETADR .LIB .BKT>
 729                                   <SET LAST <ADDRESS <RDWRD .LIB>>>
 730                                   <COND (<==? .LAST <SET PRED <- .PRED 1>>>
 731                                          ;"Yep, bucket points to this cons."
 732                                          <SETADR .LIB .PRED>
 733                                          <SET LAST <RDWRD .LIB>>
 734                                          <FREE .LIB .PRED 2>
 735                                          <SETADR .LIB .BKT>
 736                                          <WRWRD .LIB .LAST>)>)>)
 737                           (<==? .PRED .BKT>
 738                            ;"If this was first in list of two items, move
 739                              car of remaining cons to bucket."
 740                            <SETADR .LIB .LAST>
 741                            <RDBUF .LIB .PAIR>
 742                            <SETADR .LIB .BKT>
 743                            <COND (<==? <2 .PAIR> 0>
 744                                   ;"Yep, ADDR's successor is last in list."
 745                                   <WRWRD .LIB <1 .PAIR>>
 746                                   <FREE .LIB .LAST 2>)
 747                                  (T
 748                                   <WRWRD .LIB <ORB .LAST ,BKT-M>>)>)
 749                           (T                 ;"Just splice the cons out."
 750                            <SETADR .LIB .PRED>
 751                            <WRWRD .LIB .LAST>)>
 752                     <RETURN>)
 753                    (T
 754                     <SET PRED <+ .LAST 1>>   ;"Cdr is second word."
 755                     <SETADR .LIB <SET LAST <2 .PAIR>>>)>>)
 756          (T
 757           <ERROR BAD-POINTER!-ERRORS .LAST .ADDR REMOVE-POINTER>)>>
 758 \f
 759 ;"GC-LIB --
 760   Effect:   Copies contents of LIB to NEW in bucket order, rehashing if need.
 761             NNBKTS suggests the number of buckets to use.
 762   Modifies: NEW
 763   Requires: LIB is properly formatted library as defined in LIBRARY.FORMAT"
 764
 765 <DEFINE GC-LIB (LIB:<CHANNEL 'DISK> NEW:<CHANNEL 'DISK>
 766                 "OPT" (NNBKTS:FIX ,INITIAL-BUCKETS)
 767                 "NAME" GC-LIB
 768                 "AUX" NBKTS:FIX TMP:FIX (PAIR:<UVECTOR [REST FIX]> <STACK <IUVECTOR 2>>))
 769    <SET NNBKTS <NEXT-PRIME .NNBKTS>>
 770    <SETADR .LIB ,DIR-TABSIZ>                 ;"Get table size."
 771    <SET NBKTS <RDWRD .LIB>>
 772    <SETADR .LIB ,DIR-LERCNT>                 ;"Get package, entry counts."
 773    <RDBUF .LIB .PAIR>
 774    <COND (<G? </ <FLOAT <+ <1 .PAIR> <2 .PAIR>>> <FLOAT .NBKTS>> 1.5>
 775           <SET NNBKTS                        ;"Rehash."
 776                <MAX .NNBKTS
 777                     <NEXT-PRIME <FIX <* 1.5 <FLOAT <+ <1 .PAIR> <2 .PAIR>>>>>>>>)>
 778    ;"Construct and write new directory."
 779    <BIND ((DIR:<UVECTOR [REST FIX]> <STACK <IUVECTOR <+ .NNBKTS ,DIR-HDRLEN> 0>>))
 780       ;"Initialize table size, end of file pointer for new directory."
 781       <PUT .DIR <+ ,DIR-TABSIZ 1> .NNBKTS>
 782       <PUT .DIR <+ ,DIR-EOFPTR 1> <LENGTH .DIR>>
 783       <SETADR .NEW ,DIR-TABSIZ>
 784       <OR <WRBUF .NEW .DIR> <RETURN %<> .GC-LIB>>>
 785    <SET NBKTS <+ .NBKTS ,DIR-HDRLEN>>
 786    ;"Find all the records and copy them to NEW."
 787    <REPEAT ((RECORD:<UVECTOR [REST FIX]> <STACK <IUVECTOR ,MAXREC>>) (NPKGS:FIX <2 .PAIR>)
 788             (BKT:FIX ,DIR-HDRLEN))
 789       <COND (<OR <==? .NPKGS 0> <G? .BKT .NBKTS>>
 790              <RETURN .NEW>)>
 791       <SETADR .LIB .BKT>                     ;"Get current bucket."
 792       <SET TMP <RDWRD .LIB>>
 793       <COND (<TESTBIT .TMP ,BKT-P>           ;"Package?"
 794              <SETADR .LIB <ADDRESS .TMP>>
 795              <RDBUF .LIB .RECORD 1>          ;"Record info."
 796              <RDBUF .LIB <REST .RECORD> <- <LHALF <1 .RECORD>> 1>>
 797              <OR <ADD-RECORD .RECORD .NEW> <RETURN %<> .GC-LIB>>
 798              <SET NPKGS <- .NPKGS 1>>)
 799             (<TESTBIT .TMP ,BKT-M>           ;"List?"
 800              <REPEAT ()                      ;"Cruise the list."
 801                 <SETADR .LIB <ADDRESS .TMP>>
 802                 <RDBUF .LIB .PAIR>           ;"Get cons."
 803                 <COND (<TESTBIT <1 .PAIR> ,BKT-P>       ;"Package?"
 804                        <SETADR .LIB <ADDRESS <1 .PAIR>>>
 805                        <RDBUF .LIB .RECORD 1>   ;"Record info."
 806                        <RDBUF .LIB
 807                               <REST .RECORD>
 808                               <- <LHALF <1 .RECORD>> 1>>
 809                        <OR <ADD-RECORD .RECORD .NEW> <RETURN %<> .GC-LIB>>
 810                        <SET NPKGS <- .NPKGS 1>>)>
 811                 <COND (<==? <SET TMP <2 .PAIR>> 0> <RETURN>)>>)>
 812       <SET BKT <+ .BKT 1>>>>
 813 \f
 814 ;"LUPI-RECORD-EXISTS? --
 815   Effect:   Returns T if record named NAME exists in shadow library."
 816
 817 <DEFINE LUPI-RECORD-EXISTS? (NAME:STRING
 818                       "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY)
 819                             (JUNK:<UVECTOR [REST FIX]> <STACK <IUVECTOR 2>>))
 820    <AND .K <PACKAGE-POINTER .NAME <LL-NEW .K> .JUNK>>>
 821
 822 ;"LUPI-FILE-EXISTS? --
 823   Effect:  Returns T if file named NAME is found in the library directory."
 824
 825 <DEFINE LUPI-FILE-EXISTS? (NAME:STRING "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
 826    <COND
 827     (.K
 828      <PROG ((FN:<CHANNEL 'PARSE> <CHANNEL-OPEN PARSE .NAME>)
 829             (DEV:<SPECIAL STRING> <CHANNEL-OP <LL-OLD .K>:<CHANNEL 'DISK> DEV>)
 830             (SNM:<SPECIAL STRING> <CHANNEL-OP <LL-OLD .K>:<CHANNEL 'DISK> SNM>)
 831             (NM2:<SPECIAL STRING> <CHANNEL-OP .FN NM2>))
 832         <SET NAME <CHANNEL-OP .FN NM1>>
 833         <CLOSE .FN>
 834         <RETURN <FILE-EXISTS? .NAME>>>)>>
 835
 836 ;"I2S --
 837   Effect:   Convert I to string representation.
 838   Modifies: S
 839   Returns:  S rested to the first digit.
 840   Requires: S is large enough to hold the representation of I."
 841
 842 <DEFINE I2S (I:FIX "OPT" (S:STRING <ISTRING 13>)
 843                    "AUX" (NEG:<OR ATOM FALSE> <L? .I 0>))
 844    <COND (.NEG <SET I <- .I>>)>
 845    <REPEAT ((P:FIX <LENGTH .S>) D:FIX)
 846       <SET D <MOD .I 10>>
 847       <PUT .S .P <CHTYPE <+ .D %<CHTYPE !\0 FIX>> CHARACTER>>
 848       <SET P <- .P 1>>
 849       <COND (<==? <SET I </ .I 10>> 0>
 850              <COND (.NEG
 851                     <PUT .S .P !\->
 852                     <SET P <- .P 1>>)>
 853              <RETURN <REST .S .P>>)>>>
 854
 855