(define (dg-relation-internal-delete-label->left label->left id-label id-left) (status-t MDB-cursor* dg-id-t dg-id-t) dg-mdb-introduce-val-id dg-mdb-introduce-val-id-2 status-init (struct-set val-id mv-data (address-of id-label)) (struct-set val-id-2 mv-data (address-of id-left)) (dg-mdb-cursor-get! label->left val-id val-id-2 MDB-GET-BOTH) (if dg-mdb-status-success? (begin (dg-mdb-cursor-del! label->left 0) dg-mdb-status-require) dg-mdb-status-require-notfound) (status-set-id status-id-success) (label exit (return status))) (define (dg-relation-internal-delete-label->left-conditional left->right label->left id-label id-left) (status-t MDB-cursor* MDB-cursor* dg-id-t dg-id-t) status-init dg-mdb-introduce-val-relation-key (dg-define-relation-key relation-key) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-null MDB-SET) (if (status-id-is? MDB-NOTFOUND) (return (dg-relation-internal-delete-label->left label->left id-label id-left)) dg-mdb-status-require) (label exit (return status))) (define (dg-relation-internal-delete-right->left right->left id-left id-right id-label) (status-t MDB-cursor* dg-id-t dg-id-t dg-id-t) status-init dg-mdb-introduce-val-relation-key dg-mdb-introduce-val-id (dg-define-relation-key relation-key) (array-set-index relation-key 0 id-right 1 id-label) (struct-set val-relation-key mv-data relation-key) (struct-set val-id mv-data (address-of id-left)) (dg-mdb-cursor-get! right->left val-relation-key val-id MDB-GET-BOTH) (if dg-mdb-status-success? (begin (dg-mdb-cursor-del! right->left 0) dg-mdb-status-require) dg-mdb-status-require-notfound) (label exit (return status))) (pre-define (dg-relation-internal-delete-0010) (define id-label dg-id-t id-left dg-id-t) (label set-key-0010 (set id-label (dg-ids-first label)) (struct-set val-id mv-data (address-of id-label)) (dg-mdb-cursor-get! label->left val-id val-id-2 MDB-SET-KEY) (if dg-mdb-status-success? (goto each-data-0010) dg-mdb-status-require-notfound) (label each-key-0010 (set label (dg-ids-rest label)) (if label (goto set-key-0010) (goto exit)))) (label each-data-0010 (set id-left (dg-mdb-val->id val-id-2)) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) (if dg-mdb-status-success? (label each-data-2-0010 (set status (dg-relation-internal-delete-right->left right->left id-left (dg-mdb-val-relation-data->id val-relation-data) id-label)) dg-mdb-status-require-read (dg-mdb-cursor-del! left->right 0) dg-mdb-status-require (dg-mdb-cursor-next-dup! left->right val-relation-key val-relation-data) (if dg-mdb-status-success? (goto each-data-2-0010) dg-mdb-status-require-notfound)) dg-mdb-status-require-notfound) (dg-mdb-cursor-del! label->left 0) dg-mdb-status-require (dg-mdb-cursor-next-dup! label->left val-id val-id-2) (if dg-mdb-status-success? (goto each-data-0010) dg-mdb-status-require-notfound) (goto each-key-0010))) (pre-define (dg-relation-internal-delete-0110) (define id-right dg-id-t id-left dg-id-t id-label dg-id-t) (define right-pointer dg-ids-t* right) (label set-key-0110 (set id-right (dg-ids-first right-pointer) id-label (dg-ids-first label)) (array-set-index relation-key 0 id-right 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! right->left val-relation-key val-id MDB-SET-KEY) (if dg-mdb-status-success? (goto each-data-0110) dg-mdb-status-require-notfound) (label each-key-0110 (set right-pointer (dg-ids-rest right-pointer)) (if right-pointer (goto set-key-0110) (begin (set label (dg-ids-rest label)) (if label (begin (set right-pointer right) (goto set-key-0110)) (goto exit)))))) (label each-data-0110 (set id-left (dg-mdb-val->id val-id)) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) (if dg-mdb-status-success? (begin (set status (dg-mdb-left->right-seek-right left->right id-right)) (if dg-mdb-status-success? (begin (dg-mdb-cursor-del! left->right 0) dg-mdb-status-require) dg-mdb-status-require-notfound)) dg-mdb-status-require-notfound) (set status (dg-relation-internal-delete-label->left label->left id-label id-left)) dg-mdb-status-require-read (dg-mdb-cursor-del! right->left 0) dg-mdb-status-require (dg-mdb-cursor-next-dup! right->left val-relation-key val-id) (if dg-mdb-status-success? (goto each-data-0110) dg-mdb-status-require-notfound)) (goto each-key-0110)) (pre-define (dg-relation-internal-delete-1010) (define id-label dg-id-t id-left dg-id-t label-pointer dg-ids-t*) (while left (set id-left (dg-ids-first left)) (set label-pointer label) (while label-pointer (set id-label (dg-ids-first label-pointer)) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) (if dg-mdb-status-success? (begin (do-while dg-mdb-status-success? (dg-relation-internal-delete-right->left right->left id-left (dg-mdb-val-relation-data->id val-relation-data) id-label) (dg-relation-internal-delete-label->left label->left id-label id-left) (dg-mdb-cursor-next-dup! left->right val-relation-key val-relation-data)) dg-mdb-status-require-notfound (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) dg-mdb-status-require (dg-mdb-cursor-del! left->right MDB-NODUPDATA) dg-mdb-status-require) dg-mdb-status-require-notfound) (set label-pointer (dg-ids-rest label-pointer))) (set left (dg-ids-rest left)))) (pre-define (dg-relation-internal-delete-0100) (define id-left dg-id-t id-right dg-id-t id-label dg-id-t) (label set-range-0100 (set id-right (dg-ids-first right)) (array-set-index relation-key 0 id-right 1 0) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! right->left val-relation-key val-id MDB-SET-RANGE) (if dg-mdb-status-success? (if (= id-right (dg-mdb-val->id-at val-relation-key 0)) (begin (if dg-mdb-status-success? (begin)) (set id-label (dg-mdb-val->id-at val-relation-key 1)) (goto each-data-0100))) dg-mdb-status-require-notfound) (set right (dg-ids-rest right)) (if right (goto set-range-0100) (goto exit))) (label each-data-0100 (set id-left (dg-mdb-val->id val-id)) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) (if dg-mdb-status-success? (begin (set status (dg-mdb-left->right-seek-right left->right id-right)) (if dg-mdb-status-success? (begin (dg-mdb-cursor-del! left->right 0) dg-mdb-status-require) dg-mdb-status-require-notfound)) dg-mdb-status-require-notfound) (status-require! (dg-relation-internal-delete-label->left-conditional left->right label->left id-label id-left)) (dg-mdb-cursor-del! right->left 0) dg-mdb-status-require (dg-mdb-cursor-next-dup! right->left val-relation-key val-id) (if dg-mdb-status-success? (goto each-data-0100) dg-mdb-status-require-notfound)) (goto set-range-0100)) (pre-define (dg-relation-internal-delete-1000) (define id-left dg-id-t id-label dg-id-t id-right dg-id-t) (label set-range-1000 (set id-left (dg-ids-first left)) (array-set-index relation-key 0 id-left 1 0) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-RANGE) (label each-key-1000 (if dg-mdb-status-success? (if (= id-left (dg-mdb-val->id-at val-relation-key 0)) (begin (set id-label (dg-mdb-val->id-at val-relation-key 1)) (goto each-data-1000))) dg-mdb-status-require-notfound) (set left (dg-ids-rest left)) (if left (goto set-range-1000) (goto exit)))) (label each-data-1000 (set id-right (dg-mdb-val-relation-data->id val-relation-data)) (dg-relation-internal-delete-right->left right->left id-left id-right id-label) (dg-relation-internal-delete-label->left label->left id-label id-left) (dg-mdb-cursor-next-dup! left->right val-relation-key val-relation-data) (if dg-mdb-status-success? (goto each-data-1000) dg-mdb-status-require-notfound)) (array-set-index relation-key 0 id-left 1 id-label) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) dg-mdb-status-require (dg-mdb-cursor-del! left->right MDB-NODUPDATA) dg-mdb-status-require (dg-mdb-cursor-next-nodup! left->right val-relation-key val-relation-data) (goto each-key-1000)) (pre-define (dg-relation-internal-delete-1100) (define id-left dg-id-t id-right dg-id-t id-label dg-id-t right-set imht-set-t*) (status-require! (dg-ids->set right (address-of right-set))) (array-set-index relation-key 1 0) (label set-range-1100 (set id-left (dg-ids-first left)) (array-set-index relation-key 0 id-left) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-RANGE) (label each-key-1100 (if dg-mdb-status-success? (if (= id-left (dg-mdb-val->id-at val-relation-key 0)) (begin (set id-label (dg-mdb-val->id-at val-relation-key 1)) (goto each-data-1100))) dg-mdb-status-require-notfound) (set left (dg-ids-rest left)) (if left (begin (array-set-index relation-key 1 0) (goto set-range-1100)) (goto exit)))) (label each-data-1100 (set id-right (dg-mdb-val-relation-data->id val-relation-data)) (if (imht-set-contains? right-set id-right) (begin (dg-relation-internal-delete-right->left right->left id-left id-right id-label) (dg-mdb-cursor-del! left->right 0) dg-mdb-status-require)) (dg-mdb-cursor-next-dup! left->right val-relation-key val-relation-data) (if dg-mdb-status-success? (goto each-data-1100) dg-mdb-status-require-notfound)) (status-require! (dg-relation-internal-delete-label->left-conditional left->right label->left id-label id-left)) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) (cond (dg-mdb-status-success? (dg-mdb-cursor-next-nodup! left->right val-relation-key val-relation-data) (goto each-key-1100)) ((status-id-is? MDB-NOTFOUND) (goto set-range-1100)) (else (status-set-group-goto dg-status-group-lmdb)))) (pre-define (dg-relation-internal-delete-1110) (define id-left dg-id-t id-label dg-id-t right-set imht-set-t* id-right dg-id-t) (define label-first dg-ids-t* label) (status-require! (dg-ids->set right (address-of right-set))) (while left (set id-left (dg-ids-first left)) (while label (set id-label (dg-ids-first label)) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) (while dg-mdb-status-success? (if (imht-set-contains? right-set (dg-mdb-val-relation-data->id val-relation-data)) (begin (set id-right (dg-mdb-val-relation-data->id val-relation-data)) (dg-relation-internal-delete-right->left right->left id-left id-right id-label) (begin (dg-mdb-cursor-del! left->right 0) dg-mdb-status-require))) (dg-mdb-cursor-next-dup! left->right val-relation-key val-relation-data)) (dg-relation-internal-delete-label->left-conditional left->right label->left id-label id-left) (set label (dg-ids-rest label))) (set label label-first) (set left (dg-ids-rest left)))) (pre-define (dg-relation-internal-delete-get-ordinal-data ordinal) (define ordinal-min dg-ordinal-t (struct-pointer-get ordinal min)) (define ordinal-max dg-ordinal-t (struct-pointer-get ordinal max))) (pre-define (dg-relation-internal-delete-1001-1101) (define id-left dg-id-t id-right dg-id-t id-label dg-id-t right-set imht-set-t*) (dg-relation-internal-delete-get-ordinal-data ordinal) (array-set-index relation-data 0 ordinal-min) (array-set-index relation-key 1 0) (if right (status-require! (dg-ids->set right (address-of right-set)))) (label set-range-1001-1101 (set id-left (dg-ids-first left)) (array-set-index relation-key 0 id-left) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-RANGE) (label each-key-1001-1101 (if dg-mdb-status-success? (if (= id-left (dg-mdb-val->id-at val-relation-key 0)) (begin (struct-set val-relation-data mv-data relation-data) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-GET-BOTH-RANGE) (if dg-mdb-status-success? (begin (set id-label (dg-mdb-val->id-at val-relation-key 1)) (goto each-data-1001-1101)) dg-mdb-status-require-notfound) (dg-mdb-cursor-next-nodup! left->right val-relation-key val-relation-data) (goto each-key-1001-1101))) dg-mdb-status-require-notfound) (set left (dg-ids-rest left)) (if left (begin (array-set-index relation-key 1 0) (goto set-range-1001-1101)) (goto exit)))) (label each-data-1001-1101 (if (or (not ordinal-max) (<= (dg-mdb-val-relation-data->ordinal val-relation-data) ordinal-max)) (begin (set id-right (dg-mdb-val-relation-data->id val-relation-data)) (if (or (not right) (imht-set-contains? right-set id-right)) (begin (set status (dg-relation-internal-delete-right->left right->left id-left id-right id-label)) dg-mdb-status-require-read (dg-mdb-cursor-del! left->right 0) dg-mdb-status-require))) (goto next-label-1001-1101)) (dg-mdb-cursor-next-dup! left->right val-relation-key val-relation-data) (if dg-mdb-status-success? (goto each-data-1001-1101) dg-mdb-status-require-notfound)) (status-require! (dg-relation-internal-delete-label->left-conditional left->right label->left id-label id-left)) (label next-label-1001-1101 (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-SET-KEY) (cond (dg-mdb-status-success? (dg-mdb-cursor-next-nodup! left->right val-relation-key val-relation-data) (goto each-key-1001-1101)) ((status-id-is? MDB-NOTFOUND) (goto set-range-1001-1101)) (else (status-set-group-goto dg-status-group-lmdb))))) (pre-define (dg-relation-internal-delete-1011-1111) (define id-left dg-id-t id-label dg-id-t right-set imht-set-t* id-right dg-id-t) (define left-pointer dg-ids-t* left) (if right (status-require! (dg-ids->set right (address-of right-set)))) (dg-relation-internal-delete-get-ordinal-data ordinal) (array-set-index relation-data 0 ordinal-min) (set id-label (dg-ids-first label)) (label set-key-1011-1111 (set id-left (dg-ids-first left-pointer)) (array-set-index relation-key 0 id-left 1 id-label) (struct-set val-relation-key mv-data relation-key) (struct-set val-relation-data mv-data relation-data) (dg-mdb-cursor-get! left->right val-relation-key val-relation-data MDB-GET-BOTH-RANGE) (if dg-mdb-status-success? (goto each-data-1011-1111) (label each-key-1011-1111 (set left-pointer (dg-ids-rest left-pointer)) (if left-pointer (goto set-key-1011-1111) (begin (set label (dg-ids-rest label)) (if label (begin (set left-pointer left id-label (dg-ids-first label)) (goto set-key-1011-1111)) (goto exit))))))) (label each-data-1011-1111 (if (or (not ordinal-max) (<= (dg-mdb-val-relation-data->ordinal val-relation-data) ordinal-max)) (begin (if (or (not right) (imht-set-contains? right-set (dg-mdb-val-relation-data->id val-relation-data))) (begin ;delete right->left (set id-right (dg-mdb-val-relation-data->id val-relation-data)) (set status (dg-relation-internal-delete-right->left right->left id-left id-right id-label)) dg-mdb-status-require-read (dg-mdb-cursor-del! left->right 0) dg-mdb-status-require)) (dg-mdb-cursor-next-dup! left->right val-relation-key val-relation-data) (if dg-mdb-status-success? (goto each-data-1011-1111) dg-mdb-status-require-notfound)))) (status-require! (dg-relation-internal-delete-label->left-conditional left->right label->left id-label id-left)) (goto each-key-1011-1111)) (define (dg-relation-internal-delete txn left right label ordinal left->right right->left label->left) (status-t dg-txn-t* dg-ids-t* dg-ids-t* dg-ids-t* dg-ordinal-match-data-t* MDB-cursor* MDB-cursor* MDB-cursor*) "dg-relation-internal-delete does not open/close cursors. 1111 / left-right-label-ordinal. tip: the code is nice to debug if variable state is displayed near the beginning of goto labels, before cursor operations. example display on stdout: (debug-log \"each-key-1100 %lu %lu\" id-left id-right)" status-init dg-mdb-introduce-val-relation-key dg-mdb-introduce-val-relation-data dg-mdb-introduce-val-id dg-mdb-introduce-val-id-2 (dg-define-relation-key relation-key) (dg-define-relation-data relation-data) ;dg-relation-internal-delete-* macros are allowed to leave status on MDB-NOTFOUND (if left (if ordinal (if label (dg-relation-internal-delete-1011-1111) (dg-relation-internal-delete-1001-1101)) (if label (if right (dg-relation-internal-delete-1110) (dg-relation-internal-delete-1010)) (if right (dg-relation-internal-delete-1100) (dg-relation-internal-delete-1000)))) (if right (if label (dg-relation-internal-delete-0110) (dg-relation-internal-delete-0100)) (if label (dg-relation-internal-delete-0010) (dg-status-set-id-goto dg-status-id-not-implemented)))) (label exit dg-status-success-if-mdb-notfound (return status))) (define (dg-relation-delete txn left right label ordinal) (status-t dg-txn-t* dg-ids-t* dg-ids-t* dg-ids-t* dg-ordinal-match-data-t*) status-init (dg-mdb-introduce-cursor-3 txn left->right right->left label->left) (set status (dg-relation-internal-delete txn left right label ordinal left->right right->left label->left)) (label exit (dg-mdb-cursor-close-3 left->right right->left label->left) (return status)))