home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / blink.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  27.8 KB  |  721 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. ;;; TBD:
  21.  
  22. ;;; allow different size blks for index and leaves.
  23. ;;; add multi-record operations
  24.  
  25. (require (in-vicinity (program-vicinity) "sys"))
  26.  
  27. ;;; BLK ACCESS AND MODIFICATION ROUTINES
  28.  
  29. (define (short2str! str pos cint)
  30.   (string-set! str (+ pos 1) (integer->char (remainder cint 256)))
  31.   (string-set! str (+ pos 0) (integer->char (quotient cint 256))))
  32.  
  33. (define (str2short str pos)
  34.   (+ (char->integer (string-ref str (+ pos 1)))
  35.      (* 256 (char->integer (string-ref str pos)))))
  36.  
  37. (define (long2str! str pos clong)
  38.   (string-set! str (+ pos 3) (integer->char (remainder clong 256)))
  39.   (string-set! str (+ pos 2) (integer->char (remainder (quotient clong 256) 256)))
  40.   (string-set! str (+ pos 1) (integer->char (remainder (quotient clong 65536) 256)))
  41.   (string-set! str (+ pos 0) (integer->char (quotient clong 16777216))))
  42.  
  43. (define (str2long str pos)
  44.   (+ (char->integer (string-ref str (+ pos 3)))
  45.      (* 256 (+ (char->integer (string-ref str (+ pos 2)))
  46.            (* 256 (+ (char->integer (string-ref str (+ pos 1)))
  47.              (* 256 (char->integer (string-ref str pos)))))))))
  48.  
  49. (define (set-field blk b-pos val-str f-pos f-len)
  50.   (SET-FIELD-LEN! blk b-pos f-len)
  51.   (substring-move! val-str f-pos (+ f-pos f-len) blk (+ 1 b-pos))
  52.   (+ f-len 1 b-pos))
  53.  
  54. (define LEAF-SPLIT-KEY-STR (string (integer->char 255) (integer->char LEAF)))
  55.  
  56. (define (init-leaf-blk! nblk bnum typ)
  57.   (string-set! nblk (- blk-size 1) #\newline)
  58.   (BLK-SET-ID! nblk bnum)
  59.   (BLK-SET-NXT-ID! nblk 0)
  60.   (BLK-SET-TOP-ID! nblk bnum)
  61.   (BLK-SET-TIME! nblk 0)
  62.   (BLK-SET-LEVEL! nblk LEAF)
  63.   (BLK-SET-TYP! nblk typ)
  64.   (SET-FIELD-LEN! nblk BLK-DATA-START 0)
  65.   (set-field nblk (+ BLK-DATA-START 1) LEAF-SPLIT-KEY-STR 0 2)
  66.   (BLK-SET-END! nblk (+ BLK-DATA-START (if (char=? typ SEQ-TYP) 0 4))))
  67.  
  68. ; RBLK= the root block, NBLK= new block to hold root's data, BNUM= its ID
  69.  
  70. (define (reroot! rblk nblk bnum bsiz)
  71.   (define rpos BLK-DATA-START)
  72. ;;;#|s|#  (fprintf diagout "REROOT: rblk=%d nblk=%d bnum=%d bsiz=%d rpos=%d\\n"
  73. ;;;#|s|#       (BLK-ID rblk) (BLK-ID nblk) bnum bsiz rpos)
  74.   (BLK-SET-ID! nblk bnum)
  75.   (substring-move! rblk 4 bsiz nblk 4)    ;copy whole block except ID
  76.   (BLK-SET-NXT-ID! rblk 0)        ;end of chain
  77.   (BLK-SET-LEVEL! rblk (+ (BLK-LEVEL rblk) 1))
  78.   (SET-FIELD-LEN! rblk rpos 0)
  79.   (set! rpos (set-field rblk (+ rpos 1) LEAF-SPLIT-KEY-STR 0 2))
  80.   (string-set! rblk (- rpos 1) (integer->char (- (BLK-LEVEL rblk) 1)))
  81.   (set! rpos (set-field rblk rpos nblk 0 4))
  82.   (SET-FIELD-LEN! rblk rpos 1)
  83.   (set! rpos (set-field rblk (+ rpos 1) LEAF-SPLIT-KEY-STR 0 1))
  84.   (string-set! rblk (- rpos 1) (integer->char (BLK-LEVEL rblk)))
  85.   (BLK-SET-END! rblk rpos))
  86.  
  87. (define (init-next-blk! blk nblk)
  88.   (string-set! nblk (- blk-size 1) #\newline)
  89. ;;  (BLK-SET-ID! nblk bnum)
  90.   (BLK-SET-NXT-ID! nblk (BLK-NXT-ID blk))
  91.   (BLK-SET-TOP-ID! nblk (BLK-TOP-ID blk))
  92.   (BLK-SET-LEVEL! nblk (BLK-LEVEL blk))
  93.   (BLK-SET-TYP! nblk (BLK-TYP blk))
  94.   (BLK-SET-NXT-ID! blk (BLK-ID nblk))
  95.   (SET-FIELD-LEN! nblk BLK-DATA-START 0)
  96.   (set-field nblk (+ BLK-DATA-START 1) "" 0 0)
  97.   (BLK-SET-END! nblk (+ BLK-DATA-START 2)))
  98.  
  99. (define (split-key-pos blk)
  100.   (define b-end (BLK-END blk))
  101.   (let lp ((b-pos BLK-DATA-START))
  102.     (let ((s-pos (next-field blk (+ 1 b-pos))))
  103.       (cond
  104.        ((= s-pos b-end) b-pos)
  105.        ((< s-pos b-end) (lp (next-cnvpair blk b-pos)))
  106.        (else
  107.     (fprintf diagout ">>>>ERROR<<<< split-key-pos: blk past end %d %d\\n"
  108.          (BLK-ID blk) s-pos)
  109.     #f)))))
  110.  
  111.  
  112. ;;; Pass in len  -1 to seek END-OF-CHAIN, -2 for START-OF-CHAIN
  113. ;;; If key-str = END-OF-CHAIN returns PASTEND @ split-pos.
  114. ;;; If key-str = START-OF-CHAIN returns QPASTP @ blk-data-start.
  115. ;;; Otherwise, can return any of 5 match conditions.
  116.  
  117. ;;; As we go through blk looking for key, KEY-POS (k-pos) is the number of
  118. ;;; characters matching between key and blk.
  119.  
  120. (define (blk-find-pos blk key-str k-len pkt)
  121.   (if
  122.    (< k-len 0)
  123.    (begin (if (= k-len END-OF-CHAIN)
  124.           (let ((skpos (split-key-pos blk)))
  125.         (PACK! pkt (if (END-OF-CHAIN? blk) QPASTP PASTEND)
  126.                skpos 0 (blk-prev-key blk skpos)))
  127.           (PACK! pkt QPASTP BLK-DATA-START 0 0))
  128.       #t)
  129.    (let ((k-pos 0) (b-end (BLK-END blk)))
  130.      (let chknxt ((b-pos BLK-DATA-START) (p-pos 0)) ;where we are looking in this blk
  131.        (cond
  132.     ((< (FIELD-LEN blk b-pos) k-pos) ;compress count is less than
  133.      (PACK! pkt QPASTP b-pos k-pos p-pos) #t) ;what already matched.
  134.     ((> (FIELD-LEN blk b-pos) k-pos) ;matched no more than last time
  135.      (let ((s-pos (next-field blk (+ b-pos 1))))
  136.        (cond
  137.         ((< s-pos b-end)
  138.          (chknxt (NEXT-CNVPAIR blk b-pos) b-pos))
  139.         ((= s-pos b-end)
  140.          (PACK! pkt PASTEND b-pos k-pos p-pos) #t)
  141.         (else
  142.          (fprintf diagout ">>>>ERROR<<<< blk-find-pos1: blk past end %d %d\\n"
  143.               (BLK-ID blk) s-pos)
  144.          #f))))
  145.     (else
  146.      (let mchlp ((i (+ b-pos 2)) (f-len (FIELD-LEN blk (+ b-pos 1))))
  147.        (cond
  148.         ((>= k-pos k-len)        ;end of key
  149.          (if
  150.           (> f-len 0)
  151.           (begin (PACK! pkt PASTP b-pos k-pos p-pos) #t) ;field is longer
  152.           (let ((s-pos (next-field blk (+ b-pos 1))))
  153.         (cond
  154.          ((< s-pos b-end)
  155.           (PACK! pkt MATCH b-pos k-len p-pos) #t)
  156.          ((= s-pos b-end)
  157.           (PACK! pkt MATCHEND b-pos k-pos p-pos) #t) ;reached the end; keys =
  158.          (else
  159.           (fprintf diagout ">>>>ERROR<<<< blk-find-pos2: blk past end %d %d\\n"
  160.                (BLK-ID blk) s-pos)
  161.           #f)))))
  162.         ((or (<= f-len 0)        ;field was shorter
  163.          (char<? (string-ref blk i) (string-ref key-str k-pos))) ;key is more
  164.          (let ((s-pos (next-field blk (+ b-pos 1))))
  165.            (cond
  166.         ((< s-pos b-end) (chknxt (NEXT-CNVPAIR blk b-pos) b-pos))
  167.         ((= s-pos b-end)
  168.          (PACK! pkt PASTEND b-pos k-pos p-pos) #t)
  169.         (else
  170.          (fprintf diagout ">>>>ERROR<<<< blk-find-pos3: blk past end %d %d\\n"
  171.               (BLK-ID blk) s-pos)
  172.          #f))))
  173.         ((char>? (string-ref blk i) (string-ref key-str k-pos))
  174.          (PACK! pkt (if (> k-pos (FIELD-LEN blk b-pos)) PASTP QPASTP) b-pos k-pos p-pos) #t)
  175.         (else (set! k-pos (+ k-pos 1)) ;matched a character
  176.           (mchlp (+ 1 i) (- f-len 1)))))))))))
  177.  
  178. ;;; Can return QPASTP or PASTP @ any key or MATCH at non-split key.
  179.  
  180. (define (chain-find ent access key-str k-len pkt)
  181.   (define blk (ENT-BLK ent))
  182.   ;;  (fprintf diagout "chain-find %d:%ld %d %.*s\\n"
  183.   ;;       (ENT-SEG ent) (ENT-ID ent) access (max 0 k-len) key-str)
  184.   (cond ((not (blk-find-pos blk key-str k-len pkt))
  185.      (release-ent! ent access) #f)
  186.     ;;failure case.  BLK-FIND-POS already gave error message
  187.     ((not (or (eq? (MATCH-TYPE pkt) MATCHEND)
  188.           (eq? (MATCH-TYPE pkt) PASTEND)))
  189.      ent)                ;If (Q)PASTP or MATCH.  Stop here.
  190.     ((END-OF-CHAIN? blk)
  191.      (fprintf diagout ">>>>ERROR<<<<chain-find: matched or past end of chain %d:%ld\\n"
  192.           (ENT-SEG ent) (ENT-ID ent))
  193.      (SET-MATCH-TYPE! pkt QPASTP)
  194.      ent)
  195.     (else
  196.      (set! chains-to-next (+ 1 chains-to-next))
  197.      (set! ent (switch-ent ent access (BLK-NXT-ID blk) access))
  198.      (and ent (chain-find ent access key-str k-len pkt)))))
  199.  
  200.  
  201. ;;; find-ent is always called with ent = (get-ent <seg> <blk-num> #f).
  202. ;;; TBD - These calls could be colapsed.
  203. ;; should be called with LAST-LEVEL=-1
  204.  
  205. (define (find-ent ent desired-level last-level key-str k-len)
  206.   (and
  207.    ent
  208.    (ent-update-access ent #f ACCREAD)
  209.    (let* ((blk (ENT-BLK ent))
  210.       (blvl (BLK-LEVEL blk)))
  211.      (cond
  212.       ((= blvl desired-level) ent)
  213.       ((< blvl desired-level)
  214.        (fprintf diagout ">>>>ERROR<<<< bad blk level %d (des=%d) in %d:%ld\\n"
  215.         blvl desired-level (ENT-SEG ent) (ENT-ID ent))
  216.        #f)
  217.       ((and (>= last-level 0) (not (= blvl (- last-level 1))))
  218.        (fprintf diagout ">>>>ERROR<<<< bad blk level %d last=%d in %d:%ld\\n"
  219.         blvl last-level (ENT-SEG ent) (ENT-ID ent))
  220.        #f)
  221.       (else
  222.        (let ((pkt (make-vector PKT-SIZE)))
  223.      (set! ent (chain-find ent ACCREAD key-str k-len pkt))
  224.      (and
  225.       ent
  226.       (let ((pos (next-field blk (+ 1 (MATCH-POS pkt)))))
  227.         (set! blk (ENT-BLK ent))
  228.         (case (MATCH-TYPE pkt)
  229.           ((QPASTP PASTP) #f)
  230.           ((MATCH)
  231.            (if (= (BLK-END blk) pos)
  232.            (set! pos (MATCH-POS pkt))
  233.            (set! pos (next-field blk pos))))
  234.           (else (set! pos #f)))
  235.         (cond (pos
  236.            (set! pos (next-field blk (+ 1 (MATCH-POS pkt))))
  237.            (find-ent
  238.             (switch-ent ent ACCREAD
  239.                 (if (= (BLK-END blk) pos)
  240.                     (if (END-OF-CHAIN? blk)
  241.                     (str2long blk (+ -6 pos))
  242.                     (BLK-NXT-ID blk))                    
  243.                     (str2long blk (+ 1 pos)))
  244.                 #f)
  245.             desired-level
  246.             (if (and (= (BLK-END blk) pos) (not (END-OF-CHAIN? blk)))
  247.             (+ (BLK-LEVEL blk) 1) (BLK-LEVEL blk))
  248.             key-str k-len))
  249.           (else
  250.            (fprintf diagout
  251.                 ">>>ERROR<<<< find-ent: bad-MATCH-TYPE %d blk %d:%ld\\n"
  252.                 (MATCH-POS pkt) (ENT-SEG ent) (ENT-ID ent))
  253.            #f))))))))))
  254.  
  255. (define (blk-prev-key blk pos)
  256.   (do ((b-pos BLK-DATA-START (NEXT-CNVPAIR blk b-pos))
  257.        (p-pos #f b-pos))
  258.       ((>= b-pos pos)
  259.        (cond ((> b-pos pos)
  260.           (fprintf diagout ">>>>ERROR<<<< blk-prev-key: blk past end %d %d\\n"
  261.                (BLK-ID blk) p-pos)
  262.           #f)
  263.          (else
  264. ;          (fprintf diagout "blk-prev-key %d %d returns %d\\n"
  265. ;               (BLK-ID blk) pos p-pos)
  266.           p-pos)))))
  267.  
  268. ;;;; DATA BASE OPERATIONS
  269.  
  270. (define (get-this-val blk b-pos ans-str)
  271.   (set! b-pos (next-field blk (+ b-pos 1)))
  272.   (let ((alen (FIELD-LEN blk b-pos)))
  273.     (substring-move! blk (+ b-pos 1) (+ b-pos 1 alen) ans-str 0)
  274.     alen))
  275.  
  276. (define (chain-next ent key-str k-len ans-str pkt)
  277.   (define (get-this-key blk b-pos)
  278.     (let ((b-end (BLK-END blk))
  279.       (s-pos (next-field blk (+ b-pos 1))))
  280.       (cond ((< s-pos b-end)
  281.          (let* ((f-pos (FIELD-LEN blk b-pos))
  282.             (f-siz (FIELD-LEN blk (+ b-pos 1)))
  283.             (alen (+ f-pos f-siz)))
  284.            (if (not (eq? key-str ans-str))
  285.            (substring-move! key-str 0 f-pos ans-str 0))
  286.            (substring-move! blk (+ b-pos 2) (+ b-pos 2 f-siz) ans-str f-pos)
  287.            (release-ent! ent ACCREAD)
  288.            alen))
  289.         ((not (= s-pos b-end))
  290.          (fprintf diagout ">>>>ERROR<<<< chain-next: blk past end %d %d\\n"
  291.               (BLK-ID blk) s-pos)
  292.          (release-ent! ent ACCREAD)
  293.          STRANGERR)
  294.         ((END-OF-CHAIN? blk)
  295.          (release-ent! ent ACCREAD) NOTPRES)
  296.         (else
  297.          (set! ent (switch-ent ent ACCREAD (BLK-NXT-ID blk) ACCREAD))
  298.          (if ent (set! ent (chain-find ent ACCREAD key-str k-len pkt)))
  299.          (if ent (chain-next ent key-str k-len ans-str pkt)
  300.          UNKERR)))))   ; TBDFIXED-- case where get-ent fails
  301.   (SET-BLK-TO-CACHE! pkt (ENT-ID ent))
  302.   (case (MATCH-TYPE pkt)
  303.     ((PASTP QPASTP)
  304.      (get-this-key (ENT-BLK ent) (MATCH-POS pkt)))
  305.     ((MATCH)
  306.      (get-this-key (ENT-BLK ent)
  307.            (NEXT-CNVPAIR (ENT-BLK ent) (MATCH-POS pkt))))
  308.     (else (release-ent! ent ACCREAD) NOTPRES)))
  309.  
  310. ;;; To shrink a block give growth less than 0 and location equals
  311. ;;; position after deleted.
  312. ;;; blk-change-size returns #f if not enough room
  313. (define (blk-change-size blk loc growth bsiz)
  314.   (define b-end (BLK-END blk))
  315.   (cond ((zero? growth) #t)
  316.     ((> (+ b-end growth) bsiz)    ; (if (END-OF-CHAIN? blk) (- bsiz 1) bsiz)
  317.      #f)
  318.     ((negative? growth)
  319.      (substring-move-left!
  320.       blk loc b-end blk (+ loc growth))
  321.      (BLK-SET-END! blk (+ b-end growth))
  322.      #t)
  323.     (else
  324.      (substring-move-right!
  325.       blk loc b-end blk (+ loc growth))
  326.      (BLK-SET-END! blk (+ b-end growth))
  327.      #t)))
  328.  
  329. (define (blk-remove-key-and-val blk b-pos bsiz)
  330.   (define nb-pos (NEXT-CNVPAIR blk b-pos))
  331.   (cond ((> (FIELD-LEN blk nb-pos) (FIELD-LEN blk b-pos))
  332.      (let ((delk-pos
  333.         (- (FIELD-LEN blk nb-pos) (FIELD-LEN blk b-pos))))
  334.        (SET-FIELD-LEN! blk (+ 1 b-pos)
  335.                (+ (FIELD-LEN blk (+ 1 nb-pos)) delk-pos))
  336.        (blk-change-size blk
  337.                 (+ 2 nb-pos)
  338.                 (+ (- b-pos nb-pos) delk-pos)
  339.                 bsiz)))
  340.     (else (blk-change-size blk nb-pos (- b-pos nb-pos) bsiz))))
  341.  
  342. ;;; return #t if operation was succsessful; #f if not
  343. ;;; Note the splitting of OBLK into OBLK+NBLK by inserting the split key of
  344. ;;; each block into parent.
  345. ;;; Note this routine does not check if the key(s) have already been
  346. ;;; (perhaps by another process) inserted into parent.
  347.  
  348. ; unfortunately, the right way to do this requires that the update look just like
  349. ; a PUT of the NKEY-STR with value N-ID, albeit one that then swaps the values
  350. ; of the new entry and the one following...
  351.  
  352. ; The SCREW-CASE occurs when the key is inserted at the endof the block, so that
  353. ; we have to get access to the next (NON-EMPTY!) block to make the swap...
  354.  
  355. (define defer-insert-updates #f)
  356.  
  357. (define (parent-insert-update seg top-id level nkey-str nk-len n-id)
  358.   (define pkt (make-vector PKT-SIZE))
  359. ;;;#|s|#  (fprintf diagout
  360. ;;;#|s|#       "parent-insert-update: nkey=%.*s n-id=%d nk-len=%d\\n"
  361. ;;;#|s|#       (max nk-len 0) nkey-str n-id nk-len)
  362.   (let* ((ent (find-ent (get-ent seg top-id #f) (+ 1 level) -1
  363.             nkey-str nk-len))
  364.      (xent #f)
  365.      (screw-case? #f)
  366.      (blkidstr (make-string 4))
  367.      (blk #f))
  368.     (and
  369.      ent
  370.      (begin
  371.       (long2str! blkidstr 0 n-id)
  372.       (cond ((ent-update-access ent ACCREAD ACCWRITE)
  373.          (set! ent (chain-find ent ACCWRITE nkey-str nk-len pkt))
  374.          (set! blk (ENT-BLK ent)))
  375.         (else (release-ent! ent ACCREAD)
  376.           (set! ent #f)))
  377.       (cond ((and ent (at-split-key-pos? blk (MATCH-POS pkt)))
  378.          (set! screw-case? #t)
  379.          (set! xent (next-nonempty-ent (ENT-SEG ent) (BLK-NXT-ID blk)))
  380.          (if (not xent)
  381.          (fprintf diagout ">>>>ERROR<<<< No next key found for index insert %d:%lu\\n"
  382.               (ENT-SEG ent) (BLK-ID blk)))))
  383.       (cond ((and (not defer-insert-updates)
  384.           ent
  385.           (or (not screw-case?) xent)
  386.           (chain-put ent nkey-str nk-len blkidstr 4 pkt xent WCB-SAR))  ; last arg is new
  387.          #t)
  388.         (else
  389.          (fprintf diagout "WARNING p-i-u: couldn't update parent n-id=%d nk-len=%d\\n"
  390.               n-id nk-len)
  391.          (set! deferred-inserts (+ 1 deferred-inserts))
  392.          (if ent (release-ent! ent ACCWRITE))
  393.          #f))))))
  394.  
  395. (define (at-split-key-pos? blk pos)   ; only valid if called with POS=position of some KEY
  396.   (= (BLK-END blk)  (next-field blk (+ 1 pos))))
  397.  
  398. (define (next-nonempty-ent seg blknum)
  399. ;;;#|c|#  (fprintf diagout "next-nonempty-ent blknum=%d:%d\\n" seg blknum)
  400.   (cond
  401.    ((<= blknum 0) #f)
  402.    (else
  403.     (let loop ((xent (get-ent seg blknum ACCREAD)))
  404.       (and xent (ent-update-access xent ACCREAD ACCWRITE))
  405.       (cond ((not xent) #f)
  406.         ((not (blk-empty? (ENT-BLK xent))) xent)
  407.         ((zero? (BLK-NXT-ID (ENT-BLK xent)))
  408.          (release-ent! xent ACCWRITE)
  409.          #f)
  410.         (else
  411.          (loop (switch-ent xent ACCWRITE (BLK-NXT-ID (ENT-BLK xent)) ACCWRITE))))))))
  412.  
  413. ;; Note: CFP must NOT return the split key position IFF at a LEAF
  414. ;; RECON-THIS-KEY returns the data in KEY and its length as its return value.
  415. ;; END-OF-CHAIN (-1) is returned if the key reconstructed is the end-of-file mark
  416. ;; k-len is now used correctly to signal n potential overflow
  417.  
  418. (define (recon-this-key blk pos key-str k-pos k-len)
  419. ;  (fprintf diagout "recon-this-key blk=%d pos=%d %d %d\\n"
  420. ;       (blk-id blk) pos k-pos k-len)
  421.   (do ((b-pos BLK-DATA-START)
  422.        (k-size 0))
  423.       ((> b-pos pos)
  424. ;       (fprintf diagout "recon-this-key returned: %d\\n" k-size)
  425.        k-size)
  426.     (if (and
  427.      (> k-size (field-len blk b-pos))
  428.      (char<=? (string-ref blk (+ b-pos 2))
  429.           (string-ref key-str (+ k-pos (field-len blk b-pos)))))
  430.     (fprintf diagout ">>>>ERROR<<<< bad key sequence %ld @ %d\\n"
  431.          (BLK-ID blk) b-pos))
  432.     (set! k-size (+ (field-len blk b-pos) (field-len blk (+ 1 b-pos))))
  433.     (if (>= k-size k-len)
  434.     (fprintf diagout ">>>>ERROR<<<< not-enough-room %d\\n" k-len))
  435.     (substring-move! blk (+ b-pos 2)
  436.              (+ b-pos 2 (field-len blk (+ 1 b-pos)))
  437.              key-str (+ k-pos (field-len blk b-pos)))
  438. ;    (fprintf diagout "recon-this-key at-pos %d key= %.*s size= %d\\n"
  439. ;         b-pos (+ k-pos k-size) key-str k-size)
  440.     (set! b-pos (next-field blk (+ 1 b-pos)))
  441.     (if (< b-pos (blk-end blk)) (set! b-pos (next-field blk b-pos)))))
  442.  
  443. (define (insert-and-adjust blk b-pos k-pos key-str k-len val-str v-len bsiz)
  444. ;  (fprintf diagout "insert-and-adjust %d %d\\n" b-pos k-pos)
  445.   (let* ((oldk-pos (FIELD-LEN blk b-pos)) ;rep count
  446.      (oldilen (FIELD-LEN blk (+ 1 b-pos)))
  447.      (ilen (- k-len oldk-pos)))
  448.     (cond ((blk-change-size blk b-pos (+ 2 (- k-len k-pos) 1 v-len) bsiz)
  449. ;;;       (SET-FIELD-LEN! blk b-pos oldk-pos)
  450.        (set! b-pos (+ 1 b-pos))
  451.        (set! b-pos (set-field blk b-pos key-str oldk-pos ilen))
  452.        (set! b-pos (set-field blk b-pos val-str 0 v-len))
  453.        (SET-FIELD-LEN! blk b-pos k-pos)
  454.        (SET-FIELD-LEN! blk (+ b-pos 1) (- oldilen (- k-pos oldk-pos)))
  455.        #t)
  456.       (else #f))))
  457.  
  458. (define (simple-insert blk b-pos k-pos key-str k-len val-str v-len bsiz)
  459.   (define ilen (- k-len k-pos))
  460. ;  (fprintf diagout "simple-insert %d %d\\n" b-pos k-pos)
  461.   (cond ((blk-change-size blk b-pos (+ 3 v-len ilen) bsiz)
  462.      (SET-FIELD-LEN! blk b-pos k-pos)
  463.      (set! b-pos (+ 1 b-pos))
  464.      (set! b-pos (set-field blk b-pos key-str k-pos ilen))
  465.      (set-field blk b-pos val-str 0 v-len)
  466.      #t)
  467.     (else #f)))
  468.  
  469. (define (change-existing-value blk b-pos key-str k-len val-str v-len bsiz)
  470.   (define ov-len 0)
  471.   (define v-pos (next-field blk (+ 1 b-pos)))
  472.   (set! ov-len (FIELD-LEN blk v-pos))
  473. ;  (fprintf diagout "change-existing-value %d %d %d %d\\n"
  474. ;       b-pos v-pos ov-len v-len)
  475.   (cond ((blk-change-size blk (+ v-pos ov-len 1) (- v-len ov-len) bsiz)
  476.      (set-field blk v-pos val-str 0 v-len)
  477.      #t)
  478.     (else #f)))
  479.  
  480. ;;; leaf-splits are called with ACCWRITE on blk and return without it.
  481. (define (val-leaf-split blk nblk b-pos key-str k-pos k-len val-str v-len)
  482. ;;;#|s|#  (fprintf diagout "val-leaf-split %d %d %.*s %.*s\\n"
  483. ;;;#|s|#       (BLK-ID blk) b-pos (+ k-pos k-len) key-str v-len val-str)
  484.   (let* ((v-pos (next-field blk (+ 1 b-pos)))
  485.      (s-pos (next-field blk v-pos))
  486.      (b-end (BLK-END blk)))
  487.     (SET-FIELD-LEN! nblk BLK-DATA-START 0)
  488.     (if (> (- b-end s-pos) (- v-pos BLK-DATA-START))
  489.     (let ((m-len (FIELD-LEN blk s-pos)) ;more room before v-pos
  490.           (f-chr (string-ref blk (+ s-pos 2))))
  491. ;;;#|s|#      (fprintf diagout "more room before v-pos\\n")
  492.       (SET-FIELD-LEN! nblk (+ BLK-DATA-START 1)
  493.               (+ m-len (FIELD-LEN blk (+ 1 s-pos))))
  494.       (substring-move! key-str 0 m-len nblk (+ BLK-DATA-START 2))
  495.       (substring-move! blk (+ s-pos 2) b-end
  496.                nblk (+ BLK-DATA-START m-len 2))
  497.       (BLK-SET-END! nblk (+ (- b-end s-pos) m-len BLK-DATA-START))
  498.  
  499.       (set! b-pos (set-field blk v-pos val-str 0 v-len))
  500.       (string-set! blk (+ b-pos 2) f-chr)
  501.       (SET-FIELD-LEN! blk b-pos m-len))
  502.     (let ((nb-pos (+ BLK-DATA-START 1))) ;more room after s-pos
  503. ;;;#|s|#      (fprintf diagout "more room after s-pos\\n")
  504.       (set! nb-pos (set-field nblk nb-pos key-str 0 k-len))
  505.       (set! nb-pos (set-field nblk nb-pos val-str 0 v-len))
  506.       (substring-move! blk s-pos b-end nblk nb-pos)
  507.       (BLK-SET-END! nblk (+ nb-pos (- b-end s-pos)))
  508.       ))
  509.     (SET-FIELD-LEN! blk (+ b-pos 1) 1)
  510.     (BLK-SET-END! blk (+ b-pos 3))
  511.     b-pos))
  512.  
  513. (define (qpastp-leaf-split blk nblk b-pos key-str k-pos k-len val-str v-len)
  514. ;;;#|s|#  (fprintf diagout "qpastp-leaf-split %d %d %.*s %.*s\\n"
  515. ;;;#|s|#       (BLK-ID blk) b-pos (+ k-pos k-len) key-str v-len val-str)
  516.   (let* ((b-end (BLK-END blk)))
  517.     (SET-FIELD-LEN! nblk BLK-DATA-START 0)
  518.     (if (> (- b-end b-pos) (- b-pos BLK-DATA-START))
  519.     (let ((m-len (FIELD-LEN blk b-pos)) ;more room before b-pos
  520.           (f-chr (string-ref blk (+ b-pos 2))))
  521. ;;;#|s|#      (fprintf diagout "more room before b-pos\\n")
  522.       (SET-FIELD-LEN! nblk (+ BLK-DATA-START 1)
  523.               (+ m-len (FIELD-LEN blk (+ 1 b-pos))))
  524.       (substring-move! key-str 0  m-len nblk (+ BLK-DATA-START 2))
  525.       (substring-move! blk (+ b-pos 2) b-end
  526.                nblk (+ BLK-DATA-START m-len 2))
  527.       (BLK-SET-END! nblk (+ (- b-end b-pos) m-len BLK-DATA-START))
  528.  
  529.       (SET-FIELD-LEN! blk b-pos k-pos)
  530.       (set! b-pos (set-field blk (+ b-pos 1) key-str k-pos (- k-len k-pos)))
  531.       (set! b-pos (set-field blk b-pos val-str 0 v-len))
  532.       (string-set! blk (+ b-pos 2) f-chr)
  533.       (SET-FIELD-LEN! blk b-pos m-len))
  534.     (let ((nb-pos (+ BLK-DATA-START 1))) ;more room after b-pos
  535. ;;;#|s|#      (fprintf diagout "more room after b-pos\\n")
  536.       (set! nb-pos (set-field nblk nb-pos key-str 0 k-len))
  537.       (set! nb-pos (set-field nblk nb-pos val-str 0 v-len))
  538.       (substring-move! blk b-pos b-end nblk nb-pos)
  539.       (BLK-SET-END! nblk (+ nb-pos (- b-end b-pos)))
  540.       (SET-FIELD-LEN! blk b-pos k-pos)
  541.       (string-set! blk (+ b-pos 2) (string-ref key-str k-pos))))
  542.     (SET-FIELD-LEN! blk (+ b-pos 1) 1)
  543.     (BLK-SET-END! blk (+ b-pos 3))
  544.     b-pos))
  545.  
  546. (define (pastp-leaf-split blk nblk b-pos key-str k-pos k-len val-str v-len)
  547. ;;;#|s|#  (fprintf diagout "pastp-leaf-split %d %d %.*s %.*s\\n"
  548. ;;;#|s|#       (BLK-ID blk) b-pos (+ k-pos k-len) key-str v-len val-str)
  549.   (let ((m-len (FIELD-LEN blk b-pos))
  550.     (b-end (BLK-END blk)))
  551.     (SET-FIELD-LEN! nblk BLK-DATA-START 0)
  552.     (if (> (- b-end b-pos)
  553.        (- b-pos BLK-DATA-START))
  554.     (let ((f-chr (string-ref blk (+ b-pos 2 (- k-pos (FIELD-LEN blk b-pos))))))
  555. ;;;#|s|#      (fprintf diagout "more room before b-pos\\n") ;fixes "xxx2" bug
  556.       (SET-FIELD-LEN! nblk (+ BLK-DATA-START 1)
  557.               (+ m-len (FIELD-LEN blk (+ 1 b-pos))))
  558.       (substring-move! key-str 0 m-len nblk (+ BLK-DATA-START 2))
  559.       (substring-move! blk (+ b-pos 2) b-end
  560.                nblk (+ BLK-DATA-START m-len 2))
  561.       (BLK-SET-END! nblk (+ (- b-end b-pos) m-len BLK-DATA-START))
  562.  
  563.       (SET-FIELD-LEN! blk b-pos m-len)
  564.       (set! b-pos (set-field blk (+ b-pos 1) key-str m-len (- k-len m-len)))
  565.       (set! b-pos (set-field blk b-pos val-str 0 v-len))
  566.       (string-set! blk (+ b-pos 2) f-chr) ;truncated split key
  567.       (SET-FIELD-LEN! blk b-pos k-pos)) ;match count
  568.     (let ((nb-pos (+ BLK-DATA-START 1)) ;more room after b-pos
  569.           (c-pos (+ b-pos 2 (- k-pos m-len))))
  570. ;;;#|s|#      (fprintf diagout "more room after b-pos\\n")
  571.       (set! nb-pos (set-field nblk nb-pos key-str 0 k-len))
  572.       (set! nb-pos (set-field nblk nb-pos val-str 0 v-len))
  573.       (SET-FIELD-LEN! nblk nb-pos k-pos)
  574.       (SET-FIELD-LEN! nblk (+ nb-pos 1)
  575.               (- (+ (FIELD-LEN blk (+ 1 b-pos)) m-len) k-pos))
  576.       (substring-move! blk c-pos b-end nblk (+ nb-pos 2))
  577.       (BLK-SET-END! nblk (+ nb-pos 2 (- b-end c-pos)))
  578. ;;;      (string-set! blk (+ b-pos 2) f-chr) ;fixed "81" bug
  579. ;;;      (SET-FIELD-LEN! blk b-pos m-len)
  580.       ))
  581.     (SET-FIELD-LEN! blk (+ b-pos 1) 1)
  582.     (BLK-SET-END! blk (+ b-pos 3))
  583.     b-pos))
  584.  
  585. (define (dummy-leaf-split blk nblk b-pos key-str k-pos k-len val-str v-len)
  586.   (fprintf diagout ">>>ERROR<<<< leaf-split: bad-MATCH-TYPE blk %d\\n"
  587.        (BLK-ID blk))
  588.   #f)
  589.  
  590. (define (select-split-fun type)
  591.   (case type
  592.     ((PASTP)  pastp-leaf-split)
  593.     ((QPASTP) qpastp-leaf-split)
  594.     ((MATCH)  val-leaf-split)
  595.     (else dummy-leaf-split)))
  596.  
  597. (define (chain-put ent key-str k-len val-str v-len pkt xent wcb)
  598. ;;;#|c|#  (fprintf diagout "chain-put %d:%ld key=%.*s val=%.*s\\n"
  599. ;;;#|c|#       (ENT-SEG ent) (ENT-ID ent) (max k-len 0) key-str v-len val-str)
  600.   (let* ((blk (ENT-BLK ent))
  601.      (blklev (BLK-LEVEL blk))
  602.      (index? (> blklev LEAF))
  603.      (root-id (BLK-TOP-ID blk))
  604.      (nent #f)
  605.      (nrent #f)
  606.      (seg (ENT-SEG ent))
  607.      (bsiz (SEG-BSIZ seg))
  608.      (result #f)
  609.      (split? #f)
  610.      (nkey-ent ent)
  611.      (nkey-pos (MATCH-POS pkt))
  612.      (okey-ent ent)
  613.      (okey-pos BLK-DATA-START)
  614.      (n-id 0)
  615.      (s-pos 0)
  616.      (split-str (make-string 256))
  617.      (s-len 0))
  618.     (SET-BLK-TO-CACHE! pkt (ENT-ID ent))
  619.     (cond
  620.      ((and (eq? (MATCH-TYPE pkt) PASTP)
  621.        (insert-and-adjust blk (MATCH-POS pkt) (KEY-POS pkt)
  622.                   key-str k-len val-str v-len bsiz))
  623.       (set! result #t))
  624.      ((and (eq? (MATCH-TYPE pkt) QPASTP)
  625.        (simple-insert blk (MATCH-POS pkt) (KEY-POS pkt)
  626.               key-str k-len val-str v-len bsiz))
  627.       (set! result #t))
  628.      ((and (eq? (MATCH-TYPE pkt) MATCH)
  629.        (change-existing-value blk (MATCH-POS pkt)
  630.                   key-str k-len val-str v-len bsiz))
  631.       (set! result #t))
  632.      ((begin (set! nent (create-new-blk-ent seg))
  633.          (not nent))
  634.       (set! result #f))
  635.      (else
  636.       (set! split? #t)
  637.       (let* ((nblk (ENT-BLK nent)))
  638.     (set! n-id (ENT-ID nent))
  639.     (init-next-blk! blk nblk)
  640.     (set! block-splits (+ block-splits 1))
  641.     ;;S-POS is new pos of split key in old block
  642.     (set! s-pos ((select-split-fun (MATCH-TYPE pkt))
  643.              blk nblk (MATCH-POS pkt)
  644.              key-str (KEY-POS pkt) k-len val-str v-len))
  645.     (set! s-len (+ 1 (FIELD-LEN blk s-pos)))
  646.     (substring-move! nblk (+ BLK-DATA-START 2)
  647.              (+ 1 (FIELD-LEN blk s-pos)
  648.                 (+ BLK-DATA-START 2))
  649.              split-str 0)
  650.     (cond (index?            ; set up special info needed for index inserts
  651.            (set! okey-ent nent)
  652.            (cond ((not (= (MATCH-POS pkt) s-pos)) ;insert-in-old-blk? ("SPLIT CASE 1")
  653.                     ; need: okey-ent=nent, pos=BDS, nkey-ent=ent, pos=MATCH-POS
  654.               (set! split-index-inserts (+ 1 split-index-inserts)))
  655.              (else        ; more room after BPOS! ("SPLIT CASE 0")
  656.               (set! okey-pos (NEXT-CNVPAIR nblk BLK-DATA-START))
  657.               (set! nkey-ent nent)
  658.               (set! nkey-pos BLK-DATA-START)
  659.               ))))
  660.     (if (= (MATCH-POS pkt) s-pos) (SET-BLK-TO-CACHE! pkt (ENT-ID nent)))
  661.     (if (ROOT? blk)
  662.         (begin
  663.           (set! nrent (create-new-blk-ent seg))
  664.           (cond (nrent
  665.              (reroot! blk (ENT-BLK nrent) (ENT-ID nrent) (SEG-BSIZ seg))
  666.              (cond ((eq? nkey-ent ent)
  667.                 (set! nkey-ent nrent)
  668.                 (SET-BLK-TO-CACHE! pkt (ENT-ID nrent))))
  669.              ))))
  670.     (set! result #t))))
  671.  
  672.     (cond ((and result index?)        ; special code for index update
  673.        (cond (xent            ; check for the screw case!
  674. ;;;#|c|#  (fprintf diagout "chain-put/SPECIAL CASE: %d:%ld %.*s %.*s\\n"
  675. ;;;#|c|#       (ENT-SEG ent) (ENT-ID ent) (max k-len 0) key-str v-len val-str)
  676.           (set! index-screw-case (+ 1 index-screw-case ))
  677.           (set! okey-ent xent)
  678.           (set! okey-pos BLK-DATA-START))
  679.          ((not split?)
  680.           (set! okey-pos (NEXT-CNVPAIR blk (MATCH-POS pkt)))))
  681.  
  682. ;;;#|c|#  (fprintf diagout "chain-put/INDEX FIX: ent= %d:%ld nent= %d:%ld xent= %d:%ld newkey@%d pos %d oldkey@%d pos %d.\\n"
  683. ;;;#|c|#       (ENT-SEG ent) (ENT-ID ent) (ENT-SEG ent) (if nent (ENT-ID nent) -1) (ENT-SEG ent) (if xent (ENT-ID xent) -1)
  684. ;;;#|c|#      (ENT-ID nkey-ent) nkey-pos (ENT-ID okey-ent) okey-pos )
  685.        (let ((tmpstr (make-string 4)) ; swap pointers
  686.          (oldv-pos (+ (NEXT-FIELD (ENT-BLK okey-ent) (+ okey-pos 1)) 1))
  687.          (newv-pos (+ (NEXT-FIELD (ENT-BLK nkey-ent) (+ nkey-pos 1)) 1)))
  688. ;;;#|c|#   (fprintf diagout "   newvpos=%d oldvpos=%d; match-pos=%d s-pos=%d nrent= %d:%ld SPLIT-CASE=%d\\n"
  689. ;;;#|c|#            newv-pos oldv-pos (MATCH-POS pkt) s-pos (ENT-SEG ent) (if nrent (ENT-ID nrent) -1) (if (eq? okey-ent nkey-ent) 0 1))
  690.          (substring-move-left! (ENT-BLK okey-ent) oldv-pos (+ oldv-pos 4) tmpstr 0)
  691.          (substring-move-left! (ENT-BLK nkey-ent) newv-pos (+ newv-pos 4) (ENT-BLK okey-ent) oldv-pos)
  692.          (substring-move-left! tmpstr 0 4 (ENT-BLK nkey-ent) newv-pos)) ))
  693.  
  694.     ;; at this point: ENT=original block; NENT=neww blk created if ENT split;
  695.     ;;                NRENT=blk created to replace ENT, iff ENT split and ROOT;
  696.     ;;                XENT=NEXT(original ENT) iff insert-screw-case occurred
  697.     (cond (nrent
  698.        (ENT-SET-DTY! nrent #t)
  699.        (ent-write nrent)
  700.        (release-ent! nrent ACCWRITE)))
  701.     (cond (nent
  702.        (ENT-SET-DTY! nent #t)
  703.        (ent-write nent)
  704.        (ent-update-access nent ACCWRITE #f))) ;to prevent delete of this block while updating parent.
  705.     (cond (result
  706.        (ENT-SET-DTY! ent #t)
  707. ;;;       (fprintf diagout "CHAIN-PUT: blk=%d split=%d xent=%d SAP=%d\\n"
  708. ;;;            (BLK-ID (ENT-BLK ent)) split? xent (WCB-SAP? wcb))
  709.        (if (or split? xent (WCB-SAP? wcb))
  710.            (ent-write ent))
  711.        (release-ent! ent ACCWRITE)))
  712.     (cond (xent
  713.        (ENT-SET-DTY! xent #t)
  714.        (ent-write xent)
  715.        (release-ent! xent ACCWRITE)))
  716.  
  717.     ;;SPLIT? can happen only if RESULT is #t
  718.     (if split? (parent-insert-update seg root-id blklev split-str s-len n-id))
  719.     (if nent (release-ent! nent #f))    ;Ok to delete this block now.
  720.     result))
  721.