db.l (60473B)
1 # 23feb13abu 2 # (c) Software Lab. Alexander Burger 3 4 # 6 bytes in little endian format 5 # Get block address from buffer 6 (code 'getAdrZ_A 0) 7 ld B (Z 5) # Highest byte 8 zxt 9 shl A 8 10 ld B (Z 4) 11 shl A 8 12 ld B (Z 3) 13 shl A 8 14 ld B (Z 2) 15 shl A 8 16 ld B (Z 1) 17 shl A 8 18 ld B (Z) # Lowest byte 19 ret 20 21 # Set block address in buffer 22 (code 'setAdrAZ 0) 23 ld (Z) B # Lowest byte 24 shr A 8 25 ld (Z 1) B 26 shr A 8 27 ld (Z 2) B 28 shr A 8 29 ld (Z 3) B 30 shr A 8 31 ld (Z 4) B 32 shr A 8 33 ld (Z 5) B # Highest byte 34 ret 35 36 (code 'setAdrAS 0) 37 ld (S (+ I 2)) B # Write block address to stack 38 shr A 8 39 ld (S (+ I 3)) B 40 shr A 8 41 ld (S (+ I 4)) B 42 shr A 8 43 ld (S (+ I 5)) B 44 shr A 8 45 ld (S (+ I 6)) B 46 shr A 8 47 ld (S (+ I 7)) B # Highest byte 48 ret 49 50 # Read file number from 'Buf' into 'DbFile' 51 (code 'dbfBuf_AF 0) 52 ld B (Buf 1) # Two bytes little endian 53 zxt 54 shl A 8 55 ld B (Buf) 56 shl A 6 # 'dbFile' index 57 cmp A (DBs) # Local file? 58 jge retc # No 59 add A (DbFiles) # Get DB file 60 ld (DbFile) A # Set current 61 ret # 'nc' 62 63 # Build external symbol name 64 (code 'extNmCE_X 0) 65 ld X C # Get object ID into X 66 and X (hex "FFFFF") # Lowest 20 bits 67 shr C 20 # Middle part of object ID 68 ld A C 69 and A (hex "FFF") # Lowest 12 bits 70 shl A 28 71 or X A # into X 72 shr C 12 # Rest of object ID 73 shl C 48 74 or X C # into X 75 ld A E # Get file number 76 and A (hex "FF") # Lowest 8 bits 77 shl A 20 # Insert 78 or X A # into X 79 shr E 8 # Rest of file number 80 shl E 40 81 or X E # into X 82 shl X 4 # Make short name 83 or X CNT 84 ret 85 86 # Pack external symbol name 87 (code 'packExtNmX_E) 88 link 89 push ZERO # <L I> Name 90 link 91 call fileObjX_AC # Get file and object ID 92 push C # Save object ID 93 ld C 4 # Build name 94 lea X (L I) 95 null A # Any? 96 if nz # Yes 97 call packAoACX_CX # Pack file number 98 end 99 pop A # Get object ID 100 call packOctACX_CX # Pack it 101 call cons_E # Cons symbol 102 ld (E) (L I) # Set name 103 or E SYM # Make symbol 104 ld (E) E # Set value to itself 105 drop 106 ret 107 108 (code 'packAoACX_CX 0) 109 cmp A 15 # Single digit? 110 if gt # No 111 push A # Save 112 shr A 4 # Divide by 16 113 call packAoACX_CX # Recurse 114 pop A 115 and B 15 # Get remainder 116 end 117 add B (char "@") # Make ASCII letter 118 jmp byteSymBCX_CX # Pack byte 119 120 (code 'packOctACX_CX 0) 121 cmp A 7 # Single digit? 122 if gt # No 123 push A # Save 124 shr A 3 # Divide by 8 125 call packOctACX_CX # Recurse 126 pop A 127 and B 7 # Get remainder 128 end 129 add B (char "0") # Make ASCII digit 130 jmp byteSymBCX_CX # Pack byte 131 132 # Chop external symbol name 133 (code 'chopExtNmX_E) 134 call fileObjX_AC # Get file and object ID 135 ld X A # Keep file in X 136 call oct3C_CA # Get lowest octal digits 137 call consA_E # Final cell 138 ld (E) A 139 ld (E CDR) Nil 140 link 141 push E # <L I> Result 142 link 143 do 144 shr C 3 # Higher octal digits? 145 while nz # Yes 146 call oct3C_CA # Get next three digits 147 call consA_E # Cons into result 148 ld (E) A 149 ld (E CDR) (L I) 150 ld (L I) E 151 loop 152 null X # File number? 153 if nz # Yes 154 ld E 0 # Build A-O encoding 155 ld A 0 156 do 157 ld B X # Next hax digit 158 and B 15 # Lowest four bits 159 add B (char "@") # Make ASCII letter 160 or E B 161 shr X 4 # More hax digits? 162 while nz # Yes 163 shl E 8 # Shift result 164 loop 165 shl E 4 # Make short name 166 or E CNT 167 call cons_A # Make transient symbol 168 ld (A) E # Set name 169 or A SYM # Make symbol 170 ld (A) A # Set value to itself 171 call consA_E # Cons into result 172 ld (E) A 173 ld (E CDR) (L I) 174 ld (L I) E 175 end 176 ld E (L I) # Get result 177 drop 178 ret 179 180 (code 'oct3C_CA 0) 181 ld A 0 182 ld B C # Lowest octal digit 183 and B 7 184 add B (char "0") # Make ASCII digit 185 ld E A 186 shr C 3 # Next digit? 187 if nz # Yes 188 ld B C # Second octal digit 189 and B 7 190 add B (char "0") # Make ASCII digit 191 shl E 8 192 or E B 193 shr C 3 # Next digit? 194 if nz # Yes 195 ld B C # Hightest octal digit 196 and B 7 197 add B (char "0") # Make ASCII digit 198 shl E 8 199 or E B 200 end 201 end 202 shl E 4 # Make short name 203 or E CNT 204 call cons_A # Make transient symbol 205 ld (A) E # Set name 206 or A SYM # Make symbol 207 ld (A) A # Set value to itself 208 ret 209 210 # Get file and object ID from external symbol name 211 (code 'fileObjX_AC 0) 212 shl X 2 # Strip status bits 213 shr X 6 # Normalize 214 ld C X # Get object ID 215 and C (hex "FFFFF") # Lowest 20 bits 216 shr X 20 # Get file number 217 ld A X 218 and A (hex "FF") # Lowest 8 bits 219 shr X 8 # More? 220 if nz # Yes 221 ld E X # Rest in E 222 and E (hex "FFF") # Middle 12 bits of object ID 223 shl E 20 224 or C E # into C 225 shr X 12 # High 8 bits of file number 226 ld E X # into E 227 and E (hex "FF") # Lowest 8 bits 228 shl E 8 229 or A E # into A 230 shr X 8 # Rest of object ID 231 shl X 32 232 or C X # into C 233 end 234 ret 235 236 # Get file and object ID from external symbol 237 (code 'fileObjE_AC 0) 238 push X 239 ld X (E TAIL) 240 call nameX_X # Get name 241 call fileObjX_AC 242 pop X 243 ret 244 245 # Get dbFile index and block index from external symbol 246 (code 'dbFileBlkY_AC 0) 247 push X 248 ld X Y # Name in X 249 call fileObjX_AC 250 shl A 6 # 'dbFile' index 251 shl C 6 # Block index 252 pop X 253 ret 254 255 (code 'rdLockDb) 256 cmp (Solo) TSym # Already locked whole DB? 257 jeq ret # Yes 258 ld A (| F_RDLCK (hex "10000")) # Read lock, length 1 259 ld C ((DbFiles)) # Descriptor of first file 260 jmp lockFileAC 261 262 (code 'wrLockDb) 263 cmp (Solo) TSym # Already locked whole DB? 264 jeq ret # Yes 265 ld A (| F_WRLCK (hex "10000")) # Write lock, length 1 266 ld C ((DbFiles)) # Descriptor of first file 267 jmp lockFileAC 268 269 (code 'rwUnlockDbA) 270 cmp (Solo) TSym # Already locked whole DB? 271 jeq ret # Yes 272 null A # Length zero? 273 if z # Yes 274 push X 275 push Y 276 ld X (DbFiles) # Iterate DB files 277 ld Y (DBs) # Count 278 do 279 sub Y VIII # Done? 280 while ne # No 281 add X VIII # Skip first, increment by sizeof(dbFile) 282 nul (X (+ IV 0)) # This one locked? 283 if nz # Yes 284 ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 285 ld C (X) # File descriptor 286 call unLockFileAC 287 set (X (+ IV 0)) 0 # Clear lock entry 288 end 289 loop 290 pop Y 291 pop X 292 ld (Solo) ZERO # Reset solo mode 293 ld A 0 # Length zero again 294 end 295 or A F_UNLCK 296 ld C ((DbFiles)) # Unlock first file 297 jmp unLockFileAC 298 299 (code 'tryLockCE_FA) 300 do 301 ld A F_WRLCK # Write lock 302 st2 (Flock L_TYPE) # 'l_type' 303 ld (Flock L_START) C # Start position ('l_whence' is SEEK_SET) 304 ld (Flock L_LEN) E # Length 305 cc fcntl(((DbFile)) F_SETLK Flock) # Try to lock 306 nul4 # OK? 307 if ns # Yes 308 set ((DbFile) (+ IV 0)) 1 # Set lock flag 309 null C # 'Start position is zero? 310 if z # Yes 311 ld (Solo) TSym # Set solo mode 312 else 313 cmp (Solo) TSym # Already locked whole DB? 314 if ne # No 315 ld (Solo) Nil # Clear solo mode 316 setz 317 end 318 end 319 ret # 'z' 320 end 321 call errno_A 322 cmp A EINTR # Interrupted? 323 if ne # No 324 cmp A EACCES # Locked by another process? 325 if ne # No 326 cmp A EAGAIN # Memory-mapped by another process? 327 jne lockErr # No 328 end 329 end 330 do 331 cc fcntl(((DbFile)) F_GETLK Flock) # Try to get lock 332 nul4 # OK? 333 while s # No 334 call errno_A 335 cmp A EINTR # Interrupted? 336 jne lockErr # No 337 loop 338 ld2 (Flock L_TYPE) # Get 'l_type' 339 cmp B F_UNLCK # Locked by another process? 340 until ne # Yes 341 ld4 (Flock L_PID) # Return PID 342 ret # 'nz' 343 344 (code 'jnlFileno_A) 345 cc fileno((DbJnl)) # Get fd 346 ret 347 348 (code 'logFileno_A) 349 cc fileno((DbLog)) # Get fd 350 ret 351 352 (code 'lockJnl) 353 call jnlFileno_A # Get fd 354 ld C A # into C 355 jmp wrLockFileC # Write lock journal 356 357 (code 'unLockJnl) 358 cc fflush((DbJnl)) # Flush journal 359 call jnlFileno_A # Get fd 360 ld C A # into C 361 ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 362 jmp unLockFileAC # Unlock journal 363 364 (code 'setBlockAC_Z 0) 365 add A (DbFiles) # Get DB file 366 : setBlkAC_Z 367 ld (DbFile) A # Set current 368 ld (BlkIndex) C # Set block index 369 ld A (A III) # Block size 370 ld Z (DbBlock) # Get block buffer in Z 371 add A Z # Caclulate data end 372 ld (BufEnd) A 373 ret 374 375 (code 'rdBlockLinkZ_Z) 376 ld A (BlkLink) # Next block 377 (code 'rdBlockIndexAZ_Z) 378 ld (BlkIndex) A # Set block index 379 ld Z (DbBlock) # Block buffer in Z 380 (code 'rdBlockZ_Z) 381 ld A (DbFile) # Get current file 382 ld C (A III) # Block size 383 ld E (BlkIndex) # Get block index in E 384 shl E (A II) # Shift for current file 385 call blkPeekCEZ # Read block 386 call getAdrZ_A # Get link address 387 off A BLKTAG 388 ld (BlkLink) A # Store as next block 389 add Z BLK # Point to block data 390 ret 391 392 (code 'blkPeekCEZ) 393 cc pread(((DbFile)) Z C E) # Read C bytes from pos E into buffer Z 394 cmp A C # OK? 395 jne dbRdErr # No 396 ret 397 398 (code 'wrBlockZ) 399 ld A (DbFile) # Get current file 400 ld C (A III) # Block size 401 ld E (BlkIndex) # Get block index in E 402 shl E (A II) # Shift for current file 403 (code 'blkPokeCEZ) 404 cc pwrite(((DbFile)) Z C E) # Write C bytes from buffer Z to pos E 405 cmp A C # OK? 406 jne dbWrErr # No 407 null (DbJnl) # Journal? 408 if nz # Yes 409 cmp A ((DbFile) III) # Size (in A and C) equal to current file's block size? 410 if eq # Yes 411 ld A BLKSIZE # Use block unit size instead 412 end 413 cc putc_unlocked(A (DbJnl)) # Write size 414 sub S (+ BLK 2) # <S> Buffer 415 ld A ((DbFile) I) # Get file number 416 ld (S) B # Store low byte 417 shr A 8 418 ld (S 1) B # and high byte 419 ld A E # Get position 420 shr A ((DbFile) II) # Un-shift for current file 421 call setAdrAS # Set block address in buffer 422 cc fwrite(S (+ BLK 2) 1 (DbJnl)) # Write file number and address 423 cmp A 1 # OK? 424 jne wrJnlErr # No 425 cc fwrite(Z C 1 (DbJnl)) # Write C bytes from buffer Z 426 cmp A 1 # OK? 427 jne wrJnlErr # No 428 add S (+ BLK 2) # Drop buffer 429 end 430 ret 431 432 (code 'logBlock) 433 sub S (+ BLK 2) # <S> Buffer 434 ld A ((DbFile) I) # Get file number 435 ld (S) B # Store low byte 436 shr A 8 437 ld (S 1) B # and high byte 438 ld A (BlkIndex) # Get block index in E 439 call setAdrAS # Write into buffer 440 cc fwrite(S (+ BLK 2) 1 (DbLog)) # Write file number and address 441 cmp A 1 # OK? 442 jne wrLogErr # No 443 cc fwrite((DbBlock) ((DbFile) III) 1 (DbLog)) # Write 'siz' bytes from block buffer 444 cmp A 1 # OK? 445 jne wrLogErr # No 446 add S (+ BLK 2) # Drop buffer 447 ret 448 449 (code 'newBlock_X) 450 push Z 451 ld C (* 2 BLK) # Read 'free' and 'next' 452 ld E 0 # from block zero 453 ld Z Buf # into 'Buf' 454 call blkPeekCEZ 455 call getAdrZ_A # 'free'? 456 null A 457 jz 10 # No 458 null ((DbFile) VII) # 'fluse'? 459 if nz # Yes 460 ld X A # Keep 'free' in X 461 ld C (DbFile) 462 shl A (C II) # Shift 'free' 463 dec (C VII) # Decrement 'fluse' 464 ld E A # Read 'free' link 465 ld C BLK 466 call blkPeekCEZ # into 'Buf' 467 ld E 0 # Restore block zero in E 468 ld C (* 2 BLK) # and poke size in C 469 else 470 10 add Z BLK # Get 'next' 471 call getAdrZ_A 472 cmp A (hex "FFFFFFFFFFC0") # Max object ID 473 jeq dbSizErr # DB Oversize 474 ld X A # Keep in X 475 add A BLKSIZE # Increment 'next' 476 call setAdrAZ 477 sub Z BLK # Restore 'Buf' in Z 478 end 479 call blkPokeCEZ # Write 'Buf' back 480 ld C ((DbFile) III) # Current file's block size 481 sub S C # <S> Buffer 482 ld B 0 # Clear buffer 483 mset (S) C # with block size 484 ld E X # Get new block address 485 shl E ((DbFile) II) # Shift it 486 ld Z S # Write initblock 487 call blkPokeCEZ 488 add S ((DbFile) III) # Drop buffer 489 pop Z 490 ret 491 492 (code 'newIdEX_X) 493 dec E # Zero-based 494 shl E 6 # 'dbFile' index 495 cmp E (DBs) # In Range? 496 jge dbfErrX # No 497 add E (DbFiles) # Get DB file 498 ld (DbFile) E # Set current 499 null (DbLog) # Transaction log? 500 if z # No 501 inc (EnvProtect) # Protect the operation 502 end 503 call wrLockDb # Write lock DB 504 null (DbJnl) # Journal? 505 if nz # Yes 506 call lockJnl # Write lock journal 507 end 508 call newBlock_X # Allocate new block 509 ld C X # Object ID 510 shr C 6 # Normalize 511 ld E ((DbFile) I) # Get file number 512 call extNmCE_X # Build external symbol name 513 null (DbJnl) # Journal? 514 if nz # Yes 515 call unLockJnl # Unlock journal 516 end 517 ld A (hex "10000") # Length 1 518 call rwUnlockDbA # Unlock 519 null (DbLog) # Transaction log? 520 if z # No 521 dec (EnvProtect) # Unprotect 522 end 523 ret 524 525 (code 'isLifeE_F) 526 push E # Save symbol 527 call fileObjE_AC # Get file and ID 528 pop E # Restore symbol 529 shl C 6 # Block index? 530 jz retnz # No 531 shl A 6 # 'dbFile' index 532 cmp A (DBs) # Local file? 533 if lt # Yes 534 add A (DbFiles) # Get DB file 535 ld (DbFile) A # Set current 536 ld A (E TAIL) # Get tail 537 call nameA_A # Get name 538 shl A 1 # Dirty? 539 jc retz # Yes 540 shl A 1 # Loaded? 541 jc Retz # Yes 542 push E 543 push Z 544 push C # Save block index 545 ld C BLK # Read 'next' 546 ld E BLK 547 ld Z Buf # into 'Buf' 548 call blkPeekCEZ 549 call getAdrZ_A # Get 'next' 550 pop C # Get block index 551 cmp C A # Less than 'next'? 552 if ge # No 553 clrz # 'nz' 554 jmp 90 555 end 556 ld E C # Block index 557 shl E ((DbFile) II) # Shift 558 ld C BLK # Read link field 559 call blkPeekCEZ # into 'Buf' 560 ld B (Z) # Get tag byte 561 and B BLKTAG # Block tag 562 cmp B 1 # One? 563 90 pop Z 564 pop E 565 else 566 atom (Ext) # Extended databases? 567 end 568 ret # 'z' if OK 569 570 (code 'cleanUpY) 571 ld C BLK # Read 'free' 572 ld E 0 # from block zero 573 ld Z Buf # into 'Buf' 574 call blkPeekCEZ 575 call getAdrZ_A # Get 'free' 576 push A # Save 'free' 577 ld A Y # Deleted block 578 call setAdrAZ # Store in buffer 579 call blkPokeCEZ # Set new 'free' 580 ld E Y # Deleted block 581 do 582 shl E ((DbFile) II) # Shift it 583 call blkPeekCEZ # Get block link 584 off (Z) BLKTAG # Clear tag 585 call getAdrZ_A # Get link 586 null A # Any? 587 while nz # Yes 588 ld Y A # Keep link in Y 589 call blkPokeCEZ # Write link 590 ld E Y # Get link 591 loop 592 pop A # Retrieve 'free' 593 call setAdrAZ # Store in buffer 594 jmp blkPokeCEZ # Append old 'free' list 595 596 (code 'getBlockZ_FB 0) 597 cmp Z (BufEnd) # End of block data? 598 if eq # Yes 599 ld A (BlkLink) # Next block? 600 null A 601 jz ret # No: Return 0 602 push C 603 push E 604 call rdBlockIndexAZ_Z # Read block 605 pop E 606 pop C 607 end 608 ld B (Z) # Next byte 609 add Z 1 # (nc) 610 ret 611 612 (code 'putBlockBZ 0) 613 cmp Z (BufEnd) # End of block data? 614 if eq # Yes 615 push A # Save byte 616 push C 617 push E 618 ld Z (DbBlock) # Block buffer 619 null (BlkLink) # Next block? 620 if nz # Yes 621 call wrBlockZ # Write current block 622 call rdBlockLinkZ_Z # Read next block 623 else 624 push X 625 call newBlock_X # Allocate new block 626 ld B (Z) # Get block count (link is zero) 627 zxt 628 push A # Save count 629 or A X # Combine with new link 630 call setAdrAZ # Store in current block 631 call wrBlockZ # Write current block 632 ld (BlkIndex) X # Set new block index 633 pop A # Retrieve count 634 cmp A BLKTAG # Max reached? 635 if ne # No 636 inc A # Increment count 637 end 638 call setAdrAZ # Store in new current block 639 add Z BLK # Point to block data 640 pop X 641 end 642 pop E 643 pop C 644 pop A # Retrieve byte 645 end 646 ld (Z) B # Store byte 647 inc Z # Increment pointer 648 ret 649 650 # (pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T 651 (code 'doPool 2) 652 push X 653 push Y 654 push Z 655 ld X E 656 ld Y (E CDR) # Y on args 657 call evSymY_E # Eval database name 658 link 659 push E # <L IV> 'sym1' 660 ld Y (Y CDR) 661 ld E (Y) # Eval scale factor list 662 eval+ 663 push E # <L III> 'lst' 664 link 665 cmp E Nil # Need list 666 if ne 667 atom E 668 jnz lstErrEX 669 end 670 ld Y (Y CDR) 671 call evSymY_E # Eval replication journal 672 tuck E # <L II> 'sym2' 673 link 674 ld Y (Y CDR) 675 call evSymY_E # Eval transaction log 676 tuck E # <L I> 'sym3' 677 link 678 ld (Solo) ZERO # Reset solo mode 679 null (DBs) # DB open? 680 if nz # Yes 681 call doRollback # Roll back possible changes 682 ld E (DbFiles) # Iterate DB files 683 ld C (DBs) # Count 684 do 685 ld A (E) # File descriptor 686 call closeAX # Close it 687 cc free((E VI)) # Free mark bit vector 688 add E VIII # Increment by sizeof(dbFile) 689 sub C VIII # Done? 690 until z # Yes 691 ld (DBs) 0 692 null (DbJnl) # Journal? 693 if nz # Yes 694 cc fclose((DbJnl)) # Close it 695 ld (DbJnl) 0 696 end 697 null (DbLog) # Transaction log? 698 if nz # Yes 699 cc fclose((DbLog)) # Close it 700 ld (DbLog) 0 701 end 702 end 703 ld E (L IV) # Database name 704 cmp E Nil # Given? 705 if ne # Yes 706 push A # 8 bytes additional buffer space 707 call pathStringE_SZ # <S II> DB name 708 slen C S # String length in C 709 add C S # Add to buffer 710 push C # <S I> DB name end pointer 711 ld E VIII # Default to single dbFile 712 ld A (L III) # Get scale factor list 713 atom A # Any? 714 if z # Yes 715 ld E 0 # Calculate length 716 do 717 add E VIII # Increment by sizeof(dbFile) 718 ld A (A CDR) 719 atom A # More cells? 720 until nz # No 721 end 722 ld A (DbFiles) # DB file structure array 723 call allocAE_A # Set to new size 724 ld (DbFiles) A 725 ld Y A # Index in Y 726 add A E 727 push A # <S> Limit 728 ld (MaxBlkSize) 0 # Init block size maximum 729 do 730 ld C (S I) # Get DB name end pointer 731 ld A Y # Get index 732 sub A (DbFiles) 733 shr A 6 # Revert to file number 734 ld (Y I) A # Store in 'dbFile' 735 atom (L III) # Scale factor list? 736 if z # Yes 737 call bufAoAC_C # Append AO encoding to DB base name 738 end 739 set (C) 0 # Null-byte string terminator 740 ld A (L III) # Scale factor list 741 ld (L III) (A CDR) 742 ld A (A) # Next scale factor 743 cnt A # Given? 744 ldz A 2 # No: Default to 2 745 if nz 746 shr A 4 # Else normalize 747 end 748 ld (Y II) A # Set block shift 749 ld (DbFile) Y # Set current file 750 cc open(&(S II) O_RDWR) # Try to open 751 nul4 # OK? 752 if ns # Yes 753 ld (Y) A # Set file descriptor 754 ld C (+ BLK BLK 1) # Read block shift 755 ld E 0 # from block zero 756 ld Z Buf # into 'Buf' 757 call blkPeekCEZ 758 ld B (Z (+ BLK BLK)) # Get block shift 759 ld (Y II) B # Override argument block shift 760 ld C BLKSIZE # Calculate block size 761 shl C B 762 ld (Y III) C # Set in dbFile 763 else 764 ld E (L IV) # Database name (if error) 765 call errno_A 766 cmp A ENOENT # Non-existing? 767 jne openErrEX # No 768 cc open(&(S II) (| O_CREAT O_EXCL O_RDWR) (oct "0666")) # Try to create 769 nul4 # OK? 770 js openErrEX # No 771 ld (Y) A # Set file descriptor 772 ld C BLKSIZE # Calculate block size 773 shl C (Y II) 774 ld (Y III) C # Set in dbFile 775 sub S C # <S> Buffer 776 ld B 0 # Clear buffer 777 mset (S) C # with block size 778 ld E 0 # Position of DB block zero 779 lea Z (S BLK) # Address of 'next' in buffer 780 cmp Y (DbFiles) # First file? 781 if ne # No 782 ld A BLKSIZE # Only block zero 783 else 784 ld A (* 2 BLKSIZE) # Block zero plus DB root 785 end 786 call setAdrAZ # into 'next' 787 ld Z S # Buffer address 788 set (Z (* 2 BLK)) (Y II) # Set block shift in block zero 789 call blkPokeCEZ # Write DB block zero 790 cmp Y (DbFiles) # First file? 791 if eq # Yes 792 ld (S) 0 # Clear 'next' link in buffer 793 ld (S I) 0 794 ld Z S # Address of 'link' in buffer 795 ld A 1 # First block for DB root 796 call setAdrAZ # into link field 797 ld E (Y III) # Second block has block size position 798 call blkPokeCEZ # Write first ID-block (DB root block) 799 end 800 add S (Y III) # Drop buffer 801 end 802 ld A (Y) # Get fd 803 call closeOnExecAX 804 ld A (Y III) # Block size 805 cmp A (MaxBlkSize) # Calculate maximum 806 if gt 807 ld (MaxBlkSize) A 808 end 809 ld (Y IV) 0 # Clear 'flgs' 810 ld (Y V) 0 # mark vector size 811 ld (Y VI) 0 # and mark bit vector 812 ld (Y VII) -1 # Init 'fluse' 813 add Y VIII # Increment index by sizeof(dbFile) 814 ld A Y # Get index 815 sub A (DbFiles) # Advanced so far 816 ld (DBs) A # Set new scaled DB file count 817 cmp Y (S) # Done? 818 until eq # Yes 819 ld A (DbBlock) # Allocate block buffer 820 ld E (MaxBlkSize) # for maximal block size 821 call allocAE_A 822 ld (DbBlock) A 823 ld E (L II) # Replication journal? 824 cmp E Nil 825 if ne # Yes 826 call pathStringE_SZ # Write journal to stack buffer 827 cc fopen(S _a_) # Open for appending 828 ld S Z # Drop buffer 829 null A # OK? 830 jz openErrEX # No 831 ld (DbJnl) A 832 call jnlFileno_A # Get fd 833 call closeOnExecAX 834 end 835 ld E (L I) # Transaction log? 836 cmp E Nil 837 if ne # Yes 838 call pathStringE_SZ # Write journal to stack buffer 839 cc fopen(S _ap_) # Open for reading and appending 840 ld S Z # Drop buffer 841 null A # OK? 842 jz openErrEX # No 843 ld (DbLog) A 844 call logFileno_A # Get fd 845 call closeOnExecAX 846 call rewindLog # Test for existing transaction 847 cc fread(Buf 2 1 (DbLog)) # Read first file number 848 null A # Any? 849 if nz # Yes 850 cc feof((DbLog)) # EOF? 851 nul4 852 if z # No 853 call ignLog # Discard incomplete transaction 854 else 855 do 856 ld2 (Buf) # Get file number (byte order doesn't matter) 857 cmp A (hex "FFFF") # End marker? 858 if eq # Yes 859 cc fprintf((stderr) RolbLog) # Rollback incomplete transaction 860 call rewindLog # Rewind transaction log 861 ld E (DbFiles) # Iterate DB files 862 ld C (DBs) # Count 863 do 864 set (E (+ IV 1)) 0 # Clear dirty flag 865 add E VIII # Increment by sizeof(dbFile) 866 sub C VIII # Done? 867 until z # Yes 868 sub S (MaxBlkSize) # <S> Buffer 869 do 870 cc fread(Buf 2 1 (DbLog)) # Read file number 871 null A # Any? 872 jz jnlErrX # No 873 ld2 (Buf) # Get file number (byte order doesn't matter) 874 cmp A (hex "FFFF") # End marker? 875 while ne # No 876 call dbfBuf_AF # Read file number from 'Buf' to 'DbFile' 877 jc jnlErrX # No local file 878 cc fread(Buf BLK 1 (DbLog)) # Read object ID 879 cmp A 1 # OK? 880 jne jnlErrX # No 881 cc fread(S ((DbFile) III) 1 (DbLog)) # Read block data 882 cmp A 1 # OK? 883 jne jnlErrX # No 884 ld Z Buf # Get object ID from 'Buf' 885 call getAdrZ_A 886 shl A ((DbFile) II) # Shift 887 ld C ((DbFile) III) # Block size 888 cc pwrite(((DbFile)) S C A) # Write C bytes from stack buffer to pos A 889 cmp A C # OK? 890 jne dbWrErr 891 set ((DbFile) (+ IV 1)) 1 # Set dirty flag 892 loop 893 add S (MaxBlkSize) # Drop buffer 894 call fsyncDB # Sync DB files to disk 895 break T 896 end 897 call dbfBuf_AF # Read file number from 'Buf' into 'DbFile' 898 jc 40 # No local file 899 cc fread(Buf BLK 1 (DbLog)) # Read object ID 900 cmp A 1 # OK? 901 jne 40 # No 902 cc fseek((DbLog) ((DbFile) III) SEEK_CUR) # Skip by 'siz' 903 nul4 # OK? 904 jnz 40 # No 905 cc fread(Buf 2 1 (DbLog)) # Read next file number 906 cmp A 1 # OK? 907 if nz # No 908 40 call ignLog # Discard incomplete transaction 909 break T 910 end 911 loop 912 end 913 end 914 call truncLog # Truncate log file 915 end 916 end 917 drop 918 pop Z 919 pop Y 920 pop X 921 ld E TSym # Return T 922 ret 923 924 (code 'ignLog) 925 cc fprintf((stderr) IgnLog) 926 ret 927 928 (code 'rewindLog) 929 cc fseek((DbLog) 0 SEEK_SET) # Rewind transaction log 930 ret 931 932 (code 'fsyncDB) 933 ld E (DbFiles) # Iterate DB files 934 ld C (DBs) # Count 935 do 936 nul (E (+ IV 1)) # Dirty? 937 if nz # Yes 938 cc fsync((E)) # Sync DB file to disk 939 nul4 # OK? 940 js dbSyncErrX # No 941 end 942 add E VIII # Increment by sizeof(dbFile) 943 sub C VIII # Done? 944 until z # Yes 945 ret 946 947 (code 'truncLog) 948 call rewindLog # Rewind transaction log 949 call logFileno_A # Get fd 950 cc ftruncate(A 0) # Truncate log file 951 nul4 # OK? 952 jnz truncErrX 953 ret 954 955 # Append A-O encoding to string 956 (code 'bufAoAC_C 0) 957 cmp A 15 # Single digit? 958 if gt # No 959 push A # Save 960 shr A 4 # Divide by 16 961 call bufAoAC_C # Recurse 962 pop A 963 and B 15 # Get remainder 964 end 965 add B (char "@") # Make ASCII letter 966 ld (C) B # Store in buffer 967 inc C 968 ret 969 970 # (journal 'any ..) -> T 971 (code 'doJournal 2) 972 push X 973 push Y 974 push Z 975 ld X E 976 ld Y (E CDR) # Y on args 977 sub S (MaxBlkSize) # <S /I> Buffer 978 do 979 atom Y # More args? 980 while z # Yes 981 call evSymY_E # Next file name 982 call pathStringE_SZ # Write to stack buffer 983 cc fopen(S _r_) # Open file 984 ld S Z # Drop buffer 985 null A # OK? 986 jz openErrEX # No 987 ld E A # Keep journal file pointer in E 988 do 989 cc getc_unlocked(E) # Next char 990 nul4 # EOF? 991 while ns # No 992 ld C A # Size in C 993 cc fread(Buf 2 1 E) # Read file number 994 cmp A 1 # OK? 995 jne jnlErrX # No 996 call dbfBuf_AF # Read file number from 'Buf' to 'DbFile' 997 jc dbfErrX # No local file 998 cmp C BLKSIZE # Whole block? 999 ldz C (A III) # Yes: Take file's block size 1000 cc fread(Buf BLK 1 E) # Read object ID 1001 cmp A 1 # OK? 1002 jne jnlErrX # No 1003 cc fread(S C 1 E) # Read data into buffer 1004 cmp A 1 # OK? 1005 jne jnlErrX # No 1006 push E # Save journal file pointer 1007 ld Z Buf # Get object ID from 'Buf' 1008 call getAdrZ_A 1009 ld E A # into E 1010 shl E ((DbFile) II) # Shift 1011 lea Z (S I) # Buffer 1012 call blkPokeCEZ # Write object data 1013 pop E # Restore journal file pointer 1014 loop 1015 cc fclose(E) # Close file pointer 1016 ld Y (Y CDR) 1017 loop 1018 add S (MaxBlkSize) # Drop buffer 1019 ld E TSym # Return T 1020 pop Z 1021 pop Y 1022 pop X 1023 ret 1024 1025 # (id 'num ['num]) -> sym 1026 # (id 'sym [NIL]) -> num 1027 # (id 'sym T) -> (num . num) 1028 (code 'doId 2) 1029 push X 1030 push Y 1031 ld X E 1032 ld Y (E CDR) # Y on args 1033 ld E (Y) # Eval first 1034 eval 1035 num E # File number? 1036 if nz # Yes 1037 shr E 4 # Normalize 1038 push E # <S> Scaled file number or object ID 1039 ld Y (Y CDR) # Next arg 1040 ld E (Y) 1041 eval # Eval object ID 1042 cmp E Nil # Given? 1043 if eq # No 1044 pop C # Get object ID 1045 ld E 0 # File defaults to zero 1046 else 1047 call xCntEX_FE # Eval object ID 1048 ld C E # into C 1049 pop E # Get file number 1050 dec E # Zero-based 1051 end 1052 call extNmCE_X # Build external symbol name 1053 call externX_E # New external symbol 1054 pop Y 1055 pop X 1056 ret 1057 end 1058 sym E # Need symbol 1059 jz symErrEX 1060 sym (E TAIL) # External symbol? 1061 jz extErrEX # No 1062 xchg E Y # Keep symbol in Y 1063 ld E ((E CDR)) # Eval second arg 1064 eval # Eval flag 1065 xchg E Y # Keep flag in Y, get symbol in E 1066 call fileObjE_AC # Get file and ID 1067 shl C 4 # Make short object ID 1068 or C CNT 1069 cmp Y Nil # Return only object ID? 1070 ldz E C # Yes 1071 if ne # No 1072 inc A # File is zero-based 1073 shl A 4 # Make short file number 1074 or A CNT 1075 call cons_E # Return (file . id) 1076 ld (E) A 1077 ld (E CDR) C 1078 end 1079 pop Y 1080 pop X 1081 ret 1082 1083 # (seq 'cnt|sym1) -> sym | NIL 1084 (code 'doSeq 2) 1085 push X 1086 push Y 1087 push Z 1088 ld X E 1089 ld E ((E CDR)) # Eval arg 1090 eval 1091 num E # File number? 1092 if nz # Yes 1093 off E 15 # Normalize + 'dbFile' index 1094 sub E (hex "10") # Zero-based 1095 shl E 2 1096 push E # <S> Scaled file number 1097 cmp E (DBs) # Local file? 1098 jge dbfErrX # No 1099 add E (DbFiles) # Get DB file 1100 ld (DbFile) E # Set current 1101 ld X 0 # Block index zero 1102 else 1103 sym E # Need symbol 1104 jz symErrEX 1105 sym (E TAIL) # External symbol? 1106 jz extErrEX # No 1107 call fileObjE_AC # Get file and ID 1108 shl A 6 # 'dbFile' index 1109 push A # <S> Scaled file number 1110 cmp A (DBs) # Local file? 1111 jge dbfErrX # No 1112 add A (DbFiles) # Get DB file 1113 ld (DbFile) A # Set current 1114 shl C 6 # Block index from object ID 1115 ld X C # Block index in X 1116 end 1117 call rdLockDb # Lock for reading 1118 ld C BLK # Read 'next' 1119 ld E BLK 1120 ld Z Buf # into 'Buf' 1121 call blkPeekCEZ 1122 call getAdrZ_A # Get 'next' 1123 ld Y A # into Y 1124 do 1125 add X BLKSIZE # Increment block index 1126 cmp X Y # Less than 'next'? 1127 if ge # No 1128 add S I # Drop file number 1129 ld E Nil # Return NIL 1130 break T 1131 end 1132 ld E X # Block index 1133 shl E ((DbFile) II) # Shift 1134 ld C BLK # Read link field 1135 call blkPeekCEZ # into 'Buf' 1136 ld B (Z) # Get tag byte 1137 and B BLKTAG # Block tag 1138 cmp B 1 # One? 1139 if eq # Yes 1140 pop E # Get scaled file number 1141 shr E 6 # Normalize 1142 ld C X # Object ID 1143 shr C 6 # Normalize 1144 call extNmCE_X # Build external symbol name 1145 call externX_E # New external symbol 1146 break T 1147 end 1148 loop 1149 ld A (hex "10000") # Length 1 1150 call rwUnlockDbA # Unlock 1151 pop Z 1152 pop Y 1153 pop X 1154 ret 1155 1156 # (lieu 'any) -> sym | NIL 1157 (code 'doLieu 2) 1158 ld E ((E CDR)) # Get arg 1159 eval # Eval it 1160 num E # Number? 1161 jnz retNil # Yes 1162 sym E # Symbol? 1163 jz retNil # No 1164 ld A (E TAIL) # Get tail 1165 sym A # External symbol? 1166 jz retNil # No 1167 off A SYM # Clear 'extern' tag 1168 do 1169 num A # Found name? 1170 if nz # Yes 1171 shl A 1 # Dirty? 1172 if nc # No 1173 shl A 1 # Loaded? 1174 ldnc E Nil # No 1175 ret 1176 end 1177 shl A 1 # Deleted? 1178 ldc E Nil # Yes 1179 ret 1180 end 1181 ld A (A CDR) # Skip property 1182 loop 1183 1184 # (lock ['sym]) -> cnt | NIL 1185 (code 'doLock 2) 1186 push X 1187 ld X E 1188 ld E ((E CDR)) # E on arg 1189 eval # Eval it 1190 cmp E Nil # NIL? 1191 if eq # Yes 1192 ld (DbFile) (DbFiles) # Use first dbFile 1193 ld C 0 # Start 1194 ld E 0 # Length 1195 call tryLockCE_FA # Lock whole DB 1196 else 1197 num E # Need symbol 1198 jnz symErrEX 1199 sym E 1200 jz symErrEX 1201 sym (E TAIL) # External symbol? 1202 jz extErrEX # No 1203 call fileObjE_AC # Get file and ID 1204 shl A 6 # 'dbFile' index 1205 cmp A (DBs) # Local file? 1206 jge dbfErrX # No 1207 add A (DbFiles) # Get DB file 1208 ld (DbFile) A 1209 ld A (A III) # Get block size 1210 mul C # Multiply with object ID for start position 1211 ld C A # Start 1212 ld E 1 # Length 1213 call tryLockCE_FA # Lock external symbol 1214 end 1215 ld E Nil # Preload NIL 1216 if nz # Locked by another process 1217 ld E A # Get PID 1218 shl E 4 # Make short number 1219 or E CNT 1220 end 1221 pop X 1222 ret 1223 1224 (code 'dbFetchEX 0) 1225 ld A (E TAIL) # Get tail 1226 num A # Any properties? 1227 jz Ret # Yes 1228 rcl A 1 # Dirty? 1229 jc ret # Yes 1230 rcl A 1 # Loaded? 1231 jc ret # Yes 1232 setc # Set "loaded" 1233 rcr A 1 1234 shr A 1 1235 push C 1236 : dbAEX 1237 push Y 1238 push Z 1239 link 1240 push E # <L I> Symbol 1241 link 1242 ld Y A # Status/name in Y 1243 call dbFileBlkY_AC # Get file and block index 1244 cmp A (DBs) # Local file? 1245 if lt # Yes 1246 call setBlockAC_Z # Set up block env 1247 call rdLockDb # Lock for reading 1248 call rdBlockZ_Z # Read first block 1249 ld B (Z (- BLK)) # Get tag byte 1250 and B BLKTAG # Block tag 1251 cmp B 1 # One? 1252 jne idErrXL # Bad ID 1253 ld (GetBinZ_FB) getBlockZ_FB # Set binary read function 1254 ld (Extn) 0 # Set external symbol offset to zero 1255 call binReadZ_FE # Read first item 1256 ld A (L I) # Get symbol 1257 ld (A) E # Set value 1258 ld (A TAIL) Y # and status/name 1259 call binReadZ_FE # Read first property key 1260 cmp E Nil # Any? 1261 if ne # Yes 1262 call consE_A # Build first property cell 1263 ld (A) E # Cons key 1264 ld (A CDR) Y # With status/name 1265 ld Y A # Keep cell in Y 1266 or A SYM # Set 'extern' tag 1267 ld ((L I) TAIL) A # Set symbol's tail 1268 call binReadZ_FE # Read property value 1269 cmp E TSym # T? 1270 if ne # No 1271 call consE_A # Cons property value 1272 ld (A) E 1273 ld (A CDR) (Y) # With key 1274 ld (Y) A # Save in first property cell 1275 end 1276 do 1277 call binReadZ_FE # Read next property key 1278 cmp E Nil # Any? 1279 while ne # Yes 1280 call consE_A # Build next property cell 1281 ld (A) E # Cons key 1282 ld (A CDR) (Y CDR) # With name 1283 ld (Y CDR) A # Insert 1284 ld Y A # Point Y to new cell 1285 call binReadZ_FE # Read property value 1286 cmp E TSym # T? 1287 if ne # No 1288 call consE_A # Cons property value 1289 ld (A) E 1290 ld (A CDR) (Y) # With key 1291 ld (Y) A # Save in property cell 1292 end 1293 loop 1294 end 1295 ld A (hex "10000") # Length 1 1296 call rwUnlockDbA # Unlock 1297 else 1298 shr A 6 # Revert to file number 1299 ld Z (Ext) # Extended databases? 1300 atom Z 1301 jnz dbfErrX # No 1302 ld C ((Z)) # First offset 1303 shr C 4 # Normalize 1304 cmp A C # First offset too big? 1305 jlt dbfErrX # Yes 1306 do 1307 ld E (Z CDR) # More? 1308 atom E 1309 while z # Yes 1310 ld C ((E)) # Next offset 1311 shr C 4 # Normalize 1312 cmp A C # Matching entry? 1313 while ge # No 1314 ld Z E # Try next DB extension 1315 loop 1316 push Y # Save name 1317 push ((Z) CDR) # fun ((Obj) ..) 1318 ld Y S # Pointer to fun in Y 1319 push (L I) # Symbol 1320 ld Z S # Z on (last) argument 1321 call applyXYZ_E # Apply 1322 pop Z # Get symbol 1323 add S I # Drop 'fun' 1324 pop Y # Get name 1325 ld (Z) (E) # Set symbol's value 1326 ld E (E CDR) # Properties? 1327 atom E 1328 if z # Yes 1329 ld A E # Set 'extern' tag 1330 or A SYM 1331 ld (Z TAIL) A # Set property list 1332 do 1333 atom (E CDR) # Find end 1334 while z 1335 ld E (E CDR) 1336 loop 1337 ld (E CDR) Y # Set name 1338 else 1339 or Y SYM # Set 'extern' tag 1340 ld (Z TAIL) Y # Set name 1341 end 1342 end 1343 ld E (L I) # Restore symbol 1344 drop 1345 pop Z 1346 pop Y 1347 pop C 1348 ret 1349 1350 (code 'dbTouchEX 0) 1351 push C 1352 lea C (E TAIL) # Get tail 1353 ld A (C) 1354 num A # Any properties? 1355 if z # Yes 1356 off A SYM # Clear 'extern' tag 1357 do 1358 lea C (A CDR) # Skip property 1359 ld A (C) 1360 num A # Find name 1361 until nz 1362 end 1363 rcl A 1 # Already dirty? 1364 if nc # No 1365 rcl A 1 # Loaded? 1366 if c # Yes 1367 shr A 1 1368 setc # Set "dirty" 1369 rcr A 1 1370 ld (C) A # in status/name 1371 pop C 1372 ret 1373 end 1374 shr A 1 1375 setc # Set "dirty" 1376 rcr A 1 1377 jmp dbAEX 1378 end 1379 pop C 1380 ret 1381 1382 (code 'dbZapE 0) 1383 ld A (E TAIL) # Get tail 1384 num A # Any properties? 1385 if z # Yes 1386 off A SYM # Clear 'extern' tag 1387 do 1388 ld A (A CDR) # Skip property 1389 num A # Find name 1390 until nz 1391 or A SYM # Set 'extern' tag 1392 end 1393 shl A 2 # Set "deleted" 1394 setc 1395 rcr A 1 1396 setc 1397 rcr A 1 1398 ld (E TAIL) A # Set empty tail 1399 ld (E) Nil # Clear value 1400 ret 1401 1402 # (commit ['any] [exe1] [exe2]) -> T 1403 (code 'doCommit 2) 1404 push X 1405 push Y 1406 push Z 1407 ld X E 1408 ld Y (E CDR) # Y on args 1409 ld E (Y) # Eval 'any' 1410 eval 1411 link 1412 push E # <L I> 'any' 1413 link 1414 null (DbLog) # Transaction log? 1415 if z # No 1416 inc (EnvProtect) # Protect the operation 1417 end 1418 call wrLockDb # Write lock DB 1419 null (DbJnl) # Journal? 1420 if nz # Yes 1421 call lockJnl # Write lock journal 1422 end 1423 null (DbLog) # Transaction log? 1424 if nz # Yes 1425 ld E (DbFiles) # Iterate DB files 1426 ld C (DBs) # Count 1427 do 1428 set (E (+ IV 1)) 0 # Clear dirty flag 1429 ld (E VII) 0 # and 'fluse' 1430 add E VIII # Increment by sizeof(dbFile) 1431 sub C VIII # Done? 1432 until z # Yes 1433 push X 1434 push Y 1435 ld X Extern # Iterate external symbol tree 1436 ld Y 0 # Clear TOS 1437 do 1438 do 1439 ld A (X CDR) # Get subtrees 1440 atom (A CDR) # Right subtree? 1441 while z # Yes 1442 ld C X # Go right 1443 ld X (A CDR) # Invert tree 1444 ld (A CDR) Y # TOS 1445 ld Y C 1446 loop 1447 do 1448 ld A ((X) TAIL) # Get external symbol's tail 1449 call nameA_A # Get name 1450 rcl A 1 # Dirty or deleted? 1451 if c # Yes 1452 push Y 1453 rcr A 1 1454 ld Y A # Name in Y 1455 call dbFileBlkY_AC # Get file and block index 1456 cmp A (DBs) # Local file? 1457 if lt # Yes 1458 call setBlockAC_Z # Set up block env 1459 call rdBlockZ_Z # Read first block 1460 do 1461 call logBlock # Write to transaction log 1462 null (BlkLink) # More blocks? 1463 while nz # Yes 1464 call rdBlockLinkZ_Z # Read next block 1465 loop 1466 ld C (DbFile) 1467 set (C (+ IV 1)) 1 # Set dirty flag 1468 rcl Y 2 # Deleted? 1469 if nc # No 1470 inc (C VII) # Increment 'fluse' 1471 end 1472 end 1473 pop Y 1474 end 1475 ld A (X CDR) # Left subtree? 1476 atom (A) 1477 if z # Yes 1478 ld C X # Go left 1479 ld X (A) # Invert tree 1480 ld (A) Y # TOS 1481 or C SYM # First visit 1482 ld Y C 1483 break T 1484 end 1485 do 1486 ld A Y # TOS 1487 null A # Empty? 1488 jeq 20 # Done 1489 sym A # Second visit? 1490 if z # Yes 1491 ld C (A CDR) # Nodes 1492 ld Y (C CDR) # TOS on up link 1493 ld (C CDR) X 1494 ld X A 1495 break T 1496 end 1497 off A SYM # Set second visit 1498 ld C (A CDR) # Nodes 1499 ld Y (C) 1500 ld (C) X 1501 ld X A 1502 loop 1503 loop 1504 loop 1505 20 ld X (DbFiles) # Iterate DB files 1506 ld Y (DBs) # Count 1507 do 1508 ld A (X VII) # Get 'fluse' 1509 null A # Any? 1510 if nz # Yes 1511 push A # Save as count 1512 ld A X 1513 ld C 0 # Save Block 0 and free list 1514 call setBlkAC_Z # Set up block env 1515 call rdBlockZ_Z # Read first block 1516 do 1517 call logBlock # Write to transaction log 1518 null (BlkLink) # More blocks? 1519 while nz # Yes 1520 sub (S) 1 # Decrement count 1521 while nc 1522 call rdBlockLinkZ_Z # Read next block 1523 loop 1524 add S I # Drop count 1525 end 1526 add X VIII # Increment by sizeof(dbFile) 1527 sub Y VIII # Done? 1528 until z # Yes 1529 cc putc_unlocked((hex "FF") (DbLog)) # Write end marker 1530 cc putc_unlocked((hex "FF") (DbLog)) 1531 cc fflush((DbLog)) # Flush Transaction log 1532 call logFileno_A # Sync log file to disk 1533 cc fsync(A) 1534 nul4 # OK? 1535 js trSyncErrX # No 1536 pop Y 1537 pop X 1538 end 1539 ld Y (Y CDR) # Eval pre-expression 1540 ld E (Y) 1541 eval 1542 cmp (L I) Nil # 'any'? 1543 if eq # No 1544 push 0 # <L -I> No notification 1545 else 1546 ld A (Tell) 1547 or A (Children) 1548 push A # <L -I> Notify flag 1549 if nz 1550 push A # <L -II> Tell's buffer pointer 1551 push (TellBuf) # <L -III> Save current 'tell' env 1552 sub S PIPE_BUF # <L - III - PIPE_BUF> New 'tell' buffer 1553 ld Z S # Buffer pointer 1554 call tellBegZ_Z # Start 'tell' message 1555 ld E (L I) # Get 'any' 1556 call prTellEZ # Print to 'tell' 1557 ld (L -II) Z # Save buffer pointer 1558 end 1559 end 1560 push X 1561 push Y 1562 ld X Extern # Iterate external symbol tree 1563 ld Y 0 # Clear TOS 1564 do 1565 do 1566 ld A (X CDR) # Get subtrees 1567 atom (A CDR) # Right subtree? 1568 while z # Yes 1569 ld C X # Go right 1570 ld X (A CDR) # Invert tree 1571 ld (A CDR) Y # TOS 1572 ld Y C 1573 loop 1574 do 1575 lea C ((X) TAIL) # Get external symbol's tail 1576 ld A (C) 1577 num A # Any properties? 1578 if z # Yes 1579 off A SYM # Clear 'extern' tag 1580 do 1581 lea C (A CDR) # Skip property 1582 ld A (C) 1583 num A # Find name 1584 until nz 1585 end 1586 rcl A 1 # Dirty? 1587 if c # Yes 1588 push Y 1589 rcl A 1 # Deleted? 1590 if nc # No 1591 setc # Set "loaded" 1592 rcr A 1 1593 shr A 1 1594 ld (C) A # in status/name 1595 ld Y A # Name in Y 1596 call dbFileBlkY_AC # Get file and block index 1597 cmp A (DBs) # Local file? 1598 if lt # Yes 1599 call setBlockAC_Z # Set up block env 1600 call rdBlockZ_Z # Read first block 1601 ld B 1 # First block in object (might be a new object) 1602 or (Z (- BLK)) B # Set in tag byte 1603 ld (PutBinBZ) putBlockBZ # Set binary print function 1604 ld Y (X) # Get external symbol 1605 ld E (Y) # Print value 1606 ld (Extn) 0 # Set external symbol offset to zero 1607 call binPrintEZ 1608 ld Y (Y TAIL) # Get tail 1609 off Y SYM # Clear 'extern' tag 1610 do 1611 num Y # Properties? 1612 while z # Yes 1613 atom (Y) # Flag? 1614 if z # No 1615 ld E ((Y) CDR) # Get key 1616 cmp E Nil # Volatile property? 1617 if ne # No 1618 call binPrintEZ # Print key 1619 ld E ((Y)) # Print value 1620 call binPrintEZ 1621 end 1622 else 1623 ld E (Y) # Get key 1624 cmp E Nil # Volatile property? 1625 if ne # No 1626 call binPrintEZ # Print key 1627 ld E TSym # Print 'T' 1628 call binPrintEZ 1629 end 1630 end 1631 ld Y (Y CDR) 1632 loop 1633 ld A NIX 1634 call putBlockBZ # Output NIX 1635 ld Z (DbBlock) # Block buffer in Z again 1636 ld B (Z) # Lowest byte of link field 1637 and B BLKTAG # Clear link 1638 zxt 1639 call setAdrAZ # Store in last block 1640 call wrBlockZ # Write block 1641 ld Y (BlkLink) # More blocks? 1642 null Y 1643 if nz # Yes 1644 call cleanUpY # Clean up 1645 end 1646 null (L -I) # Notify? 1647 if nz # Yes 1648 ld Z (L -II) # Get buffer pointer 1649 lea A ((TellBuf) (- PIPE_BUF 10)) # Space for EXTERN+<8>+END? 1650 cmp Z A 1651 if ge # No 1652 ld A 0 # Send to all PIDs 1653 call tellEndAZ # Close 'tell' 1654 lea Z (L (- (+ III PIPE_BUF))) # Reset buffer pointer 1655 call tellBegZ_Z # Start new 'tell' message 1656 ld E (L I) # Get 'any' 1657 call prTellEZ # Print to 'tell' 1658 end 1659 ld E (X) # Get external symbol 1660 call prTellEZ # Print to 'tell' 1661 ld (L -II) Z # Save buffer pointer 1662 end 1663 end 1664 else # Deleted 1665 shr A 2 # Set "not loaded" 1666 ld (C) A # in status/name 1667 ld Y A # Name in Y 1668 call dbFileBlkY_AC # Get file and block index 1669 cmp A (DBs) # Local file? 1670 if lt # Yes 1671 add A (DbFiles) # Get DB file 1672 ld (DbFile) A # Set current 1673 ld Y C 1674 call cleanUpY # Clean up 1675 null (L -I) # Notify? 1676 if nz # Yes 1677 ld Z (L -II) # Get buffer pointer 1678 lea A ((TellBuf) (- PIPE_BUF 10)) # Space for EXTERN+<8>+END? 1679 cmp Z A 1680 if ge # No 1681 ld A 0 # Send to all PIDs 1682 call tellEndAZ # Close 'tell' 1683 lea Z (L (- (+ III PIPE_BUF))) # Reset buffer pointer 1684 call tellBegZ_Z # Start new 'tell' message 1685 ld E (L I) # Get 'any' 1686 call prTellEZ # Print to 'tell' 1687 end 1688 ld E (X) # Get external symbol 1689 call prTellEZ # Print to 'tell' 1690 ld (L -II) Z # Save buffer pointer 1691 end 1692 end 1693 end 1694 pop Y 1695 end 1696 ld A (X CDR) # Left subtree? 1697 atom (A) 1698 if z # Yes 1699 ld C X # Go left 1700 ld X (A) # Invert tree 1701 ld (A) Y # TOS 1702 or C SYM # First visit 1703 ld Y C 1704 break T 1705 end 1706 do 1707 ld A Y # TOS 1708 null A # Empty? 1709 jeq 40 # Done 1710 sym A # Second visit? 1711 if z # Yes 1712 ld C (A CDR) # Nodes 1713 ld Y (C CDR) # TOS on up link 1714 ld (C CDR) X 1715 ld X A 1716 break T 1717 end 1718 off A SYM # Set second visit 1719 ld C (A CDR) # Nodes 1720 ld Y (C) 1721 ld (C) X 1722 ld X A 1723 loop 1724 loop 1725 loop 1726 40 pop Y 1727 pop X 1728 null (L -I) # Notify? 1729 if nz # Yes 1730 ld A 0 # Send to all PIDs 1731 ld Z (L -II) # Get buffer pointer 1732 call tellEndAZ # Close 'tell' 1733 add S PIPE_BUF # Drop 'tell' buffer 1734 pop (TellBuf) 1735 end 1736 ld Y (Y CDR) # Eval post-expression 1737 ld E (Y) 1738 eval 1739 null (DbJnl) # Journal? 1740 if nz # Yes 1741 call unLockJnl # Unlock journal 1742 end 1743 ld Y (Zap) # Objects to delete? 1744 atom Y 1745 if z # Yes 1746 push (OutFile) # Save output channel 1747 sub S (+ III BUFSIZ) # <S> Local buffer with sizeof(outFile) 1748 ld E (Y CDR) # Get zap file pathname 1749 call pathStringE_SZ # Write to stack buffer 1750 cc open(S (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) # Open zap file 1751 nul4 # OK? 1752 js openErrEX # No 1753 ld S Z # Drop buffer 1754 ld (S) A # Store 'fd' in outFile 1755 ld (S I) 0 # Clear 'ix' 1756 ld (S II) 0 # and 'tty' 1757 ld (OutFile) S # Set OutFile 1758 ld (PutBinBZ) putStdoutB # Set binary print function 1759 ld Y (Y) # Get zap list 1760 do 1761 atom Y # More symbols? 1762 while z # Yes 1763 ld E (Y) # Get next 1764 ld (Extn) 0 # Set external symbol offset to zero 1765 call binPrintEZ # Print it 1766 ld Y (Y CDR) 1767 loop 1768 ld A S # Flush file 1769 call flushA_F 1770 ld A S # Close file 1771 call closeAX 1772 ld ((Zap)) Nil # Clear zap list 1773 add S (+ III BUFSIZ) # Drop buffer 1774 pop (OutFile) # Restore output channel 1775 end 1776 null (DbLog) # Transaction log? 1777 if nz # Yes 1778 call fsyncDB # Sync DB files to disk 1779 call truncLog # Truncate log file 1780 end 1781 ld A 0 # Length 1782 call rwUnlockDbA # Unlock all 1783 call unsync # Release sync 1784 null (DbLog) # Transaction log? 1785 if z # No 1786 dec (EnvProtect) # Unprotect 1787 end 1788 ld E (DbFiles) # Iterate DB files 1789 ld C (DBs) # Count 1790 do 1791 ld (E VII) -1 # Init 'fluse' 1792 add E VIII # Increment by sizeof(dbFile) 1793 sub C VIII # Done? 1794 until z # Yes 1795 drop 1796 pop Z 1797 pop Y 1798 pop X 1799 ld E TSym # Return T 1800 ret 1801 1802 # (rollback) -> T 1803 (code 'doRollback 2) 1804 push X 1805 push Y 1806 ld X Extern # Iterate external symbol tree 1807 ld Y 0 # Clear TOS 1808 do 1809 do 1810 ld A (X CDR) # Get subtrees 1811 atom (A CDR) # Right subtree? 1812 while z # Yes 1813 ld C X # Go right 1814 ld X (A CDR) # Invert tree 1815 ld (A CDR) Y # TOS 1816 ld Y C 1817 loop 1818 do 1819 ld E (X) # Get external symbol 1820 ld A (E TAIL) 1821 num A # Any properties? 1822 if z # Yes 1823 off A SYM # Clear 'extern' tag 1824 do 1825 ld A (A CDR) # Skip property 1826 num A # Find name 1827 until nz 1828 or A SYM # Set 'extern' tag 1829 end 1830 shl A 2 # Strip status bits 1831 shr A 2 1832 ld (E TAIL) A # Set status/name 1833 ld (E) Nil # Clear value 1834 ld A (X CDR) # Left subtree? 1835 atom (A) 1836 if z # Yes 1837 ld C X # Go left 1838 ld X (A) # Invert tree 1839 ld (A) Y # TOS 1840 or C SYM # First visit 1841 ld Y C 1842 break T 1843 end 1844 do 1845 ld A Y # TOS 1846 null A # Empty? 1847 jeq 90 # Done 1848 sym A # Second visit? 1849 if z # Yes 1850 ld C (A CDR) # Nodes 1851 ld Y (C CDR) # TOS on up link 1852 ld (C CDR) X 1853 ld X A 1854 break T 1855 end 1856 off A SYM # Set second visit 1857 ld C (A CDR) # Nodes 1858 ld Y (C) 1859 ld (C) X 1860 ld X A 1861 loop 1862 loop 1863 loop 1864 90 ld Y (Zap) # Objects to delete? 1865 atom Y 1866 if z # Yes 1867 ld (Y) Nil # Clear zap list 1868 end 1869 ld A 0 # Length 1870 call rwUnlockDbA # Unlock all 1871 call unsync # Release sync 1872 pop Y 1873 pop X 1874 ld E TSym # Return T 1875 ret 1876 1877 # (mark 'sym|0 [NIL | T | 0]) -> flg 1878 (code 'doMark 2) 1879 push X 1880 push Y 1881 ld X E 1882 ld Y (E CDR) # Y on args 1883 ld E (Y) # Eval first 1884 eval 1885 cmp E ZERO # Zero? 1886 if eq # Yes 1887 ld X (DbFiles) # Iterate DB files 1888 ld Y (DBs) # Count 1889 do 1890 sub Y VIII # Done? 1891 while ge # No 1892 ld (X V) 0 # Mark vector size zero 1893 cc free((X VI)) # Free mark bit vector 1894 ld (X VI) 0 # Set to null 1895 add X VIII # Increment by sizeof(dbFile) 1896 loop 1897 ld E Nil # Return NIL 1898 pop Y 1899 pop X 1900 ret 1901 end 1902 num E # Need symbol 1903 jnz symErrEX 1904 sym E 1905 jz symErrEX 1906 sym (E TAIL) # External symbol? 1907 jz extErrEX # No 1908 push E # <S> 'sym' 1909 ld E ((Y CDR)) # Eval second arg 1910 eval 1911 xchg E (S) # <S> NIL | T | 0 1912 call fileObjE_AC # Get file and ID 1913 shl A 6 # 'dbFile' index 1914 cmp A (DBs) # Local file? 1915 jge dbfErrX # No 1916 add A (DbFiles) # Get DB file 1917 ld X A # into X 1918 ld E C # Object ID in E 1919 shr E 3 # Byte position 1920 cmp E (X V) # Greater or equal to mark vector size? 1921 if ge # Yes 1922 push E # Save byte position 1923 inc E # New size 1924 ld Y E # Keep in Y 1925 ld A (X VI) # Get mark bit vector 1926 call allocAE_A # Increase to new size 1927 ld (X VI) A 1928 xchg E (X V) # Store size in 'dbFile', get old size 1929 sub Y E # Length of new area 1930 add E A # Start position of new area 1931 ld B 0 # Clear new area 1932 mset (E) Y 1933 pop E # Restore byte position 1934 end 1935 add E (X VI) # Byte position in bit vector 1936 and C 7 # Lowest three bits of object ID 1937 ld B 1 # Bit position 1938 shl B C # in B 1939 test (E) B # Bit test 1940 if z # Not set 1941 cmp (S) TSym # Second arg 'T'? 1942 if eq # Yes 1943 or (E) B # Set mark 1944 end 1945 ld E Nil # Return NIL 1946 else # Bit was set 1947 cmp (S) ZERO # Second arg '0'? 1948 if eq # Yes 1949 not B 1950 and (E) B # Clear mark 1951 end 1952 ld E TSym # Return T 1953 end 1954 add S I # Drop second arg 1955 pop Y 1956 pop X 1957 ret 1958 1959 # (free 'cnt) -> (sym . lst) 1960 (code 'doFree 2) 1961 push X 1962 push Y 1963 push Z 1964 ld X E 1965 ld E ((E CDR)) # Eval 'cnt' 1966 call evCntEX_FE 1967 dec E # File is zero-based 1968 shl E 6 # 'dbFile' index 1969 cmp E (DBs) # Local file? 1970 jge dbfErrX # No 1971 add E (DbFiles) # Get DB file 1972 ld (DbFile) E # Set current 1973 call rdLockDb # Lock for reading 1974 ld C (* 2 BLK) # Read 'free' and 'next' 1975 ld E 0 # from block zero 1976 ld Z Buf # into 'Buf' 1977 call blkPeekCEZ 1978 call getAdrZ_A # Get 'free' 1979 ld (BlkLink) A # Store as next block 1980 add Z BLK 1981 call getAdrZ_A # Get 'next' 1982 ld C A # Object ID 1983 shr C 6 # Normalize 1984 ld E ((DbFile) I) # Get file number 1985 call extNmCE_X # Build external symbol name 1986 call externX_E # New external symbol 1987 call cons_Y # Cons as CAR of result list 1988 ld (Y) E 1989 ld (Y CDR) Nil 1990 link 1991 push Y # (L I) Result list 1992 link 1993 do # Collect free list 1994 ld C (BlkLink) # Next free block? 1995 null C 1996 while nz # Yes 1997 shr C 6 # Normalize 1998 ld E ((DbFile) I) # Get file number 1999 call extNmCE_X # Build external symbol name 2000 call externX_E # New external symbol 2001 call cons_A # Next cell 2002 ld (A) E 2003 ld (A CDR) Nil 2004 ld (Y CDR) A # Append ot result list 2005 ld Y A 2006 call rdBlockLinkZ_Z # Read next block 2007 loop 2008 ld A (hex "10000") # Length 1 2009 call rwUnlockDbA # Unlock 2010 ld E (L I) # Get result list 2011 drop 2012 pop Z 2013 pop Y 2014 pop X 2015 ret 2016 2017 # (dbck ['cnt] 'flg) -> any 2018 (code 'doDbck 2) 2019 push X 2020 push Y 2021 push Z 2022 ld X E 2023 ld Y (E CDR) # Y on args 2024 ld E (Y) # Eval first 2025 eval 2026 ld (DbFile) (DbFiles) # Default to first dbFile 2027 cnt E # 'cnt' arg? 2028 if nz # Yes 2029 off E 15 # Normalize + 'dbFile' index 2030 sub E (hex "10") # Zero-based 2031 shl E 2 2032 cmp E (DBs) # Local file? 2033 jge dbfErrX # No 2034 add E (DbFiles) # Get DB file 2035 ld (DbFile) E # Set current 2036 ld Y (Y CDR) # Next arg 2037 ld E (Y) 2038 eval # Eval next arg 2039 end 2040 push (DbJnl) # <S IV> Journal 2041 push E # <S III> 'flg' 2042 push ZERO # <S II> 'syms' 2043 push ZERO # <S I> 'blks' 2044 inc (EnvProtect) # Protect the operation 2045 call wrLockDb # Write lock DB 2046 null (DbJnl) # Journal? 2047 if nz # Yes 2048 call lockJnl # Write lock journal 2049 end 2050 ld C (* 2 BLK) # Read 'free' and 'next' 2051 ld E 0 # from block zero 2052 ld Z Buf # into 'Buf' 2053 call blkPeekCEZ 2054 call getAdrZ_A # Get 'free' 2055 ld (BlkLink) A # Store as next block 2056 add Z BLK 2057 call getAdrZ_A # Get 'next' 2058 push A # <S> 'next' 2059 ld Y BLKSIZE # 'cnt' in Y 2060 ld (DbJnl) 0 # Disable Journal 2061 do # Check free list 2062 ld A (BlkLink) # Next block? 2063 null A 2064 while nz # Yes 2065 call rdBlockIndexAZ_Z # Read next block 2066 add Y BLKSIZE # Increment 'cnt' 2067 cmp Y (S) # Greater than 'next'? 2068 if gt # Yes 2069 ld E CircFree # Circular free list 2070 call mkStrE_E # Return message 2071 jmp 90 2072 end 2073 ld Z (DbBlock) # Block buffer in Z again 2074 or (Z) BLKTAG # Mark free list 2075 call wrBlockZ # Write block 2076 loop 2077 ld (DbJnl) (S IV) # Restore Journal 2078 ld X BLKSIZE # 'p' in X 2079 do # Check all chains 2080 cmp X (S) # Reached 'next'? 2081 while ne # No 2082 ld A X # Get 'p' 2083 call rdBlockIndexAZ_Z # Read next block 2084 sub Z BLK # Block buffer in Z again 2085 ld B (Z) # Get tag byte 2086 and B BLKTAG # Block tag zero? 2087 if z # Yes 2088 add Y BLKSIZE # Increment 'cnt' 2089 movn (Z) (Buf) BLK # Insert into free list 2090 call wrBlockZ # Write block 2091 ld A X # Write 'free' 2092 ld Z Buf # into 'Buf' 2093 call setAdrAZ 2094 ld C BLK 2095 ld E 0 # 'free' address 2096 call blkPokeCEZ # Write 'Buf' 2097 else 2098 cmp B 1 # ID-block of symbol? 2099 if eq # Yes 2100 push X 2101 add (S II) (hex "10") # Increment 'blks' 2102 add (S III) (hex "10") # Increment 'syms' 2103 add Y BLKSIZE # Increment 'cnt' 2104 ld X 2 # Init 'i' 2105 do 2106 ld A (BlkLink) # Next block? 2107 null A 2108 while nz # Yes 2109 add Y BLKSIZE # Increment 'cnt' 2110 add (S II) (hex "10") # Increment 'blks' 2111 call rdBlockIndexAZ_Z # Read next block 2112 ld B (Z (- BLK)) # Get tag byte 2113 and B BLKTAG # Block tag 2114 cmp B X # Same as 'i'? 2115 if ne # No 2116 ld E BadChain # Bad object chain 2117 call mkStrE_E # Return message 2118 jmp 90 2119 end 2120 cmp X BLKTAG # Less than maximum? 2121 if lt # Yes 2122 inc X # Increment 2123 end 2124 loop 2125 pop X 2126 end 2127 end 2128 add X BLKSIZE # Increment 'p' 2129 loop 2130 ld Z Buf # Get 'free' 2131 call getAdrZ_A 2132 ld (BlkLink) A # Store as next block 2133 ld (DbJnl) 0 # Disable Journal 2134 do # Unmark free list 2135 null A # Any? 2136 while nz # Yes 2137 call rdBlockIndexAZ_Z # Read next block 2138 sub Z BLK # Block buffer in Z again 2139 ld B (Z) # Get tag byte 2140 and B BLKTAG # Block tag non-zero? 2141 if nz # Nes 2142 off (Z) BLKTAG # Clear tag 2143 call wrBlockZ # Write block 2144 end 2145 ld A (BlkLink) # Get next block 2146 loop 2147 cmp Y (S) # 'cnt' == 'next'? 2148 if ne # No 2149 ld E BadCount # Circular free list 2150 call mkStrE_E # Return message 2151 else 2152 cmp (S III) Nil # 'flg' is NIL? 2153 ldz E Nil # Yes: Return NIL 2154 if ne # No 2155 call cons_E # Return (blks . syms) 2156 ld (E) (S I) # 'blks' 2157 ld (E CDR) (S II) # 'syms' 2158 end 2159 end 2160 90 add S IV # Drop 'next', 'blks', 'syms' and 'flg' 2161 pop (DbJnl) # Restore Journal 2162 null (DbJnl) # Any? 2163 if nz # Yes 2164 call unLockJnl # Unlock journal 2165 end 2166 ld A (hex "10000") # Length 1 2167 call rwUnlockDbA # Unlock 2168 dec (EnvProtect) # Unprotect 2169 pop Z 2170 pop Y 2171 pop X 2172 ret 2173 2174 # vi:et:ts=3:sw=3