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
7 LUP-BASE.MUD: EDIT HISTORY Machine Independent
9 COMPILATION: Spliced in at compile time.
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 ****************************************************************************"
17 <COND (<NOT <VALID-TYPE? LIBLOCK>> <NEWTYPE LIBLOCK VECTOR>)> ;"See L-DEFS."
19 ;"LUPI-KEY -- Is the LIBLOCK when an update is in progress."
21 <OR <GASSIGNED? LUPI-KEY> <SETG LUPI-KEY %<> '<OR FALSE LIBLOCK>>>
24 Effect: Aborts an update in progress. Deletes all temporary files
25 generated, writes message to log file, and unlocks library.
28 <DEFINE LUPI-ABORT ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY)
29 NAME:STRING CH:<CHANNEL 'DISK>)
31 <MAPF %<> ,DELFILE <LL-TMP-FILES .K>>
32 <COND (<CHANNEL-OPEN? <SET CH <LL-LOG .K>>>
33 <PRINTSTRING "*** Update aborted." .CH>
36 <COND (<CHANNEL-OPEN? <SET CH <LL-NEW .K>>>
37 <SET NAME <CHANNEL-OP .CH:DSK NAME>>
40 <SET NAME <CHANNEL-NAME .CH>>)>
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>
50 Effect: Generate a unique file name for the library directory:
51 LIBTMPnnn.TEMP if the library is locked.
55 <DEFINE LUPI-GENTEMP ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
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>>)
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>>
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.
76 Note: The default for the log file is NM1.LOG where NM1 is first name
77 of library file in library directory."
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>)
88 ;"Check to see if user already has library locked."
89 <COND (<AND <GASSIGNED? LUPI-KEY> ,LUPI-KEY>
90 <RETURN #FALSE ("LOCKED")>)>
92 ;"Soft lock under UNIX."
93 <COND (<NOT <CALL SYSCALL FLOCK <CHANNEL-OP .LIB FILE-HANDLE>
95 <RETURN #FALSE ("LOCKED")>)>)
97 ;"Thawed under TOPS20."
98 <COND (<SET NEW <CHANNEL-OPEN DISK .NAME "MODIFY" "BINARY">>
102 <RETURN #FALSE ("LOCKED")>)>)>
103 ;"Open the log file if we were not given one. Recreate if needed."
106 <SET FN <CHANNEL-OPEN PARSE .NM1>>
107 <SET NAME <CHANNEL-OP .FN NAME>>
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">>
113 <SET LOG <CHANNEL-OPEN DISK .NAME "MODIFY" "ASCII">>
114 <PRINTSTRING "*** " .LOG>
115 <PRINTSTRING <DTIME> .LOG>
116 <PRINTSTRING " Log file recreated." .LOG>
118 ;"Copy the library to temporary file."
120 <SET FN <CHANNEL-OPEN PARSE "LIBTMP0">>
121 <SET NAME <CHANNEL-OP .FN NAME>>
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>
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.
144 <DEFINE LUPI-COMMIT ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY) LOG:<CHANNEL 'DISK>)
146 <SET LOG <LL-LOG .K>>
149 <FUNCTION (NAME:STRING)
150 <PRINTSTRING " Deleting file " .LOG>
151 <PRINTSTRING .NAME .LOG>
155 ;"Rename temporary files."
157 <FUNCTION (FROM:STRING TO:STRING)
158 <PRINTSTRING " Adding file " .LOG>
159 <PRINTSTRING .TO .LOG>
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>))
169 <IFSYS ("TOPS20" <DELFILE .OLD>)>
171 <PRINTSTRING "*** Update completed." .LOG>
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.
184 <DEFINE LUPI-INSTALL ("AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY) LOG:<CHANNEL 'DISK>)
186 <SET LOG <LL-LOG .K>>
189 <FUNCTION (NAME:STRING)
190 <PRINTSTRING " Deleting file " .LOG>
191 <PRINTSTRING .NAME .LOG>
195 ;"Rename temporary files."
197 <FUNCTION (FROM:STRING TO:STRING)
198 <PRINTSTRING " Adding file " .LOG>
199 <PRINTSTRING .TO .LOG>
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>)
210 <IFSYS ("TOPS20" <DELFILE .OLD>)>
212 <PRINTSTRING "*** Installed." .LOG>
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>>)
219 <AND .CH <CLOSE .CH>>
224 Effect: Create a library named NAME with default second name LIBMIM.
225 Creates associated log file.
226 Returns: Full library name."
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>>
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>>
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>))
252 <SET FN <CHANNEL-OPEN PARSE <CHANNEL-OP .LIB NM1>>>
253 <SET NAME <CHANNEL-OP .FN NAME>>
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>>
262 <PRINTSTRING "*** " .LOG>
263 <PRINTSTRING <DTIME> .LOG>
264 <PRINTSTRING " Library created" .LOG>
269 <ERROR CANT-OPEN-LIBRARY-FILE!-ERRORS .NAME .LIB LUPI-CREATE>
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.
279 <DEFINE LUPI-ADD-PACK (RECORD:<UVECTOR [REST FIX]> ADD:LIST TMP:LIST
280 "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
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>)
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>>>>
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.
308 <DEFINE LUPI-ADD-FILE (TMP:STRING ADD:STRING
309 "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
311 <LL-TMP-FILES .K (.TMP !<LL-TMP-FILES .K>)>
312 <LL-ADD-FILES .K (.ADD !<LL-ADD-FILES .K>)>
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
321 <DEFINE LUPI-DEL-FILE (DEL:STRING "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
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>>
330 <CHANNEL-OPEN PARSE .DEL>
331 <SET DEL <CHANNEL-OP .FN NAME>>
333 <LL-DEL-FILES .K (.DEL !<LL-DEL-FILES .K>)>
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.
342 <DEFINE LUPI-DEL-PACK (PACKAGE:STRING "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
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>)
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)."
361 <FUNCTION (NAME:<OR STRING FALSE>)
363 <SET FN <CHANNEL-OPEN PARSE .NAME>>
364 <COND (<AND <=? <CHANNEL-OP .FN DEV>:STRING .DEV>
365 <=? <CHANNEL-OP .FN SNM>:STRING .SNM>>
367 (<CHANNEL-OP .FN NAME ,NO-GENERATION> !.LLDEL)>)>
370 <LL-DEL-FILES .K .LLDEL>
371 <PRINTSTRING " Removing record " .LOG>
372 <PRINTSTRING .PACKAGE .LOG>
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.
383 <DEFINE LUPI-GC ("OPT" (NBKTS:FIX ,INITIAL-BUCKETS)
384 "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
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>>
396 <PRINTSTRING "*** Library GC" .LOG>
404 ;"NPRIME? -- Returns T iff N is not prime."
406 <DEFINE NPRIME? (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>)>
413 ;"NEXT-PRIME -- Returns next prime larger than X."
415 <DEFINE NEXT-PRIME (X:FIX)
416 <REPEAT () <COND (<NOT <NPRIME? <SET X <+ .X 1>>>> <RETURN .X>)>>>
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
423 Returns: Address of allocated storage block."
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."
446 ;"If end of list or exact, we can do no better."
447 <COND (<OR <0? .SUCC> <==? .BSIZE .AMT>>
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>>)
458 <SETADR .LIB .BPRED> ;"Got a block from list."
459 <COND (<==? .BSIZE .AMT> ;"Exact, just splice out."
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>
473 Effect: Deallocate AMT storage beginning at address START. The block
474 is spliced into the FREE list in storage order.
477 <DEFINE FREE (LIB:<CHANNEL 'DISK> START:FIX AMT:FIX
478 "AUX" (END:FIX <+ .START .AMT>) (PAIR <STACK <UVECTOR .AMT 0>>)
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>
486 (T ;"Find where block belongs."
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."
504 ;"SUCC is adjacent to end of block, compact."
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>>>
514 ;"Block belongs before SUCC, mung SUCC's predecessor and
515 point block at SUCC."
517 <WRBUF .LIB <1 <2 .PAIR .SUCC> .AMT>>
522 ;"Block belongs after SUCC, point SUCC at block."
523 <SETADR .LIB <+ .SUCC 1>>
526 <WRBUF .LIB <1 <2 .PAIR 0> .AMT>>
529 <SET PRED <+ .SUCC 1>>
530 <SET SUCC <2 .PAIR>>)>>)>
534 Effect: Adds RECORD to LIB. The directory is pointed at RECORD and all of its
537 Requires: RECORD is a properly formatted library record as defined in
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
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>
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."
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."
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>
576 Effect: Points the bucket FROM at address TO with MASK bits set in
577 bucket pointer (either BKT-P or BKT-E).
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
583 <DEFINE ADD-POINTER (LIB:<CHANNEL 'DISK> FROM:FIX TO:FIX MASK:FIX "AUX" TMP:FIX)
585 <COND (<0? <SET TMP <RDWRD .LIB>>> ;"Empty bucket."
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
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."
600 <2 <1 .PAIR <ORB .TO .MASK>> 0>
601 <SETADR .LIB .TMP> ;"New pointer."
603 (T ;"Cons onto existing list."
605 <WRWRD .LIB <ORB ,BKT-M .ADDR>>
606 <2 <1 .PAIR <ORB .MASK .TO>> <ADDRESS .TMP>>
608 <WRBUF .LIB .PAIR>)>>)>>
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.
615 Returns: Vector of file names associated with record."
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."
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>)>)
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)
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>
657 <COND (<==? <SET CDR <2 .PAIR>> 0> ;"Empty list?"
658 <RETURN %<> .REMOVE-RECORD>)
660 <SETADR .LIB .CDR>)>>)
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."
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>>)
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>>>>>>
703 Effect: Deletes pointer to ADDR found in BKT. If the pointer is in cons,
704 its storage is freed.
706 Requires: BKT is the address of a bucket in the hash table, ADDR is present
709 <DEFINE REMOVE-POINTER (LIB:<CHANNEL 'DISK> BKT:FIX ADDR:FIX "AUX" LAST:FIX)
711 <COND (<==? <ADDRESS <SET LAST <RDWRD .LIB>>> .ADDR>
712 <SETADR .LIB .BKT> ;"ADDR was only thing in bucket"
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?"
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."
729 <SET LAST <ADDRESS <RDWRD .LIB>>>
730 <COND (<==? .LAST <SET PRED <- .PRED 1>>>
731 ;"Yep, bucket points to this cons."
733 <SET LAST <RDWRD .LIB>>
736 <WRWRD .LIB .LAST>)>)>)
738 ;"If this was first in list of two items, move
739 car of remaining cons to bucket."
743 <COND (<==? <2 .PAIR> 0>
744 ;"Yep, ADDR's successor is last in list."
745 <WRWRD .LIB <1 .PAIR>>
748 <WRWRD .LIB <ORB .LAST ,BKT-M>>)>)
749 (T ;"Just splice the cons out."
754 <SET PRED <+ .LAST 1>> ;"Cdr is second word."
755 <SETADR .LIB <SET LAST <2 .PAIR>>>)>>)
757 <ERROR BAD-POINTER!-ERRORS .LAST .ADDR REMOVE-POINTER>)>>
760 Effect: Copies contents of LIB to NEW in bucket order, rehashing if need.
761 NNBKTS suggests the number of buckets to use.
763 Requires: LIB is properly formatted library as defined in LIBRARY.FORMAT"
765 <DEFINE GC-LIB (LIB:<CHANNEL 'DISK> NEW:<CHANNEL 'DISK>
766 "OPT" (NNBKTS:FIX ,INITIAL-BUCKETS)
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."
774 <COND (<G? </ <FLOAT <+ <1 .PAIR> <2 .PAIR>>> <FLOAT .NBKTS>> 1.5>
775 <SET NNBKTS ;"Rehash."
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>>
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."
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>>>>
814 ;"LUPI-RECORD-EXISTS? --
815 Effect: Returns T if record named NAME exists in shadow library."
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>>>
822 ;"LUPI-FILE-EXISTS? --
823 Effect: Returns T if file named NAME is found in the library directory."
825 <DEFINE LUPI-FILE-EXISTS? (NAME:STRING "AUX" (K:<OR FALSE LIBLOCK> ,LUPI-KEY))
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>>
834 <RETURN <FILE-EXISTS? .NAME>>>)>>
837 Effect: Convert I to string representation.
839 Returns: S rested to the first digit.
840 Requires: S is large enough to hold the representation of I."
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)
847 <PUT .S .P <CHTYPE <+ .D %<CHTYPE !\0 FIX>> CHARACTER>>
849 <COND (<==? <SET I </ .I 10>> 0>
853 <RETURN <REST .S .P>>)>>>