; configuration options
; possible types correspond to guiles integer conversion routines. for example uint, int32, uint64, intmax
(pre-define-if-not-defined dg-data-integer-type int64)
; 1 or zero to disable typed interns (saves 8bits per intern, read/write bytevectors only)
(pre-define-if-not-defined dg-guile-intern-type-size 1)
;
(pre-define debug-log? #t scm-enable-typechecks? #t)
(pre-include "sph-dg.c" "libguile.h")
(sc-include-once sph-one "sph/one" sph-guile "sph/guile")
(pre-define (status->scm-return result) (return (status->scm result)))
(pre-define (optional-count a) (if* (scm-is-integer a) (scm->uint a) 0))
(pre-define (optional-count-one a) (if* (scm-is-integer a) (scm->uint a) 1))
(pre-define (optional-every? a) (or (scm-is-undefined a) (scm-is-true a)))
(pre-define (optional-types a) (if* (scm-is-integer a) (scm->uint8 a) 0))
(pre-define (optional-offset a) (if* (scm-is-integer a) (scm->uint32 a) 0))
(pre-define (scm->txn a) (convert-type (SCM-SMOB-DATA a) dg-txn-t*))
(pre-define (dg-id->scm a) (scm-from-uint a))
(pre-define (scm->dg-id a) (scm->uint a))
(pre-define dg-guile-scm->ordinal scm->int)

(pre-define dg-guile-intern-bytevector 0
  dg-guile-intern-integer 1
  dg-guile-intern-string 2 dg-guile-intern-rational 3 dg-guile-intern-scheme 4)

(pre-define (optional-ids scm-a a)
  "append ids from scm-a to dg-ids-t* list if a is not false or undefined (no filter)"
  (if (scm-is-pair scm-a) (status-require! (scm->dg-ids scm-a (address-of a)))))

(pre-define (optional-relation-retrieve a)
  (if* (scm-is-symbol a)
    (case* scm-is-eq a
      (scm-symbol-right dg-relation-records->scm-retrieve-right)
      (scm-symbol-left dg-relation-records->scm-retrieve-left)
      (scm-symbol-label dg-relation-records->scm-retrieve-label)
      (scm-symbol-ordinal dg-relation-records->scm-retrieve-ordinal) (else 0))
    dg-relation-records->scm))

(pre-define (txn->scm txn-pointer)
  (scm-new-smob scm-type-txn (convert-type txn-pointer scm-t-bits)))

(define-type dg-read-state-type-t (enum (dg-read-state-type-relation dg-read-state-type-node)))

(define-type dg-guile-relation-read-state-t
  (struct (left dg-ids-t*) (right dg-ids-t*)
    (label dg-ids-t*) (records->scm (function-pointer SCM dg-relation-records-t*))
    (dg-state dg-relation-read-state-t)))

(define-type dg-guile-generic-read-state-t
  (struct (state b0*) (read-state-type dg-read-state-type-t)))

(pre-define mi-list-name-prefix dg-guile-generic-read-states
  mi-list-element-t dg-guile-generic-read-state-t)

(sc-include-once sph-mi-list "sph/mi-list")

(pre-define dg-guile-generic-read-states-first mi-list-first
  dg-guile-generic-read-states-rest mi-list-rest)

(define active-read-states (__thread dg-guile-generic-read-states-t*) 0)

(pre-define (active-read-states-add! state read-state-type)
  "create a generic-read-state object with the given state and read-state-type and
  add it to the thread-local active-read-states list"
  (define generic-read-state dg-guile-generic-read-state-t (struct-literal state read-state-type))
  (define generic-read-states-temp dg-guile-generic-read-states-t*
    (dg-guile-generic-read-states-add active-read-states generic-read-state))
  (if generic-read-states-temp (set active-read-states generic-read-states-temp)
    (status-set-both dg-status-group-dg dg-status-id-memory)))

(define (active-read-states-free) b0
  "read states are freed when the transaction is finalised. there can only be one transaction per thread.
  dg read states may be wrapped in dg-guile read states to carry pointers to values that are to be
  garbage collected"
  (define generic-read-state dg-guile-generic-read-state-t)
  (while active-read-states
    (set generic-read-state (dg-guile-generic-read-states-first active-read-states))
    (case = (struct-get generic-read-state read-state-type)
      (dg-read-state-type-relation
        (define state dg-guile-relation-read-state-t* (struct-get generic-read-state state))
        (dg-relation-selection-destroy (address-of (struct-pointer-get state dg-state)))
        (dg-ids-destroy (struct-pointer-get state left))
        (dg-ids-destroy (struct-pointer-get state label))
        (dg-ids-destroy (struct-pointer-get state right)) (free state))
      (dg-read-state-type-node
        (define state dg-node-read-state-t* (struct-get generic-read-state state))
        (dg-node-selection-destroy state)))
    (set active-read-states (dg-guile-generic-read-states-drop active-read-states))))

(define scm-type-selection scm-t-bits
  scm-type-txn scm-t-bits
  dg-scm-write SCM
  dg-scm-read SCM
  scm-rnrs-raise SCM
  scm-symbol-label SCM scm-symbol-left SCM scm-symbol-right SCM scm-symbol-ordinal SCM)

(define (selection->scm pointer) (SCM b0*)
  "with gcc optimisation level 3, not using a local variable did not set the smob data.
  passing a null pointer creates an empty/null selection"
  (define result SCM (scm-new-smob scm-type-selection (convert-type pointer scm-t-bits)))
  (return result))

(pre-define (scm->selection a type-group-name)
  (convert-type (SCM-SMOB-DATA a) (pre-concat dg_ type-group-name _read-state-t*)))

(pre-define (scm-c-error name description)
  (scm-call-1 scm-rnrs-raise
    (scm-list-3 (scm-from-latin1-symbol name)
      (scm-cons (scm-from-latin1-symbol "description") (scm-from-utf8-string description))
      (scm-cons (scm-from-latin1-symbol "c-routine") (scm-from-latin1-symbol __FUNCTION__)))))

(pre-define (status->scm-error a) (scm-c-error (dg-status-name a) (dg-status-description a)))
(pre-define (status->scm result) (if* status-success? result (status->scm-error status)))

(pre-define (define-dg-type? name)
  (define ((pre-concat scm-dg_ name _p) id) (SCM SCM)
    (return (scm-from-bool (and (scm-is-integer id) ((pre-concat dg_ name _p) (scm->uint id)))))))

(pre-define (scm-string-octet-length-uint a)
  (scm->uint (scm-product (scm-string-bytes-per-char a) (scm-string-length a))))

(pre-define (dg-pre-concat-primitive a b) (pre-concat a b))
(pre-define (dg-pre-concat a b) (dg-pre-concat-primitive a b))

(pre-define dg-scm->data-integer (dg-pre-concat scm_to_ dg-data-integer-type)
  dg-data-integer->scm (dg-pre-concat scm_from_ dg-data-integer-type)
  dg-data-integer-t (dg-pre-concat dg-data-integer-type _t))

(pre-define (scm-c-alist-add-from-struct target source key struct-key convert)
  (set target
    (scm-acons (scm-from-latin1-symbol key) (convert (struct-get source struct-key)) target)))

(define scm-bytevector-null SCM)

(define (scm-string->dg-data a result intern-type) (status-t SCM dg-data-t* b8)
  "strings are stored without a trailing 0 because we have the octet size exactly" status-init
  (define a-size size-t)
  ; If lenp is not NULL, the string is not null terminated, and the length of the returned string is returned in lenp
  (define a-c b8* (scm->utf8-stringn a (address-of a-size)))
  (define size size-t (+ dg-guile-intern-type-size a-size)) (define data b8* (calloc size 1))
  (if (not data) (dg-status-set-id-goto dg-status-id-memory))
  ; the only guile binding that allows writing to a buffer is scm_to_locale_stringbuf,
  ; and it is current locale dependent. it also uses memcpy similarly internally
  (memcpy (+ dg-guile-intern-type-size data) a-c (- size dg-guile-intern-type-size))
  (pre-if dg-guile-intern-type-size (set (deref data) intern-type))
  (struct-pointer-set result data data size size) (label exit (return status)))

(define (scm->dg-data a result) (status-t SCM dg-data-t*)
  "the caller has to free the data field in the result struct" status-init
  (cond
    ( (scm-is-bytevector a)
      (define size size-t (+ dg-guile-intern-type-size (SCM-BYTEVECTOR-LENGTH a)))
      (define data b8* (calloc size 1)) (if (not data) (dg-status-set-id-goto dg-status-id-memory))
      (pre-if dg-guile-intern-type-size (set (deref data) dg-guile-intern-bytevector))
      (memcpy (+ dg-guile-intern-type-size data) (SCM-BYTEVECTOR-CONTENTS a) size)
      (struct-pointer-set result data data size size))
    ((scm-is-string a) (scm-string->dg-data a result dg-guile-intern-string))
    ( (scm-is-integer a)
      (define size size-t (+ dg-guile-intern-type-size (sizeof dg-data-integer-t)))
      (define data b8* (calloc size 1)) (if (not data) (dg-status-set-id-goto dg-status-id-memory))
      (pre-if dg-guile-intern-integer (set (deref data) dg-guile-intern-integer))
      (set (deref (convert-type (+ dg-guile-intern-type-size data) dg-data-integer-t*))
        (dg-scm->data-integer a))
      (struct-pointer-set result data data size size))
    ( (scm-is-rational a) (define size size-t (+ dg-guile-intern-type-size (sizeof double)))
      (define data b8* (calloc size 1)) (if (not data) (dg-status-set-id-goto dg-status-id-memory))
      (pre-if dg-guile-intern-type-size (set (deref data) dg-guile-intern-rational))
      (set (deref (convert-type (+ dg-guile-intern-type-size data) double*)) (scm->double a)))
    (else (define b SCM (scm-object->string a dg-scm-write))
      (scm-string->dg-data b result dg-guile-intern-scheme)))
  (label exit (return status)))

(define (dg-data-list-data-free a) (b0 dg-data-list-t*)
  (while a (free (struct-get (dg-data-list-first a) data)) (set a (dg-data-list-rest a))))

(define (debug-display-data a size) (b0 b8* size-t)
  (if (not size) (return)) (printf "%x" (deref a 0))
  (define index size-t 1)
  (while (< index size) (printf " %x" (deref a index)) (set index (+ 1 index))) (printf "\n"))

(pre-define (define-dg-data->scm type-group-name)
  (define ((pre-concat dg_ type-group-name _to-scm-bytevector) a)
    (SCM (pre-concat dg_ type-group-name _t))
    (define r SCM (scm-c-make-bytevector (- (struct-get a size) dg-guile-intern-type-size)))
    (memcpy (SCM-BYTEVECTOR-CONTENTS r)
      (+ dg-guile-intern-type-size (convert-type (struct-get a data) b8*))
      (- (struct-get a size) dg-guile-intern-type-size))
    (return r))
  (define ((pre-concat dg_ type-group-name _to-scm-string) a)
    (SCM (pre-concat dg_ type-group-name _t))
    (scm-from-utf8-stringn (+ dg-guile-intern-type-size (convert-type (struct-get a data) b8*))
      (- (struct-get a size) dg-guile-intern-type-size)))
  (define ((pre-concat dg_ type-group-name _to-scm-integer) a)
    (SCM (pre-concat dg_ type-group-name _t))
    (if (> (struct-get a size) dg-guile-intern-type-size)
      (dg-data-integer->scm
        (deref
          (convert-type (+ dg-guile-intern-type-size (convert-type (struct-get a data) b8*))
            dg-data-integer-t*)))
      (scm-from-int8 0)))
  (define ((pre-concat dg_ type-group-name _to-scm-rational) a)
    (SCM (pre-concat dg_ type-group-name _t))
    (if (> (struct-get a size) dg-guile-intern-type-size)
      (scm-from-double
        (deref
          (convert-type (+ dg-guile-intern-type-size (convert-type (struct-get a data) b8*))
            double*)))
      (scm-from-int8 0)))
  (define ((pre-concat dg_ type-group-name _to-scm-scheme) a)
    (SCM (pre-concat dg_ type-group-name _t))
    (scm-call-with-input-string
      (scm-from-utf8-stringn (+ dg-guile-intern-type-size (convert-type (struct-get a data) b8*))
        (- (struct-get a size) dg-guile-intern-type-size))
      dg-scm-read))
  (define ((pre-concat dg_ type-group-name _to_scm) a) (SCM (pre-concat dg_ type-group-name _t))
    (define type b8
      (if* dg-guile-intern-type-size (deref (convert-type (struct-get a data) b8*))
        dg-guile-intern-bytevector))
    ( (case* = type
        (dg-guile-intern-bytevector (pre-concat dg_ type-group-name _to-scm-bytevector))
        (dg-guile-intern-integer (pre-concat dg_ type-group-name _to-scm-integer))
        (dg-guile-intern-string (pre-concat dg_ type-group-name _to-scm-string))
        (dg-guile-intern-rational (pre-concat dg_ type-group-name _to-scm-rational))
        (dg-guile-intern-scheme (pre-concat dg_ type-group-name _to-scm-scheme)))
      a)))

;dg-data->scm-*
(define-dg-data->scm data)
;dg-data-record->scm-*
(define-dg-data->scm data-record)

(define (dg-ids->scm a) (SCM dg-ids-t*)
  (define result SCM SCM-EOL)
  (while a (set result (scm-cons (dg-id->scm (dg-ids-first a)) result) a (dg-ids-rest a)))
  (return result))

(define (scm->dg-ids a result) (status-t SCM dg-ids-t**)
  status-init (define result-temp dg-ids-t* (deref result))
  (while (not (scm-is-null a))
    (set result-temp (dg-ids-add result-temp (scm->dg-id (scm-first a))))
    (if result-temp (set (deref result) result-temp a (scm-tail a))
      (begin (dg-ids-destroy (deref result)) (dg-status-set-id-goto dg-status-id-memory))))
  (label exit (return status)))

(define (dg-data-list->scm a) (SCM dg-data-list-t*)
  (define result SCM SCM-EOL)
  (while a
    (set result (scm-cons (dg-data->scm (dg-data-list-first a)) result) a (dg-data-list-rest a)))
  (return result))

(define (dg-data-records->scm a convert-data)
  (SCM dg-data-records-t* (function-pointer SCM dg-data-record-t)) (define result SCM SCM-EOL)
  (define record dg-data-record-t) (define data SCM)
  (while a
    (set record (dg-data-records-first a)
      data (if* record.size (convert-data record) scm-bytevector-null)
      result (scm-cons (scm-vector (scm-list-2 (dg-id->scm record.id) data)) result)
      a (dg-data-records-rest a)))
  (return result))

(define (dg-relation-records->scm a) (SCM dg-relation-records-t*)
  (define result SCM SCM-EOL) (define record dg-relation-record-t)
  (while a
    (set record (dg-relation-records-first a)
      result
      (scm-cons
        (scm-vector
          (scm-list-4 (dg-id->scm (struct-get record left)) (dg-id->scm (struct-get record right))
            (dg-id->scm (struct-get record label)) (dg-id->scm (struct-get record ordinal))))
        result)
      a (dg-relation-records-rest a)))
  (return result))

(pre-define (define-dg-relation-records->scm-retrieve field-name)
  (define ((pre-concat dg-relation-records->scm-retrieve_ field-name) a)
    (SCM dg-relation-records-t*) (define result SCM SCM-EOL)
    (define record dg-relation-record-t)
    (while a
      (set record (dg-relation-records-first a)
        result (scm-cons (dg-id->scm (struct-get record field-name)) result)
        a (dg-relation-records-rest a)))
    (return result)))

(define-dg-relation-records->scm-retrieve left)
(define-dg-relation-records->scm-retrieve right)
(define-dg-relation-records->scm-retrieve label)
(define-dg-relation-records->scm-retrieve ordinal)

(define (scm->dg-data-list a result) (status-t SCM dg-data-list-t**)
  status-init (define result-temp dg-data-list-t* (deref result))
  (define data-temp dg-data-t (struct-literal 0 0))
  (while (not (scm-is-null a))
    (status-require! (scm->dg-data (scm-first a) (address-of data-temp)))
    (set result-temp (dg-data-list-add result-temp data-temp))
    (if result-temp (set (deref result) result-temp a (scm-tail a))
      (dg-status-set-id-goto dg-status-id-memory)))
  (label exit
    ;added result elements are not freed on error to allow passing a result-value with elements
    (if status-failure? (free (struct-get data-temp data))) (return status)))

(define (scm-from-mdb-stat a) (SCM MDB-stat*)
  status-init (define result SCM SCM-EOL)
  (pre-let
    ( (result-add key struct-key)
      (scm-c-alist-add-from-struct result (deref a) key struct-key scm-from-uint))
    (result-add "ms-psize" ms-psize) (result-add "ms-depth" ms-depth)
    (result-add "ms-branch-pages" ms-branch-pages) (result-add "ms-leaf-pages" ms-leaf-pages)
    (result-add "ms-overflow-pages" ms-overflow-pages) (result-add "ms-entries" ms-entries))
  (status->scm-return result))

(define (scm-dg-init scm-path scm-options) (SCM SCM SCM)
  status-init (define options dg-init-options-t options-pointer dg-init-options-t* scm-temp SCM)
  (define path b8* 0)
  (if (or (scm-is-undefined scm-options) (scm-is-null scm-options)) (set options-pointer 0)
    (pre-let
      ( (scm-get-value name)
        (begin (set scm-temp (scm-assoc-ref scm-options (scm-from-latin1-symbol name)))
          (set scm-temp (if* (scm-is-pair scm-temp) (scm-tail scm-temp) SCM-UNDEFINED))))
      (dg-init-options-set-defaults (address-of options)) (scm-get-value "read-only?")
      (if (scm-is-bool scm-temp) (set options.read-only? (scm-is-true scm-temp)))
      (scm-get-value "maximum-size-octets")
      (if (scm-is-integer scm-temp) (set options.maximum-size-octets (scm->uint scm-temp)))
      (scm-get-value "maximum-reader-count")
      (if (scm-is-integer scm-temp) (set options.maximum-reader-count (scm->uint scm-temp)))
      (scm-get-value "filesystem-has-ordered-writes?")
      (if (scm-is-bool scm-temp)
        (set options.filesystem-has-ordered-writes? (scm-is-true scm-temp)))
      (scm-get-value "env-open-flags")
      (if (scm-is-integer scm-temp) (set options.env-open-flags (scm->uint scm-temp)))
      (scm-get-value "file-permissions")
      (if (scm-is-integer scm-temp) (set options.file-permissions (scm->uint scm-temp)))
      (set options-pointer (address-of options))))
  (set path (scm->locale-string scm-path)) (status-require! (dg-init path options-pointer))
  (define scm-module SCM (scm-c-resolve-module "sph storage dg"))
  (set scm-temp (scm-variable-ref (scm-c-module-lookup scm-module "dg-init-extension")))
  (while (not (scm-is-null scm-temp)) (scm-call-0 (scm-first scm-temp))
    (set scm-temp (scm-tail scm-temp)))
  (label exit (free path) (status->scm-return SCM-BOOL-T)))

(define (scm-dg-exit) SCM (scm-gc) (dg-exit) (return SCM-UNSPECIFIED))
(define (scm-dg-initialised?) SCM (return (scm-from-bool dg-initialised)))
(define (scm-dg-root) SCM (return (scm-from-locale-string dg-root)))

(pre-define (define-scm-dg-txn-create name flags)
  (define ((pre-concat scm-dg-txn-create_ name)) SCM
    status-init (define txn dg-txn-t*)
    (dg-mdb-status-require! (mdb-txn-begin dg-mdb-env 0 flags (address-of txn)))
    (define result SCM (txn->scm txn))
    (label exit (if (and result status-failure?) (free txn)) (status->scm-return result))))

(define-scm-dg-txn-create read MDB-RDONLY)
(define-scm-dg-txn-create write 0)
(define-dg-type? id)
(define-dg-type? intern)
(define-dg-type? extern)
(define-dg-type? relation)

(define (scm-dg-txn-abort scm-txn) (SCM SCM)
  (active-read-states-free) (mdb-txn-abort (scm->txn scm-txn))
  (SCM-SET-SMOB-DATA scm-txn 0) (return SCM-UNSPECIFIED))

(define (scm-dg-txn-commit scm-txn) (SCM SCM)
  "note that mdb-txn-commit frees cursors - active-read-states-free uses mdb-cursor-close.
  if active-read-states-free is called after mdb-txn-commit a double free occurs"
  status-init (active-read-states-free)
  (dg-mdb-status-require! (mdb-txn-commit (scm->txn scm-txn))) (SCM-SET-SMOB-DATA scm-txn 0)
  (label exit (status->scm-return SCM-UNSPECIFIED)))

(define (scm-dg-id-create scm-txn scm-count) (SCM SCM SCM)
  status-init (define count b32 (optional-count-one scm-count))
  (define ids dg-ids-t* 0) (status-require! (dg-id-create (scm->txn scm-txn) count (address-of ids)))
  (define result SCM (dg-ids->scm ids)) (label exit (dg-ids-destroy ids) (status->scm-return result)))

(define (scm-dg-extern-create scm-txn scm-count scm-data) (SCM SCM SCM SCM)
  status-init (define count b32 (optional-count-one scm-count))
  (define data-struct dg-data-t (struct-literal 0 0))
  (define data dg-data-t* (address-of data-struct))
  (if (scm-is-undefined scm-data) (set data 0) (status-require! (scm->dg-data scm-data data)))
  (define ids dg-ids-t* 0)
  (status-require! (dg-extern-create (scm->txn scm-txn) count data (address-of ids)))
  (define result SCM (dg-ids->scm ids))
  (label exit (dg-ids-destroy ids) (free (struct-get data-struct data)) (status->scm-return result)))

(define (scm-dg-extern-id->data scm-txn scm-ids scm-every?) (SCM SCM SCM SCM)
  status-init (define every? boolean (optional-every? scm-every?))
  (define ids dg-ids-t* 0) (status-require! (scm->dg-ids scm-ids (address-of ids)))
  (define data dg-data-list-t* 0)
  (dg-status-require-read! (dg-extern-id->data (scm->txn scm-txn) ids every? (address-of data)))
  (define result SCM (dg-data-list->scm data))
  (label exit (dg-ids-destroy ids) (dg-data-list-destroy data) (status->scm-return result)))

(define (scm-dg-extern-data->id scm-txn scm-data) (SCM SCM SCM)
  status-init (define data dg-data-t (struct-literal 0 0))
  (status-require! (scm->dg-data scm-data (address-of data))) (define ids dg-ids-t* 0)
  (dg-status-require-read! (dg-extern-data->id (scm->txn scm-txn) data (address-of ids)))
  (define result SCM (dg-ids->scm ids))
  (label exit (dg-ids-destroy ids) (free (struct-get data data)) (status->scm-return result)))

(define (dg-guile-ordinal-generator state) (dg-ordinal-t b0*)
  (define scm-state SCM (deref (convert-type state SCM*)))
  (define scm-generator SCM (scm-first scm-state))
  (define scm-result SCM (scm-apply-0 scm-generator (scm-tail scm-state)))
  (set (deref (convert-type state SCM*)) (scm-cons scm-generator scm-result))
  (return (dg-guile-scm->ordinal (scm-first scm-result))))

(define
  (scm-dg-relation-ensure scm-txn scm-left scm-right scm-label scm-ordinal-generator
    scm-ordinal-generator-state)
  (SCM SCM SCM SCM SCM SCM SCM) status-init
  (if (or (scm-is-undefined scm-label) (not (scm-is-true scm-label)))
    (set scm-label (scm-list-1 (scm-from-uint8 0))))
  (dg-define-ids-3 left right label) (status-require! (scm->dg-ids scm-left (address-of left)))
  (status-require! (scm->dg-ids scm-right (address-of right)))
  (if (scm-is-true scm-label) (status-require! (scm->dg-ids scm-label (address-of label))))
  (define ordinal-generator dg-relation-ordinal-generator-t 0) (define ordinal-generator-state b0*)
  (define ordinal-value dg-ordinal-t) (define scm-state SCM)
  (if (scm-is-true (scm-procedure? scm-ordinal-generator))
    (set scm-state
      (scm-cons scm-ordinal-generator
        (if* (scm-is-true (scm-list? scm-ordinal-generator-state)) scm-ordinal-generator-state
          (scm-list-1 scm-ordinal-generator-state)))
      ordinal-generator-state (address-of scm-state) ordinal-generator dg-guile-ordinal-generator)
    (set ordinal-value
      (if* (scm-is-undefined scm-ordinal-generator-state) 0 (scm->uint scm-ordinal-generator-state))
      ordinal-generator-state (address-of ordinal-value)))
  (status-require!
    (dg-relation-ensure (scm->txn scm-txn) left
      right label ordinal-generator ordinal-generator-state))
  (label exit (dg-ids-destroy left)
    (dg-ids-destroy right) (dg-ids-destroy label) (status->scm-return SCM-BOOL-T)))

(define (scm-dg-statistics scm-txn) (SCM SCM)
  status-init (define result SCM SCM-EOL)
  (define stat dg-statistics-t)
  (status-require! (dg-statistics (scm->txn scm-txn) (address-of stat)))
  (pre-let
    ( (result-add key struct-key)
      (set result
        (scm-acons (scm-from-latin1-symbol key)
          (scm-from-mdb-stat (address-of (struct-get stat struct-key))) result)))
    (result-add "id->data" id->data) (result-add "data-intern->id" data-intern->id)
    (result-add "data-extern->extern" data-extern->extern) (result-add "left->right" left->right)
    (result-add "right->left" right->left) (result-add "label->left" label->left))
  (label exit (status->scm-return result)))

(define (scm-dg-delete scm-txn scm-ids) (SCM SCM SCM)
  status-init (define ids dg-ids-t* 0)
  (status-require! (scm->dg-ids scm-ids (address-of ids)))
  (status-require! (dg-delete (scm->txn scm-txn) ids))
  (label exit (dg-ids-destroy ids) (status->scm-return SCM-UNSPECIFIED)))

(define (scm-dg-identify scm-txn scm-ids) (SCM SCM SCM)
  status-init (define ids dg-ids-t* 0)
  (status-require! (scm->dg-ids scm-ids (address-of ids))) (define ids-result dg-ids-t* 0)
  (status-require! (dg-identify (scm->txn scm-txn) ids (address-of ids-result)))
  (define result SCM (dg-ids->scm ids-result))
  (label exit (dg-ids-destroy ids) (dg-ids-destroy ids-result) (status->scm-return result)))

(define (scm-dg-exists? scm-txn scm-ids) (SCM SCM SCM)
  status-init (define ids dg-ids-t* 0)
  (status-require! (scm->dg-ids scm-ids (address-of ids))) (define result-c boolean)
  (status-require! (dg-exists? (scm->txn scm-txn) ids (address-of result-c)))
  (label exit (dg-ids-destroy ids) (status->scm-return (scm-from-bool result-c))))

(define (scm-dg-intern-ensure scm-txn scm-data) (SCM SCM SCM)
  status-init (define data dg-data-list-t* 0)
  (status-require! (scm->dg-data-list scm-data (address-of data))) (define ids dg-ids-t* 0)
  (status-require! (dg-intern-ensure (scm->txn scm-txn) data (address-of ids)))
  (define result SCM (dg-ids->scm ids))
  (label exit (dg-ids-destroy ids)
    (dg-data-list-data-free data) (dg-data-list-destroy data) (status->scm-return result)))

(define (scm-dg-intern-update scm-txn scm-id scm-data) (SCM SCM SCM SCM)
  status-init (define data dg-data-t (struct-literal 0 0))
  (status-require! (scm->dg-data scm-data (address-of data))) (define id dg-id-t (scm->dg-id scm-id))
  (status-require! (dg-intern-update (scm->txn scm-txn) id data))
  (label exit (free (struct-get data data)) (status->scm-return SCM-BOOL-T)))

(define (scm-dg-extern-update scm-txn scm-id scm-data) (SCM SCM SCM SCM)
  status-init (define data dg-data-t)
  (status-require! (scm->dg-data scm-data (address-of data))) (define id dg-id-t (scm->dg-id scm-id))
  (status-require! (dg-extern-update (scm->txn scm-txn) id data))
  (label exit (free (struct-get data data)) (status->scm-return SCM-BOOL-T)))

(define (scm-dg-status-description id-status id-group) (SCM SCM SCM)
  status-init (struct-set status id (scm->int id-status) group (scm->int id-group))
  (scm-from-latin1-string (dg-status-description status)))

(define (scm-dg-status-group-id->name a) (SCM SCM)
  (scm-from-latin1-symbol (dg-status-group-id->name (scm->int a))))

(define (scm-dg-intern-data->id scm-txn scm-data scm-every?) (SCM SCM SCM SCM)
  status-init (define every? boolean (optional-every? scm-every?))
  (define data dg-data-list-t* 0) (status-require! (scm->dg-data-list scm-data (address-of data)))
  (define ids dg-ids-t* 0)
  (set status (dg-intern-data->id (scm->txn scm-txn) data every? (address-of ids)))
  (if (= dg-status-id-condition-unfulfilled status.id) status-reset status-require)
  (define result SCM (dg-ids->scm ids))
  (label exit (dg-ids-destroy ids)
    (dg-data-list-data-free data) (dg-data-list-destroy data) (status->scm-return result)))

(define (scm-dg-intern-id->data scm-txn scm-ids scm-every?) (SCM SCM SCM SCM)
  status-init (define every? boolean (optional-every? scm-every?))
  (define ids dg-ids-t* 0) (status-require! (scm->dg-ids scm-ids (address-of ids)))
  (define data dg-data-list-t* 0)
  (set status (dg-intern-id->data (scm->txn scm-txn) ids every? (address-of data)))
  (if (= dg-status-id-condition-unfulfilled status.id) status-reset status-require)
  (define result SCM (dg-data-list->scm data))
  (label exit (dg-ids-destroy ids) (dg-data-list-destroy data) (status->scm-return result)))

(define (scm-dg-intern-small? id-scm) (SCM SCM)
  (scm-from-bool (dg-intern-small? (scm->dg-id id-scm))))

(define (scm-dg-intern-small-id->data id-scm) (SCM SCM)
  (dg-id->scm (dg-intern-small-id->data (scm->dg-id id-scm))))

(define (scm-dg-intern-small-data->id data-scm) (SCM SCM)
  (dg-id->scm (dg-intern-small-data->id (scm->dg-id data-scm))))

(pre-let
  ( (result-add key struct-key)
    (scm-c-alist-add-from-struct result result-c key struct-key dg-ids->scm)
    (result-add-records key struct-key)
    (scm-c-alist-add-from-struct result result-c key struct-key dg-relation-records->scm))
  (define (scm-dg-index-errors-intern scm-txn) (SCM SCM)
    status-init (define result-c dg-index-errors-intern-t)
    (status-require! (dg-index-errors-intern (scm->txn scm-txn) (address-of result-c)))
    (define result SCM SCM-EOL) (result-add "different-data-id" different-data-id)
    (result-add "excess-data-id" excess-data-id) (result-add "different-id-data" different-id-data)
    (result-add "missing-id-data" missing-id-data)
    (scm-c-alist-add-from-struct result result-c "errors?" errors? scm-from-bool)
    (label exit (status->scm-return result)))
  (define (scm-dg-index-errors-extern scm-txn) (SCM SCM)
    status-init (define result-c dg-index-errors-extern-t)
    (status-require! (dg-index-errors-extern (scm->txn scm-txn) (address-of result-c)))
    (define result SCM SCM-EOL) (result-add "different-data-extern" different-data-extern)
    (result-add "excess-data-extern" excess-data-extern)
    (result-add "different-id-data" different-id-data) (result-add "missing-id-data" missing-id-data)
    (scm-c-alist-add-from-struct result result-c "errors?" errors? scm-from-bool)
    (label exit (status->scm-return result)))
  (define (scm-dg-index-errors-relation scm-txn) (SCM SCM)
    status-init (define result-c dg-index-errors-relation-t)
    (status-require! (dg-index-errors-relation (scm->txn scm-txn) (address-of result-c)))
    (define result SCM SCM-EOL) (result-add-records "missing-right-left" missing-right-left)
    (result-add-records "missing-label-left" missing-label-left)
    (result-add-records "excess-right-left" excess-right-left)
    (result-add-records "excess-label-left" excess-label-left)
    (scm-c-alist-add-from-struct result result-c "errors?" errors? scm-from-bool)
    (label exit (status->scm-return result))))

(pre-define (define-scm-dg-index-recreate name)
  (define ((pre-concat scm-dg-index-recreate- name)) SCM
    status-init (status-require! ((pre-concat dg-index-recreate- name)))
    (label exit (status->scm-return SCM-BOOL-T))))

(define-scm-dg-index-recreate intern)
(define-scm-dg-index-recreate extern)
(define-scm-dg-index-recreate relation)

(define (scm-dg-node-select scm-txn scm-types scm-offset) (SCM SCM SCM SCM)
  (if (scm-is-null scm-types) (return (selection->scm 0))) status-init
  (define offset b32 (optional-offset scm-offset))
  (define state dg-node-read-state-t* (malloc (sizeof dg-node-read-state-t)))
  (if (not state) (status-set-id-goto dg-status-id-memory))
  (define types b8 (optional-types scm-types))
  (status-require! (dg-node-select (scm->txn scm-txn) types offset state))
  (label exit
    (if (and status-failure? (not (status-id-is? dg-status-id-no-more-data)))
      (begin (free state) (return (status->scm-error status))))
    (active-read-states-add! state dg-read-state-type-node) (return (selection->scm state))))

(define (scm-dg-node-read scm-selection scm-count) (SCM SCM SCM)
  status-init (define state dg-node-read-state-t* (scm->selection scm-selection node))
  (define count b32 (optional-count scm-count)) (define records dg-data-records-t* 0)
  (dg-status-require-read! (dg-node-read state count (address-of records)))
  dg-status-success-if-no-more-data
  (define result SCM (dg-data-records->scm records dg-data-record->scm))
  (label exit (set status.group dg-status-group-lmdb)
    (dg-data-records-destroy records) (status->scm-return result)))

(pre-define (dg-status-require-malloc malloc-result)
  (if (not malloc-result) (status-set-both-goto dg-status-group-dg dg-status-id-memory)))

(pre-define (set-ordinal-match-data scm-ordinal) (define ordinal dg-ordinal-match-data-t* 0)
  (if (scm-is-true (scm-list? scm-ordinal))
    (begin (define scm-ordinal-min SCM (scm-assoc-ref scm-ordinal (scm-from-latin1-symbol "min")))
      (define scm-ordinal-max SCM (scm-assoc-ref scm-ordinal (scm-from-latin1-symbol "max")))
      (set ordinal (calloc 1 (sizeof dg-ordinal-match-data-t))) (dg-status-require-malloc ordinal)
      (struct-pointer-set ordinal min
        (if* (scm-is-integer scm-ordinal-min) (scm->uint scm-ordinal-min) 0) max
        (if* (scm-is-integer scm-ordinal-max) (scm->uint scm-ordinal-max) 0)))))

(define
  (scm-dg-relation-select scm-txn scm-left scm-right scm-label scm-retrieve scm-ordinal scm-offset)
  (SCM SCM SCM SCM SCM SCM SCM SCM)
  (if (or (scm-is-null scm-left) (scm-is-null scm-right) (scm-is-null scm-label))
    (return (selection->scm 0)))
  status-init (set-ordinal-match-data scm-ordinal)
  (define offset b32 (optional-offset scm-offset))
  (define state dg-guile-relation-read-state-t* (malloc (sizeof dg-guile-relation-read-state-t)))
  (dg-status-require-malloc state) (dg-define-ids-3 left right label)
  (optional-ids scm-left left) (optional-ids scm-right right)
  (optional-ids scm-label label)
  (status-require!
    (dg-relation-select (scm->txn scm-txn) left
      right label ordinal offset (address-of (struct-pointer-get state dg-state))))
  (define records->scm (function-pointer SCM dg-relation-records-t*)
    (optional-relation-retrieve scm-retrieve))
  (if (not records->scm) (status-set-both-goto dg-status-group-dg dg-status-id-input-type))
  (struct-pointer-set state left left right right label label records->scm records->scm)
  (label exit
    (if status-failure?
      (begin (free state) (free left)
        (free right) (free label)
        (if (status-id-is? dg-status-id-no-more-data) (return (selection->scm 0))
          (status->scm-error status)))
      (begin (active-read-states-add! state dg-read-state-type-relation)
        (return (selection->scm state))))))

(define (scm-dg-relation-delete scm-txn scm-left scm-right scm-label scm-ordinal)
  (SCM SCM SCM SCM SCM SCM)
  (if (or (scm-is-null scm-left) (scm-is-null scm-right) (scm-is-null scm-label))
    (return SCM-BOOL-T))
  status-init (set-ordinal-match-data scm-ordinal)
  (dg-define-ids-3 left right label) (optional-ids scm-left left)
  (optional-ids scm-right right) (optional-ids scm-label label)
  (status-require! (dg-relation-delete (scm->txn scm-txn) left right label ordinal))
  (label exit (status->scm-return SCM-BOOL-T)))

(define (scm-dg-relation-read scm-selection scm-count) (SCM SCM SCM)
  status-init
  (define state dg-guile-relation-read-state-t* (scm->selection scm-selection guile-relation))
  (if (not state) (return SCM-EOL)) (define count b32 (optional-count scm-count))
  (define records dg-relation-records-t* 0)
  (define records->scm (function-pointer SCM dg-relation-records-t*)
    (struct-pointer-get state records->scm))
  (dg-status-require-read!
    (dg-relation-read (address-of (struct-pointer-get state dg-state)) count (address-of records)))
  dg-status-success-if-no-more-data (define result SCM (records->scm records))
  (label exit (dg-relation-records-destroy records) (status->scm-return result)))

(define (scm-dg-txn? a) (SCM SCM) (return (scm-from-bool (SCM-SMOB-PREDICATE scm-type-txn a))))
(define (scm-dg-txn-active? a) (SCM SCM) (return (scm-from-bool (SCM-SMOB-DATA a))))

(define (scm-dg-selection? a) (SCM SCM)
  (return (scm-from-bool (SCM_SMOB_PREDICATE scm-type-selection a))))

(define (scm-dg-debug-count-all-btree-entries txn) (SCM SCM)
  status-init (define result b32)
  (status-require! (dg-debug-count-all-btree-entries (scm->txn txn) (address-of result)))
  (label exit (status->scm-return (scm-from-uint32 result))))

(define (scm-dg-debug-display-btree-counts txn) (SCM SCM)
  status-init (status-require! (dg-debug-display-btree-counts (scm->txn txn)))
  (label exit (status->scm-return SCM-BOOL-T)))

(define (scm-dg-debug-display-content-left->right txn) (SCM SCM)
  status-init (dg-status-require-read! (dg-debug-display-content-left->right (scm->txn txn)))
  (label exit (status->scm-return SCM-BOOL-T)))

(define (scm-dg-debug-display-content-right->left txn) (SCM SCM)
  status-init (dg-status-require-read! (dg-debug-display-content-right->left (scm->txn txn)))
  (label exit (status->scm-return SCM-BOOL-T)))

(define (dg-guile-init) b0
  (set scm-type-txn (scm-make-smob-type "dg-txn" #t)
    scm-type-selection (scm-make-smob-type "dg-selection" 0)
    dg-scm-write (scm-variable-ref (scm-c-lookup "write"))
    dg-scm-read (scm-variable-ref (scm-c-lookup "read"))
    scm-symbol-label (scm-from-latin1-symbol "label")
    scm-symbol-ordinal (scm-from-latin1-symbol "ordinal")
    scm-symbol-left (scm-from-latin1-symbol "left")
    scm-symbol-right (scm-from-latin1-symbol "right")
    scm-rnrs-raise (scm-c-public-ref "rnrs exceptions" "raise")
    scm-bytevector-null (scm-c-make-bytevector 0))
  (define m SCM (scm-c-resolve-module "sph storage dg"))
  (scm-c-module-define m "dg-init-extension" SCM-EOL)
  (scm-c-module-define m "dg-size-octets-id" (scm-from-size-t dg-size-octets-id))
  (scm-c-module-define m "dg-size-octets-data-max"
    (scm-from-size-t (- dg-size-octets-data-max dg-guile-intern-type-size)))
  (scm-c-module-define m "dg-size-octets-data-min" (scm-from-size-t dg-size-octets-data-min))
  (scm-c-module-define m "dg-null" (scm-from-uint8 dg-null))
  (scm-c-module-define m "dg-type-bit-id" (scm-from-uint8 dg-type-bit-id))
  (scm-c-module-define m "dg-type-bit-intern" (scm-from-uint8 dg-type-bit-intern))
  (scm-c-module-define m "dg-type-bit-extern" (scm-from-uint8 dg-type-bit-extern))
  (scm-c-module-define m "dg-type-bit-intern-small" (scm-from-uint8 dg-type-bit-intern-small))
  scm-c-define-procedure-c-init
  (scm-c-define-procedure-c "dg-exit" 0 0 0 scm-dg-exit "completely deinitialises the database")
  (scm-c-define-procedure-c "dg-init" 1 1 0 scm-dg-init "path [options] ->")
  (scm-c-define-procedure-c "dg-id?" 1 0 0 scm-dg-id? "integer -> boolean")
  (scm-c-define-procedure-c "dg-intern?" 1 0 0 scm-dg-intern? "integer -> boolean")
  (scm-c-define-procedure-c "dg-extern?" 1 0 0 scm-dg-extern? "integer -> boolean")
  (scm-c-define-procedure-c "dg-relation?" 1 0 0 scm-dg-relation? "integer -> boolean")
  (scm-c-define-procedure-c "dg-initialised?" 0 0 0 scm-dg-initialised? "-> boolean")
  (scm-c-define-procedure-c "dg-root" 0 0 0 scm-dg-root "-> string")
  (scm-c-define-procedure-c "dg-txn-create-read" 0 0 0 scm-dg-txn-create-read "-> dg-txn")
  (scm-c-define-procedure-c "dg-txn-create-write" 0 0 0 scm-dg-txn-create-write "-> dg-txn")
  (scm-c-define-procedure-c "dg-txn-abort" 1 0 0 scm-dg-txn-abort "dg-txn ->")
  (scm-c-define-procedure-c "dg-txn-commit" 1 0 0 scm-dg-txn-commit "dg-txn -> unspecified")
  (scm-c-define-procedure-c "dg-id-create" 1 1 0 scm-dg-id-create "dg-txn [count] -> (integer ...)")
  (scm-c-define-procedure-c "dg-identify" 2 0 0 scm-dg-identify "dg-txn (integer:id ...) -> list")
  (scm-c-define-procedure-c "dg-exists?" 2 0 0 scm-dg-exists? "dg-txn (integer:id ...) -> list")
  (scm-c-define-procedure-c "dg-statistics" 1 0 0 scm-dg-statistics "dg-txn -> alist")
  (scm-c-define-procedure-c "dg-relation-ensure" 3
    3 0 scm-dg-relation-ensure "dg-txn list list [list false/procedure integer/any] -> list:ids")
  (scm-c-define-procedure-c "dg-intern-ensure" 2 0 0 scm-dg-intern-ensure "dg-txn list -> list:ids")
  (scm-c-define-procedure-c "dg-status-description" 2
    0 0 scm-dg-status-description "integer:status integer:group -> string")
  (scm-c-define-procedure-c "dg-status-group-id->name" 1
    0 0 scm-dg-status-group-id->name "integer:group-id -> string")
  (scm-c-define-procedure-c "dg-intern-id->data" 2
    2 0 scm-dg-intern-id->data "dg-txn list [boolean:every?] -> (any ...)")
  (scm-c-define-procedure-c "dg-intern-data->id" 2
    1 0 scm-dg-intern-data->id "dg-txn list [boolean:every?] -> (integer ...)")
  (scm-c-define-procedure-c "dg-intern-small?" 1 0 0 scm-dg-intern-small? "id -> boolean")
  (scm-c-define-procedure-c "dg-intern-small-data->id" 1
    0 0 scm-dg-intern-small-data->id "integer -> id")
  (scm-c-define-procedure-c "dg-intern-small-id->data" 1
    0 0 scm-dg-intern-small-id->data "id -> integer")
  (scm-c-define-procedure-c "dg-delete" 2 0 0 scm-dg-delete "dg-txn list -> unspecified")
  (scm-c-define-procedure-c "dg-extern-create" 1
    2 0 scm-dg-extern-create "dg-txn [integer:count any:data] -> list")
  (scm-c-define-procedure-c "dg-extern-id->data" 2
    2 0 scm-dg-extern-id->data "dg-txn (integer ...) [boolean:every?] -> list")
  (scm-c-define-procedure-c "dg-extern-data->id" 2 0 0 scm-dg-extern-data->id "dg-txn any -> list")
  (scm-c-define-procedure-c "dg-index-errors-relation" 1
    0 0 scm-dg-index-errors-relation "dg-txn -> list")
  (scm-c-define-procedure-c "dg-index-errors-intern" 1
    0 0 scm-dg-index-errors-intern "dg-txn -> list")
  (scm-c-define-procedure-c "dg-index-errors-extern" 1
    0 0 scm-dg-index-errors-extern "dg-txn -> list")
  (scm-c-define-procedure-c "dg-index-recreate-intern" 0 0 0 scm-dg-index-recreate-intern "-> true")
  (scm-c-define-procedure-c "dg-index-recreate-extern" 0 0 0 scm-dg-index-recreate-extern "-> true")
  (scm-c-define-procedure-c "dg-index-recreate-relation" 0
    0 0 scm-dg-index-recreate-relation "-> true")
  (scm-c-define-procedure-c "dg-node-select" 1
    2 0
    scm-dg-node-select
    "dg-txn [types offset] -> dg-selection
    types is zero or a combination of bits from dg-type-bit-* variables, for example (logior dg-type-bit-intern dg-type-bit-extern)")
  (scm-c-define-procedure-c "dg-node-read" 1
    1 0 scm-dg-node-read "dg-selection [count] -> (vector ...)")
  (scm-c-define-procedure-c "dg-relation-select" 1
    6 0
    scm-dg-relation-select
    "dg-txn (integer ...):left [(integer ...):right (integer ...):label symbol:retrieve-only-field list:((symbol:min integer) (symbol:max integer)):ordinal integer:offset] -> dg-selection")
  (scm-c-define-procedure-c "dg-relation-delete" 2
    3 0
    scm-dg-relation-delete
    "dg-txn (integer ...):left [(integer ...):right (integer ...):label list:((symbol:min integer) (symbol:max integer)):ordinal] -> unspecified")
  (scm-c-define-procedure-c "dg-relation-read" 1
    1 0 scm-dg-relation-read "dg-selection [integer:count] -> (vector ...)")
  (scm-c-define-procedure-c "dg-intern-update" 3
    0 0 scm-dg-intern-update "dg-txn integer:id any:data -> true")
  (scm-c-define-procedure-c "dg-extern-update" 3
    0 0 scm-dg-extern-update "dg-txn integer:id any:data -> true")
  (scm-c-define-procedure-c "dg-selection?" 1 0 0 scm-dg-selection? "any -> boolean")
  (scm-c-define-procedure-c "dg-txn?" 1 0 0 scm-dg-txn? "any -> boolean")
  (scm-c-define-procedure-c "dg-txn-active?" 1 0 0 scm-dg-txn-active? "dg-txn -> boolean")
  (scm-c-define-procedure-c "dg-debug-count-all-btree-entries" 1
    0 0 scm-dg-debug-count-all-btree-entries "dg-txn -> integer")
  (scm-c-define-procedure-c "dg-debug-display-btree-counts" 1
    0 0 scm-dg-debug-display-btree-counts "dg-txn ->")
  (scm-c-define-procedure-c "dg-debug-display-content-left->right" 1
    0 0 scm-dg-debug-display-content-left->right "dg-txn ->")
  (scm-c-define-procedure-c "dg-debug-display-content-right->left" 1
    0 0 scm-dg-debug-display-content-right->left "dg-txn ->"))