;;;; sqlite3.scm
;;;; bindings to the SQLite3 database library

;; Notes
;;
;; - Due to 'usual-integrations' the 'string-length' procedure is rewritten
;; to the "core" implementation. So even if the utf-8 module is "imported"
;; into the top-level a byte length will result.

(define-extension sqlite3
  (export
    ;; classes
    initialize
    <sqlite3:database>
    <sqlite3:statement>
    ;; methods & procedures
    sqlite3:open
    sqlite3:define-collation
    sqlite3:define-function
    sqlite3:set-busy-timeout!
    sqlite3:set-busy-handler!
    sqlite3:set-safe-busy-handler!
    sqlite3:default-safe-busy-handler
    sqlite3:interrupt!
    sqlite3:auto-committing?
    sqlite3:changes
    sqlite3:last-insert-rowid
    sqlite3:finalize!
    sqlite3:prepare
    sqlite3:repair!
    sqlite3:reset!
    sqlite3:bind-parameter-count
    sqlite3:bind-parameter-index
    sqlite3:bind-parameter-name
    sqlite3:bind!
    sqlite3:bind-parameters!
    sqlite3:step!
    sqlite3:column-count
    sqlite3:column-type
    sqlite3:column-declared-type
    sqlite3:column-name
    sqlite3:column-data
    sqlite3:call-with-temporary-statements
    sqlite3:exec
    sqlite3:update
    sqlite3:first-result
    sqlite3:first-row
    sqlite3:fold-row
    sqlite3:for-each-row
    sqlite3:map-row
    sqlite3:with-transaction
    sqlite3:complete?
    sqlite3:library-version
    sqlite3:enable-shared-cache!
    sqlite3:boolean-value ) )

(declare
  (usual-integrations)
  (fixnum-arithmetic)
  (no-procedure-checks-for-usual-bindings)
  ; redefinition of imported variable `initialize' from `tinyclos'
  (disable-warning redef)
  (unused
    ; Stop annoying messages
    chicken_sqlite3_function_stub
    chicken_sqlite3_collation_stub
    chicken_sqlite3_final_stub
    chicken_sqlite3_step_stub
    chicken_sqlite3_busy_handler_stub )
  (bound-to-procedure
    ##sys#expand-home-path
    #;##sys#pathname-resolution
    abort-sqlite3-null-error
    sqlite3:errmsg ) )

#>#include <sqlite3.h><#

(use (srfi 1 12 13 18 26 69) extras lolevel)
(use tinyclos synch miscmacros)

;;;

;; Only works when the invoked object is a procedure.
;; Macros & values will not work.
(define-macro thunker cut)

(define core:abort abort)   ; abort overridden by sqlite3:status enum

;;; Foreign types & values

;; Enumeration and constant definitions

(define-foreign-enum (sqlite3:status int)
  #f ; no aliases
  (ok		    SQLITE_OK	#f)	  ; Successful result
  (error	    SQLITE_ERROR)	  ; SQL error or missing database
  (internal	    SQLITE_INTERNAL)	  ; NOT USED. Internal logic error in SQLite
  (permission	    SQLITE_PERM)	  ; Access permission denied
  (abort	    SQLITE_ABORT)	  ; Callback routine requested an abort
  (busy		    SQLITE_BUSY)	  ; The database file is locked
  (locked	    SQLITE_LOCKED)	  ; A table in the database is locked
  (no-memory	    SQLITE_NOMEM)	  ; A malloc() failed
  (read-only	    SQLITE_READONLY)	  ; Attempt to write a readonly database
  (interrupt	    SQLITE_INTERRUPT)	  ; Operation terminated by sqlite3_interrupt()
  (io-error	    SQLITE_IOERR)	  ; Some kind of disk I/O error occurred
  (corrupt	    SQLITE_CORRUPT)	  ; The database disk image is malformed
  (not-found	    SQLITE_NOTFOUND)	  ; NOT USED. Table or record not found
  (full		    SQLITE_FULL)	  ; Insertion failed because database is full
  (cant-open	    SQLITE_CANTOPEN)	  ; Unable to open the database file
  (protocol	    SQLITE_PROTOCOL)	  ; NOT USED. Database lock protocol error
  (empty	    SQLITE_EMPTY)	  ; Database is empty
  (schema	    SQLITE_SCHEMA)	  ; The database schema changed
  (too-big	    SQLITE_TOOBIG)	  ; String or BLOB exceeds size limit
  (constraint	    SQLITE_CONSTRAINT)	  ; Abort due to contraint violation
  (mismatch	    SQLITE_MISMATCH)	  ; Data type mismatch
  (misuse	    SQLITE_MISUSE)	  ; Library used incorrectly
  (no-lfs	    SQLITE_NOLFS)	  ; Uses OS features not supported on host
  (authorization    SQLITE_AUTH)	  ; Authorization denied
  (format	    SQLITE_FORMAT)	  ; Auxiliary database format error
  (range	    SQLITE_RANGE)	  ; 2nd parameter to sqlite3_bind out of range
  (not-a-database   SQLITE_NOTADB)	  ; File opened that is not a database file
  (row		    SQLITE_ROW)		  ; sqlite3_step() has another row ready
  (done		    SQLITE_DONE) )	  ; sqlite3_step() has finished executing

(define-foreign-enum (sqlite3:type int)
  #f ; no aliases
  (integer  SQLITE_INTEGER)
  (float    SQLITE_FLOAT)
  (text	    SQLITE_TEXT)
  (blob	    SQLITE_BLOB)
  (null	    SQLITE_NULL) )

;; Types

(define-foreign-type sqlite3:context (c-pointer "sqlite3_context"))

(define-foreign-type sqlite3:value (c-pointer "sqlite3_value"))

;;; Classes for databases and statements

(define-class <sqlite3:database> (<c++-object>) (busy-handler))
(define-foreign-type sqlite3:database
  (instance "sqlite3" <sqlite3:database>)
  (lambda (db)
    (unless (slot-ref db 'this)
      (abort-sqlite3-null-error 'sqlite3:database->c-pointer db))
    db))
(define-method (initialize (this <sqlite3:database>) initargs)
  (call-next-method)
  (initialize-slots this initargs) )

(define-class <sqlite3:statement> (<c++-object>) (database sql))
(define-foreign-type sqlite3:statement
  (instance "sqlite3_stmt" <sqlite3:statement>)
  (lambda (stmt)
    (unless (slot-ref stmt 'this)
      (abort-sqlite3-null-error 'sqlite3:statement->c-pointer stmt))
    stmt))

(define-method (initialize (this <sqlite3:statement>) initargs)
  (call-next-method)
  (initialize-slots this initargs) )

;;; Helpers

;; Expand variables in pathname
(define sqlite3:resolve-pathname
  ##sys#expand-home-path
  #; ;not needed, yet
  (cute ##sys#pathname-resolution <> identity) )

;; Conditions

(define (make-exn-condition loc msg . args)
  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )

(define (make-sqlite3-condition sta)
  (make-property-condition 'sqlite3 'status sta) )

(define (make-sqlite3-error-condition loc msg sta . args)
   (make-composite-condition
    (apply make-exn-condition loc msg args)
    (make-sqlite3-condition sta)) )

(define (make-no-data-condition loc stmt params)
  (make-sqlite3-error-condition loc
                                "the statement returned no data"
                                'done
                                stmt params) )

;; Errors
(define ((abort-sqlite3-error loc db . args) sta)
  (core:abort
   (apply make-sqlite3-error-condition
          loc
          (if db (sqlite3:errmsg db) (symbol->string sta))
          sta
          args)))

(define (check-sqlite3-type loc obj class)
  (unless (instance-of? obj class)
    (core:abort
     (make-composite-condition
      (make-exn-condition loc
                          (string-append
                           "bad argument type " (class-name (class-of obj))
                           ", expected " (class-name class))
		          obj)
      (make-property-condition 'type)
      (make-sqlite3-condition 'error)))) )

(define (abort-sqlite3-null-error loc obj)
  (core:abort
   (make-sqlite3-error-condition loc
                                 (string-append
                                  "bad " (class-name (class-of obj))
                                  " object, contained pointer is #f")
                                 'error
                                 obj)) )
(define (print-error msg obj)
  (print-error-message obj (current-error-port) (string-append "Error: " msg)) )

;; Tree dictionary

(define (make-hash-table-tree/synch id . args)
  (make-object/synch (apply make-hash-table args) id) )

(define (hash-table-tree-set! ht-tree keys value)
  (if (null? (cdr keys))
      (hash-table-set! ht-tree (car keys) value)
      (hash-table-update! ht-tree
                          (car keys)
                          (cute hash-table-tree-set! <> (cdr keys) value)
                          (thunker make-hash-table)) )
  ht-tree )

(define (hash-table-tree-delete! ht-tree keys)
  (if (null? (cdr keys))
      (hash-table-delete! ht-tree (car keys))
      (hash-table-update! ht-tree
                          (car keys)
                          (cute hash-table-tree-delete! <> (cdr keys))
                          (thunker make-hash-table)) )
  ht-tree )

(define (hash-table-tree-ref
	 ht-tree keys
	 #!optional
	 (thunk (thunker abort
                         (make-composite-condition
                          (make-exn-condition 'hash-table-tree-ref
                                              "hash-table-tree does not contain path"
                                              ht-tree keys)
                          (make-property-condition 'access)))))
  (let/cc return
    (let loop ([ht ht-tree]
               [keys keys] )
      (if (null? keys)
	  ht
	  (loop (hash-table-ref ht (car keys) (thunker return (thunk)))
	        (cdr keys)) ) ) ) )

(define (hash-table-tree-ref/default ht-tree keys default)
  (hash-table-tree-ref ht-tree keys (lambda () default)) )

(define (hash-table-tree-clear! htt id elt-clear)
  (cond [(hash-table-ref/default htt id #f)
         => (cute hash-table-walk <> elt-clear) ] )
  (hash-table-delete! htt id) )

;; SQL collation sequence interface

(define *sqlite3:collations* (make-hash-table-tree/synch 'sqlite3:collations))

(define-external (chicken_sqlite3_collation_stub (scheme-object qn) (int la)
                                                 (c-pointer da) (int lb)
                                                 (c-pointer db))
                 int
  (let/cc return
    (let ([r #f])
      (dynamic-wind
          noop
          (lambda ()
	    (handle-exceptions exn
	                       (print-error "in collation function" exn)
	      (let ([a (make-string la)]
	            [b (make-string lb)] )
                (move-memory! da a la)
	        (move-memory! db b lb)
	        (set! r
		      ((vector-ref (call-with/synch *sqlite3:collations*
		                     (cute hash-table-tree-ref <> qn))
		                   1)
		       a b)))))
          (lambda ()
            (if (and (integer? r) (exact? r))
                (return r)
                (begin
                  (print-error "in collation function: invalid return value" (->string r))
                  (return 0))))) ) ) )

(define sqlite3_create_collation
  (foreign-lambda* sqlite3:status
                  ((sqlite3:database db) (c-string name) (scheme-object qn))
#<<EOS
  if (qn == C_SCHEME_FALSE)
    return(sqlite3_create_collation(db, name, SQLITE_UTF8, NULL, NULL));
  else
    return(sqlite3_create_collation(db, name, SQLITE_UTF8,
  				      (void *)qn,
  				      (int (*)(void *,
  					       int, const void *,
  					       int, const void *))
  					&chicken_sqlite3_collation_stub));
EOS
  ))

(define-generic sqlite3:define-collation)
(define-method (sqlite3:define-collation (db <sqlite3:database>)
					 (name <string>))
  (cond [(sqlite3_create_collation db name #f)
         => (abort-sqlite3-error 'sqlite3:define-collation db name) ]
        [else
         (let ([qn (list (pointer->address (slot-ref db 'this)) name)])
           (call-with/synch *sqlite3:collations*
             (lambda (col)
               (cond [(hash-table-tree-ref/default col qn #f)
                      => (lambda (info)
                           (hash-table-tree-delete! col qn)
                           (object-release (vector-ref info 0))) ] ) ) ) ) ] ) )

(define-method (sqlite3:define-collation (db <sqlite3:database>)
					  (name <string>)
					  (proc <procedure-class>))
  (let ([qn (object-evict (list (pointer->address (slot-ref db 'this)) name))])
    (cond [(sqlite3_create_collation db name qn)
           => (lambda (s)
                (object-release qn)
                ((abort-sqlite3-error 'sqlite3:define-collation db name proc) s)) ]
          [else
           (call-with/synch *sqlite3:collations*
	(cute hash-table-tree-set! <> qn (vector qn proc))) ] ) ) )

;;; SQL function interface

(define *sqlite3:functions* (make-hash-table-tree/synch 'sqlite3:functions))

(define *sqlite3:seeds* (make-hash-table-tree/synch 'sqlite3:seeds))

(define (sqlite3:parameter-data n args)
  (let loop ([i 0])
    (if (<= n i)
	'()
	(cons (case ((foreign-lambda* sqlite3:type
                                      (((c-pointer sqlite3:value) args) (int i))
                      "return(sqlite3_value_type(args[i]));")
                     args i)
                [(integer)
                 ((foreign-lambda* integer
                                   (((c-pointer sqlite3:value) args) (int i))
                   "return(sqlite3_value_double(args[i]));")
                  args i) ]
                [(float)
                 ((foreign-lambda* double
                                   (((c-pointer sqlite3:value) args) (int i))
                   "return(sqlite3_value_double(args[i]));")
                  args i) ]
                [(text)
                 ((foreign-primitive scheme-object
                                     (((c-pointer sqlite3:value) args) (int i))
                   "int n = sqlite3_value_bytes(args[i]);"
                   "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
                   "return(C_string(&s, n, (char *)sqlite3_value_text(args[i])));")
                  args i) ]
                [(blob)
                 ((foreign-primitive scheme-object
                                     (((c-pointer sqlite3:value) args) (int i))
                   "int n = sqlite3_value_bytes(args[i]);"
                   "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
                   "return(C_bytevector(&s, n, (char *)sqlite3_value_blob(args[i])));")
                  args i) ]
                [else
                 <void> ] )
              (loop (add1 i)) ) ) ) )

(define-generic sqlite3:set-result!)
(define-method (sqlite3:set-result! (ctx <pointer>) (v <blob>))
  ((foreign-lambda* void
                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
   ctx v (blob-size v)) )

; Deprecated
(define-method (sqlite3:set-result! (ctx <pointer>) (v <byte-vector>))
  ((foreign-lambda* void
                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
   ctx v (byte-vector-length v)) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <exact>))
  ((foreign-lambda void "sqlite3_result_int" sqlite3:context int)
   ctx v) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <number>))
  ((foreign-lambda void "sqlite3_result_double" sqlite3:context double)
   ctx v) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <string>))
  ((foreign-lambda* void
                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    "sqlite3_result_text(ctx, v, n, SQLITE_TRANSIENT);")
   ctx v (string-length v)) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <void>))
  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
   ctx) )

(define-method (sqlite3:set-result! (ctx <pointer>))
  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
   ctx) )

(define sqlite3_user_data
  (foreign-lambda scheme-object "sqlite3_user_data" sqlite3:context))

(define-external (chicken_sqlite3_function_stub (c-pointer ctx) (int n) (c-pointer args))
                 void
  (let/cc return
    (dynamic-wind
        noop
        (lambda ()
          (handle-exceptions exn
                             (print-error "in SQL function" exn)
            (sqlite3:set-result!
             ctx
             (apply (vector-ref
                     (call-with/synch *sqlite3:functions*
                      (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))
                     1)
                    (sqlite3:parameter-data n args) ) ) ) )
       (lambda ()
         (return (void)) ) ) ) )

(define sqlite3_aggregate_context
  (foreign-lambda* integer ((sqlite3:context ctx))
   "return((int)sqlite3_aggregate_context(ctx, 1));"))

(define-external (chicken_sqlite3_step_stub (c-pointer ctx) (int n) (c-pointer args))
                 void
  (let/cc return
    (dynamic-wind
        noop
        (lambda ()
          (handle-exceptions exn
                             (print-error "in step of SQL function" exn)
            (let ([info (call-with/synch *sqlite3:functions*
                          (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
              (call-with/synch *sqlite3:seeds*
               (cute hash-table-update!/default
                     <>
                     (sqlite3_aggregate_context ctx)
                     (lambda (seed)
                       (apply (vector-ref info 1) seed (sqlite3:parameter-data n args)))
                     (vector-ref info 2)) ) ) ) )
	   (lambda ()
	     (return (void)) ) ) ) )

(define-external (chicken_sqlite3_final_stub (c-pointer ctx))
                 void
  (let/cc return
    (let ([agc (sqlite3_aggregate_context ctx)])
      (dynamic-wind
	  noop
	  (lambda ()
	    (handle-exceptions exn
	                       (print-error "in final of SQL function" exn)
	      (let ([info (call-with/synch *sqlite3:functions*
			   (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
	        (cond [((vector-ref info 3)
                 (call-with/synch *sqlite3:seeds*
                   (cute hash-table-ref/default <> agc (vector-ref info 2))))
                 => (cute sqlite3:set-result! ctx <>) ]
                [else
                 (sqlite3:set-result! ctx) ] ) ) ) )
	  (lambda ()
	    (call-with/synch *sqlite3:seeds*
	     (cute hash-table-delete! <> agc))
	    (return (void)) ) ) ) ) )

(define-generic sqlite3:define-function)
(define-method (sqlite3:define-function (db <sqlite3:database>)
					 (name <string>)
					 (n <exact>)
					 (proc <procedure-class>))
  (let ([qn (object-evict (list (pointer->address (slot-ref db 'this)) name))])
    (cond [((foreign-lambda* sqlite3:status
                             ((sqlite3:database db)
                              (c-string name) (int n) (scheme-object qn))
#<<EOS
        return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
  				       (void *)qn,
  				       (void (*)(sqlite3_context *, int,
  				                 sqlite3_value **))
  				       &chicken_sqlite3_function_stub,
  				       NULL,
  				       NULL));
EOS
            )
            db name n qn)
           => (lambda (s)
                (object-release qn)
                ((abort-sqlite3-error 'sqlite3:define-function db name n proc) s)) ]
          [else
           (call-with/synch *sqlite3:functions*
	(cute hash-table-tree-set! <> qn (vector qn proc))) ] ) ) )

(define-method (sqlite3:define-function (db <sqlite3:database>)
					 (name <string>)
					 (n <exact>)
					 (step-proc <procedure-class>)
					 (seed <top>)
					 #!optional (final-proc identity))
  (check-sqlite3-type 'sqlite3:define-function final-proc <procedure-class>)
  (let ([qn (object-evict (list (pointer->address (slot-ref db 'this)) name))])
    (cond [((foreign-lambda* sqlite3:status
                             ((sqlite3:database db)
                              (c-string name) (int n) (scheme-object qn))
#<<EOS
        return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
  				       (void *)qn,
  				       NULL,
  				       (void (*)(sqlite3_context *, int,
  				                 sqlite3_value **))
  				       &chicken_sqlite3_step_stub,
  				       ((void (*)(sqlite3_context *))
  				         &chicken_sqlite3_final_stub)));
EOS
            )
            db name n qn)
           => (lambda (s)
                (object-release qn)
                ((abort-sqlite3-error
                   'sqlite3:define-function db name n step-proc seed final-proc) s)) ]
          [else
           (call-with/synch *sqlite3:functions*
	(cute hash-table-tree-set! <> qn (vector qn step-proc seed final-proc))) ] ) ) )

;;; Database interface

;; Get any error message
(define sqlite3:errmsg
  (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database) )

;; Open a database
(define (sqlite3:open path)
  (check-sqlite3-type 'sqlite3:open path <string>)
  (let-location ([db c-pointer])
    (cond [((foreign-lambda sqlite3:status "sqlite3_open"
                                           nonnull-c-string (c-pointer sqlite3:database))
            (sqlite3:resolve-pathname path) #$db)
           => (abort-sqlite3-error 'sqlite3:open #f path) ]
          [else
           (make <sqlite3:database> 'this db 'busy-handler #f) ] ) ) )

;; Set a timeout until a busy error is thrown

(define *sqlite3:busy-handlers* (make-hash-table-tree/synch 'sqlite3:busy-handlers))

(define (sqlite3:set-busy-timeout! db #!optional (ms 0))
  (check-sqlite3-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
  (cond [((foreign-lambda sqlite3:status "sqlite3_busy_timeout" sqlite3:database int) db ms)
         => (abort-sqlite3-error 'sqlite3:set-busy-timeout! db db ms) ]
        (else
          (call-with/synch *sqlite3:busy-handlers*   ; unregister scheme handler
            (lambda (busy)
              (hash-table-delete! busy
                                  (pointer->address (slot-ref db 'this))))))))

(define-record busy-handler proc db)
(define-external (chicken_sqlite3_busy_handler_stub (c-pointer data) (int count)) int
  (let/cc return
    (let ((r #f))
      (dynamic-wind
          noop
          (lambda ()
            (handle-exceptions exn (print-error "in busy timeout handler" exn)
              (let* ((db-addr (pointer->address data))
                     (data (call-with/synch *sqlite3:busy-handlers*
                                            (lambda (busy) (hash-table-ref busy db-addr))))
                     (handler (busy-handler-proc data))
                     (db (busy-handler-db data)))
                (set! r (handler db count)))))
          (lambda ()
            (return (if r 1 0)))))))

;; Set SQLite library busy handler callback.  This handler must not yield.
;; Callback is called with arguments DB and COUNT.
(define (sqlite3:set-busy-handler! db handler)
  (check-sqlite3-type 'sqlite3:set-busy-handler! db <sqlite3:database>)
  (let ((sqlite3_busy_handler
         (foreign-lambda sqlite3:status "sqlite3_busy_handler"
                         sqlite3:database c-pointer c-pointer))
        (db-ptr (slot-ref db 'this)))
    (cond ((not handler)
           (cond ((sqlite3_busy_handler db #f #f)
                  => (abort-sqlite3-error 'sqlite3:set-busy-handler! db db handler))
                 (else (call-with/synch *sqlite3:busy-handlers*
                         (lambda (busy)
                           (hash-table-delete! busy (pointer->address db-ptr))
                           (void))))))
          ((sqlite3_busy_handler db #$chicken_sqlite3_busy_handler_stub db-ptr)
           => (abort-sqlite3-error 'sqlite3:set-busy-handler! db db handler))
          (else
           (call-with/synch *sqlite3:busy-handlers*
                            (lambda (busy)
                              (hash-table-set! busy
                                               (pointer->address db-ptr)
                                               (make-busy-handler handler db))))))))

;; Set application busy handler.  Does not use a callback, so it is safe
;; to yield.  Handler is called with DB, COUNT and LAST (the last value
;; it returned).  Return true value to continue trying, or #f to stop.
(define (sqlite3:set-safe-busy-handler! db handler)
  (check-sqlite3-type 'sqlite3:set-safe-busy-handler! db <sqlite3:database>)
  (slot-set! db 'busy-handler handler))

;; Returns a closure suitable for use with set-safe-busy-handler!.  Identical
;; to sqlite's default busy handler (set-busy-timeout!), but does not block.
(define (sqlite3:default-safe-busy-handler timeout)
  (define (thread-sleep!/ms ms)
    (thread-sleep!
     (milliseconds->time (+ ms (time->milliseconds (current-time))))))  
  (let* ((delays '#(1 2 5 10 15 20 25 25 25 50 50 100))
         (totals '#(0 1 3  8 18 33 53 78 103 128 178 228))
         (ndelay (vector-length delays)))
    (lambda (db count last)
      last   ; ignored
      (let* ((delay (vector-ref delays (min count (- ndelay 1))))
             (prior (if (< count ndelay)
                        (vector-ref totals count)
                        (+ (vector-ref totals (- ndelay 1))
                           (* delay (- count (- ndelay 1)))))))
        (let ((delay (if (> (+ prior delay) timeout)
                         (- timeout prior)
                         delay)))
          (cond ((<= delay 0) #f)
                (else
                 (thread-sleep!/ms delay)
                 #t)))))))

;; Cancel any running database operation as soon as possible
(define (sqlite3:interrupt! db)
  (check-sqlite3-type 'sqlite3:interrupt! db <sqlite3:database>)
  ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db) )

;; Check whether the database is in autocommit mode
(define (sqlite3:auto-committing? db)
  (check-sqlite3-type 'sqlite3:auto-committing? db <sqlite3:database>)
  ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db) )

;; Get the number of changes made to the database
(define (sqlite3:changes db #!optional (total #f))
  (check-sqlite3-type 'sqlite3:changes db <sqlite3:database>)
  (if total
      ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db)
      ((foreign-lambda number "sqlite3_changes" sqlite3:database) db) ) )

;; Get the row ID of the last inserted row
(define (sqlite3:last-insert-rowid db)
  (check-sqlite3-type 'sqlite3:last-insert-rowid db <sqlite3:database>)
  ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db) )

;; Close a database
(define-generic sqlite3:finalize!)
(define-method (sqlite3:finalize! (db <sqlite3:database>))
  (cond [(not (slot-ref db 'this))
         (void) ]
        [((foreign-safe-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)
         => (abort-sqlite3-error 'sqlite3:finalize! db db) ]
        [else
         (let ([id (pointer->address (slot-ref db 'this))]
               [release-qns (lambda (_ info) (object-release (vector-ref info 0)))] )
           (call-with/synch *sqlite3:collations*
             (cute hash-table-tree-clear! <> id release-qns))
           (call-with/synch *sqlite3:functions*
             (cute hash-table-tree-clear! <> id release-qns)) )
           (slot-set! db 'this #f)
           (slot-set! db 'busy-handler #f)] ) )

;;; Statement interface

;; Create a new statement
(define (sqlite3:prepare db sql)
  (check-sqlite3-type 'sqlite3:prepare db <sqlite3:database>)
  (check-sqlite3-type 'sqlite3:prepare sql <string>)
  (let retry ((retries 0) (last-busy #f))
    (let-location ([stmt c-pointer] [tail c-string])
      (cond [((foreign-safe-lambda sqlite3:status "sqlite3_prepare"
                                   sqlite3:database scheme-pointer int
                                   (c-pointer sqlite3:statement)
                                   (c-pointer (const c-string)))
              db sql (string-length sql) #$stmt #$tail)
             => (lambda (err)
                  (case err
                    ((busy)
                     (let ((h (slot-ref db 'busy-handler)))
                       (cond ((and h (h db retries last-busy))
                              => (lambda (last-busy)
                                   (retry (+ retries 1) last-busy)))
                             (else
                              ((abort-sqlite3-error 'sqlite3:prepare db db sql) err)))))
                    (else
                     ((abort-sqlite3-error 'sqlite3:prepare db db sql) err))))]
            [else
             (values
              (make <sqlite3:statement> 'this stmt 'database db 'sql sql)
              tail) ] ) )) )

;; Recompile an existing statement and transfer all bindings
(define (sqlite3:repair! stmt)
  (check-sqlite3-type 'sqlite3:repair! stmt <sqlite3:statement>)
  (let ([fresh (sqlite3:prepare
		(slot-ref stmt 'database) (slot-ref stmt 'sql))])
    (dynamic-wind
	noop
	(lambda ()
	  (let ([old (slot-ref stmt 'this)]
		[new (slot-ref fresh 'this)] )
	    (cond [((foreign-lambda sqlite3:status "sqlite3_transfer_bindings"
                                             c-pointer c-pointer)
              old new)
             => (abort-sqlite3-error 'sqlite3:repair! (slot-ref stmt 'database) stmt) ]
            [else
             (slot-set! stmt 'this new)
             (slot-set! fresh 'this old) ] ) ) )
	(lambda ()
	  (sqlite3:finalize! fresh))) ) )

;; Discard an existing statement
;; (define-generic sqlite3:finalize!)
(define-method (sqlite3:finalize! (stmt <sqlite3:statement>))
  (cond [(not (slot-ref stmt 'this))
         (void) ]
        [((foreign-lambda sqlite3:status "sqlite3_finalize" sqlite3:statement) stmt)
         => (abort-sqlite3-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt) ]
        [else
         (slot-set! stmt 'this #f) ] ) )

;; Reset an existing statement to process it again
(define sqlite3_reset
  (foreign-lambda sqlite3:status "sqlite3_reset" sqlite3:statement))

(define (sqlite3:reset! stmt)
  (check-sqlite3-type 'sqlite3:reset! stmt <sqlite3:statement>)
  (cond [(sqlite3_reset stmt)
         => (abort-sqlite3-error 'sqlite3:reset! (slot-ref stmt 'database) stmt) ] ) )

;; Get number of bindable parameters
(define (sqlite3:bind-parameter-count stmt)
  (check-sqlite3-type 'sqlite3:bind-parameter-count stmt <sqlite3:statement>)
  ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt) )

;; Get index of a bindable parameter or #f if no parameter with the
;; given name exists
(define (sqlite3:bind-parameter-index stmt name)
  (check-sqlite3-type 'sqlite3:bind-parameter-index stmt <sqlite3:statement>)
  (let ([i ((foreign-lambda int "sqlite3_bind_parameter_index"
                                sqlite3:statement nonnull-c-string)
	    stmt name)])
    (if (zero? i)
        #f
        (sub1 i) ) ) )

;; Get the name of a bindable parameter
(define (sqlite3:bind-parameter-name stmt i)
  (check-sqlite3-type 'sqlite3:bind-parameter-name stmt <sqlite3:statement>)
  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int)
   stmt (add1 i)) )

;; Bind data as parameters to an existing statement

(define-generic sqlite3:bind!)
(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <blob>))
  (cond [((foreign-lambda* sqlite3:status
                           ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
           "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
          stmt (add1 i) v (blob-size v))
         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )

; Deprecated
(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <byte-vector>))
  (cond [((foreign-lambda* sqlite3:status
                           ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
           "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
          stmt (add1 i) v (byte-vector-length v))
         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <boolean>))
  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int"
                                         sqlite3:statement int int)
          stmt (add1 i) (or (and v 1) 0))
         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <exact>))
  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int"
                                         sqlite3:statement int int)
          stmt (add1 i) v)
         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <number>))
  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_double"
                                          sqlite3:statement int double)
          stmt (add1 i) v)
         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <string>))
  (cond [((foreign-lambda* sqlite3:status
                           ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
           "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
          stmt (add1 i) v (string-length v))
         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>))
  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int)
          stmt (add1 i))
         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i) ] ) )

; Helper

(define (bind-parameters! loc stmt params)
  (sqlite3:reset! stmt)
  (let ([cnt (sqlite3:bind-parameter-count stmt)])
    (if (= cnt (length params))
        (unless (zero? cnt)
          (for-each
           (lambda (i v)
             (if (eq? <void> v)
                 (sqlite3:bind! stmt i)
                 (sqlite3:bind! stmt i v) ) )
           (iota cnt) params) )
        (core:abort
         (make-composite-condition
          (make-exn-condition
           loc
           (conc "bad parameter count - received " (length params) " but expected " cnt))
          (make-property-condition 'arity)
          (make-sqlite3-condition 'error))) ) ) )

(define (sqlite3:bind-parameters! stmt . params)
  (bind-parameters! 'sqlite3:bind-parameters! stmt params) )

;; Single-step a prepared statement, return #t if data is available,
;; #f otherwise
(define sqlite3_step
  (foreign-safe-lambda sqlite3:status "sqlite3_step" sqlite3:statement))
(define (sqlite3:step! stmt)
  (check-sqlite3-type 'sqlite3:step! stmt <sqlite3:statement>)
  (let retry ((retries 0) (last-busy #f))
    (let ([s (sqlite3_step stmt)])
      (case s
	[(row)
	 #t ]
	[(done)
	 #f ]
	[(error)
	 (let ([s (sqlite3_reset stmt)])
	   (case s
	     [(schema)
	      (sqlite3:repair! stmt)
	      (retry retries last-busy) ]
	     [else
	      ((abort-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ] ) ) ]
        [(busy)
         (let* ((db (slot-ref stmt 'database))
                (h (slot-ref db 'busy-handler)))
           (cond ((and h (h db retries last-busy))
                  => (lambda (last-busy)
                       (retry (+ retries 1) last-busy)))
                 (else
                  ((abort-sqlite3-error 'sqlite3:step! db stmt) s))))]
	[else
	 ((abort-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ] ) ) ) )

;; Retrieve information from a prepared/stepped statement
(define (sqlite3:column-count stmt)
  (check-sqlite3-type 'sqlite3:column-count stmt <sqlite3:statement>)
  ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt) )

(define (sqlite3:column-type stmt i)
  (check-sqlite3-type 'sqlite3:column-type stmt <sqlite3:statement>)
  ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i) )

(define (sqlite3:column-declared-type stmt i)
  (check-sqlite3-type 'sqlite3:column-declared-type stmt <sqlite3:statement>)
  ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i) )

(define (sqlite3:column-name stmt i)
  (check-sqlite3-type 'sqlite3:column-name stmt <sqlite3:statement>)
  ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i) )

;; Retrieve data from a stepped statement
(define (sqlite3:column-data stmt i)
  (case (sqlite3:column-type stmt i)
    [(integer)
     ((foreign-lambda integer "sqlite3_column_double" sqlite3:statement int) stmt i) ]
    [(float)
     ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i) ]
    [(text)
     ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
       "int n = sqlite3_column_bytes(stmt, i);"
       "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
       "return(C_string(&s, n, (char *)sqlite3_column_text(stmt, i)));")
      stmt i) ]
    [(blob)
     ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
       "int n = sqlite3_column_bytes(stmt, i);"
       "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
       "return(C_bytevector(&s, n, (char *)sqlite3_column_blob(stmt, i)));")
      stmt i) ]
    [else
     <void> ] ) )

;;; Easy statement interface

;; Compile a statement and call a procedure on it, then finalize the
;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
(define (sqlite3:call-with-temporary-statements proc db . sqls)
  (check-sqlite3-type 'sqlite3:call-with-temporary-statements db <sqlite3:database>)
  (let ([stmts #f] [e #f])
    (dynamic-wind
	(lambda ()
	  (unless stmts
	    (set! stmts (map (cute sqlite3:prepare db <>) sqls))))
	(lambda ()
          (handle-exceptions exn (begin
                                   (print-error "call-with-temporary-statements" exn)
                                   (set! e exn))
              (apply proc stmts)))
	(lambda ()
	  (when stmts
	    (map sqlite3:finalize! stmts)
	    (set! stmts #f))
          (and-let* ((ec e))
            (set! e #f)
            (signal ec))))))

;; Step through a statement and ignore possible results
(define-generic sqlite3:exec)
(define-method (sqlite3:exec (stmt <sqlite3:statement>) . params)
  (bind-parameters! 'sqlite3:exec stmt params)
  (while (sqlite3:step! stmt))
  (void) )

(define-method (sqlite3:exec (db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute apply sqlite3:exec <> params)
   db sql) )

;; Step through a statement, ignore possible results and return the
;; count of changes performed by this statement
(define-generic sqlite3:update)
(define-method (sqlite3:update (stmt <sqlite3:statement>) . params)
  (sqlite3:reset! stmt)
  (apply sqlite3:exec stmt params)
  (sqlite3:changes (slot-ref stmt 'database)) )

(define-method (sqlite3:update (db <sqlite3:database>) (sql <string>) . params)
  (apply sqlite3:exec db sql params)
  (sqlite3:changes db) )

;; Return only the first column of the first result row produced by this
;; statement

(define-generic sqlite3:first-result)
(define-method (sqlite3:first-result (stmt <sqlite3:statement>) . params)
  (bind-parameters! 'sqlite3:first-result stmt params)
  (if (sqlite3:step! stmt)
      (let ([r (sqlite3:column-data stmt 0)])
	(sqlite3:reset! stmt)
	r )
      (core:abort (make-no-data-condition 'sqlite3:first-result stmt params)) ) )

(define-method (sqlite3:first-result
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute apply sqlite3:first-result <> params)
   db sql) )

;; Return only the first result row produced by this statement as a list

(define-generic sqlite3:first-row)
(define-method (sqlite3:first-row (stmt <sqlite3:statement>) . params)
  (bind-parameters! 'sqlite3:first-row stmt params)
  (if (sqlite3:step! stmt)
      (map (cute sqlite3:column-data stmt <>)
           (iota (sqlite3:column-count stmt)))
      (core:abort (make-no-data-condition 'sqlite3:first-row stmt params)) ) )

(define-method (sqlite3:first-row
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute apply sqlite3:first-row <> params)
   db sql))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulating results.

(define (%fold-row loc proc stmt init params)
  (bind-parameters! loc stmt params)
  (let ([cl (iota (sqlite3:column-count stmt))])
    (let loop ([acc init])
      (if (sqlite3:step! stmt)
          (loop (apply proc acc (map (cute sqlite3:column-data stmt <>) cl)))
          acc ) ) ) )

(define-generic sqlite3:fold-row)
(define-method (sqlite3:fold-row (proc <procedure-class>)
                                 (stmt <sqlite3:statement>)
                                 (init <object>) . params)
  (%fold-row 'sqlite3:fold-row proc stmt init params) )

(define-method (sqlite3:fold-row (proc <procedure-class>)
                                 (db <sqlite3:database>)
                                 (sql <string>)
                                 (init <object>) . params)
  (sqlite3:call-with-temporary-statements
   (cute apply sqlite3:fold-row proc <> init params)
   db sql) )

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and discard the results

(define (for-each-row-proc proc)
  (lambda (acc . cols)
    (apply proc cols)
    acc ) )

(define-generic sqlite3:for-each-row)
(define-method (sqlite3:for-each-row (proc <procedure-class>)
                                     (stmt <sqlite3:statement>) . params)
  (%fold-row 'sqlite3:for-each-row (for-each-row-proc proc) stmt (void) params) )

(define-method (sqlite3:for-each-row (proc <procedure-class>)
                                     (db <sqlite3:database>)
                                     (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute apply sqlite3:for-each-row proc <> params)
   db sql) )

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulate the results in a list

(define (map-row-proc proc)
  (lambda (acc . cols)
    (cons (apply proc cols) acc) ) )

(define-generic sqlite3:map-row)
(define-method (sqlite3:map-row (proc <procedure-class>)
                                (stmt <sqlite3:statement>) . params)
  (reverse! (%fold-row 'sqlite3:map-row (map-row-proc proc) stmt '() params)) )

(define-method (sqlite3:map-row (proc <procedure-class>)
                                (db <sqlite3:database>)
                                (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute apply sqlite3:map-row proc <> params)
   db sql) )

;;; Utility procedures

;; Run a thunk within a database transaction, commit if return value is
;; true, rollback if return value is false or the thunk is interrupted by
;; an exception
(define (sqlite3:with-transaction db thunk #!optional (type 'deferred))
  (check-sqlite3-type 'sqlite3:with-transaction db <sqlite3:database>)
  (check-sqlite3-type 'sqlite3:with-transaction thunk <procedure-class>)
  (unless (memq type '(deferred immediate exclusive))
    (core:abort
     (make-composite-condition
      (make-exn-condition 'sqlite3:with-transaction
                          "bad argument: expected deferred, immediate or exclusive"
                          type)
      (make-property-condition 'type))) )
  (let ([success? #f] [e #f])
    (dynamic-wind
	(lambda ()
	  (sqlite3:exec db
	   (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
	(lambda ()
          (handle-exceptions exn (begin
                                   (print-error "with-transaction" exn)
                                   (set! e exn))
            (set! success? (thunk))))
	(lambda ()
	  (sqlite3:exec db
                        (if success?
                            "COMMIT TRANSACTION;"
                            "ROLLBACK TRANSACTION;"))
          (and-let* ((exn e))
            (set! e #f)
            (signal exn))))))

;; Check if the given string is a valid SQL statement
(define sqlite3:complete?
  (foreign-lambda bool "sqlite3_complete" nonnull-c-string))

;; Return a descriptive version string
(define sqlite3:library-version
  (foreign-lambda c-string "sqlite3_libversion") )

;; Enables (disables) the sharing of the database cache and schema data
;; structures between connections to the same database.
(define (sqlite3:enable-shared-cache! enable?)
  (cond
   (((foreign-lambda sqlite3:status "sqlite3_enable_shared_cache" bool) enable?)
    => (abort-sqlite3-error 'sqlite3:enable-shared-cache! #f))))

;; Return a Scheme boolean for the usual SQLite column boolean values
(define (sqlite3:boolean-value v)
  (cond [(string? v)
         (or (string-ci=? "Y" v)
             (string-ci=? "YES" v)
             (string=? "Yes" v)) ]
        [(and (integer? v) (exact? v))
         (not (zero? v)) ]
        [else
          #f ] ) )