sqlite3.sls

;;;; sqlite3.scm
;;;; :tabSize=2:indentSize=2:noTabs=true:
;;;; bindings to the SQLite3 database library

#!chezscheme
(library
 (sqlite3)
 (export
  ;; procedures
  open-database
                                        ;define-collation
                                        ;define-function
  set-busy-handler!
                                        ;make-busy-timeout
  sqlite3-busy-timeout
  interrupt!
  auto-committing?
  change-count
  last-insert-rowid
  finalize!
  prepare
  source-sql
  reset!
  bind-parameter-count
  bind-parameter-index
  bind-parameter-name
  bind!
  bind-parameters!
  step!
  column-count
  column-type
  column-declared-type
  column-name
  column-data
  call-with-temporary-statements
  execute
  update
  first-result
  first-row
  fold-row
  for-each-row
  map-row
  with-transaction
  sql-complete?
  database-version
  database-memory-used
  database-memory-highwater
  enable-shared-cache!
  enable-load-extension!

  sqlite3-trace
  sqlite3-config-log)

 (import
  (chezscheme)
  (srfi s0 cond-expand)
  (srfi s2 and-let)
  (matchable)
  (only (srfi s13 strings) string-contains-ci)
  (srfi s11 let-values)
  (srfi s26 cut)
  (sql-null))

 #;(define (sqlite3-library-init))
 (define libinit
   (begin
     (case (machine-type)
       [(i3nt a6nt i3mw a6mw)
	(load-shared-object "sqlite3.dll")]
       [else
	(load-shared-object "libsqlite3.so.0")])))
 ;(define libinit (begin (load-shared-object "sqlite3.dll")))
 ;; compatibility functions
 (define (hashtable-walk ht f)
   (vector-for-each (lambda (x)
                      (f x (hashtable-ref ht x #f)))
                    (hashtable-keys ht)))

 (define (->string x)
   (with-output-to-string (lambda () (display x))))

 (define (conc . args)
   (apply string-append (map ->string args)) )

;;; Foreign types & values

 ;; Enumeration and constant definitions
 (define sqlite3:status
   '((ok         .  0) ; Successful result (#f?)
     (error      .  1) ; SQL error or missing database
     (internal   .  2) ; NOT USED. Internal logic error in SQLite
     (permission .  3) ; Access permission denied
     (abort      .  4) ; Callback routine requested an abort
     (busy       .  5) ; The database file is locked
     (locked     .  6) ; A table in the database is locked
     (no-memory  .  7) ; A malloc() failed
     (read-only  .  8) ; Attempt to write a readonly database
     (interrupt  .  9) ; Operation terminated by sqlite3_interrupt()
     (io-error   . 10) ; Some kind of disk I/O error occurred
     (corrupt    . 11) ; The database disk image is malformed
     (not-found  . 12) ; NOT USED. Table or record not found
     (full       . 13) ; Insertion failed because database is full
     (cant-open  . 14) ; Unable to open the database file
     (protocol   . 15) ; NOT USED. Database lock protocol error
     (empty      . 16) ; Database is empty
     (schema     . 17) ; The database schema changed
     (too-big    . 18)  ; String or BLOB exceeds size limit
     (constraint . 19) ; Abort due to contraint violation
     (mismatch   . 20) ; Data type mismatch
     (misuse     . 21) ; Library used incorrectly
     (no-lfs     . 22) ; Uses OS features not supported on host
     (auth       . 23) ; Authorization denied
     (format     . 24) ; Auxiliary database format error
     (range      . 25) ; 2nd parameter to sqlite3_bind out of range
     (not-a-db   . 26) ; File opened that is not a database file
     (notice     . 27) ; Notifications from sqlite3_log()
     (warning    . 28) ; Warnings from sqlite3_log()
     (row       . 100) ; sqlite3_step() has another row ready
     (done      . 101) ; sqlite3_step() has finished executing
     ))

 (define (number->sqlite3:status status)
   (let ([x (find (lambda (a) (equal? (cdr a) status)) sqlite3:status)])
     (if (pair? x) (car x) #f)))

 (define sqlite3:type-enum (make-enumeration '(undefined integer float text blob null)))
 (define sqlite3:type-index (enum-set-indexer sqlite3:type-enum))
 (define (sqlite3:type-ref index)
   (list-ref (enum-set->list sqlite3:type-enum) index))

 

 ;; Auxiliary types

 (define-ftype sqlite3:context void*)

 (define-ftype sqlite3:value void*)

 ;; Types for databases and statements

 (define-ftype sqlite3:database* void*)

 (define-ftype sqlite3:database** (* sqlite3:database*))
                                        ;(define-check+error-type database)
 (define-ftype sqlite3:statement* void*)
 (define-ftype sqlite3:statement** (* sqlite3:statement*))

 (define-record-type (&sqlite3 make-sqlite3-condition $sqlite3-condition?)
   (parent &condition)
   (fields (immutable status $sqlite3-condition-status)))

 (define-record-type database
   (fields
    (mutable ptr)
    (mutable busy-handler)))

 (define-record-type statement
   (fields
    (mutable ptr)
    (mutable database)
    (mutable sql)))

                                        ;(define-check+error-type statement)

;;; Helpers

 ;; Conditions
 (define rtd (record-type-descriptor &sqlite3))
 (define sqlite3-condition? (condition-predicate rtd))
 (define sqlite3-status (condition-accessor rtd $sqlite3-condition-status))

 (define (make-sqlite3-error-condition loc msg sta . args)
   (condition
    (make-sqlite3-condition sta)
    (make-who-condition loc)
    (make-message-condition msg)
    (make-irritants-condition args)
    ))

 (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)
   (lambda (sta)
     (if (not (equal? sta 0))
         (raise
          (apply make-sqlite3-error-condition
                 loc
                 (if db (sqlite3-errmsg db) "sta")
                 sta
                 args)))))

 (define (print-error-message obj port str)
   (display obj port) (display str port) (newline port))

 (define (print-error msg obj)
   (print-error-message obj (current-error-port) (string-append "Error: " msg)))

;;; Database interface

 ;; Get any error message
 (define sqlite3_errmsg
   (foreign-procedure "sqlite3_errmsg" (sqlite3:database*) string))
 (define (sqlite3-errmsg db)
   (check-database 'sqlite3-errmsg db)
   (sqlite3_errmsg (database-addr db)))

 ;; Open a database
 (define (open-database path)
   (assert (and open-database (string? path)))
   (let* ([ptr (make-ftype-pointer sqlite3:database**
                                   (foreign-alloc (ftype-sizeof sqlite3:database**)))]
          [f (foreign-procedure "sqlite3_open" (string void*) int)]
          [e (f path (ftype-pointer-address ptr))])
     (if (= e 0)
         (make-database (ftype-&ref sqlite3:database** (*) ptr) #f)
	 ((abort-sqlite3-error 'open-database #f path) e))))

 (define (check-database context db)
   (assert (and context (database? db))))

 (define (check-statement context db)
   (assert (and context (statement? 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 (set-busy-handler! db handler)
   (check-database 'set-busy-handler! db)
   (database-busy-handler-set! db handler))

 (define (sqlite3-busy-timeout db ms)
   (let ([f (foreign-procedure "sqlite3_busy_timeout" (sqlite3:database* int) int)])
     (f (database-addr db) ms)))
 
 (define (database-addr db)
   (ftype-pointer-address (database-ptr db)))

 (define (statement-addr stmt)
   (ftype-pointer-address (statement-ptr stmt)))

 ;; Cancel any running database operation as soon as possible
 (define (interrupt! db)
   (check-database 'interrupt! db)
   (let ([f (foreign-procedure "sqlite3_interrupt" (sqlite3:database*) void)])
     (f (database-addr db))))

 ;; Check whether the database is in autocommit mode
 (define (auto-committing? db)
   (check-database 'auto-committing? db)
   (let ([f (foreign-procedure "sqlite3_get_autocommit" (sqlite3:database*) boolean)])
     (f (database-addr db))))

 ;; Get the number of changes made to the database
 (define change-count
   (case-lambda
     [(db) (change-count db #f)]
     [(db total)
      (check-database 'change-count db)
      (let ([total-changes (foreign-procedure "sqlite3_total_changes" (sqlite3:database*) int)]
            [changes (foreign-procedure "sqlite3_changes" (sqlite3:database*) int)])
        (if total
            (total-changes (database-addr db))
            (changes (database-addr db))))]))

 ;; Get the row ID of the last inserted row
 (define (last-insert-rowid db)
   (check-database 'last-insert-rowid db)
   (let ([f (foreign-procedure "sqlite3_last_insert_rowid" (sqlite3:database*) int)])
     (f (database-addr db))))

 ;; Close a database or statement handle
 (define (sqlite3-finalize db)
   (check-database 'sqlite3-finalize db)
   (let* ([f (foreign-procedure "sqlite3_finalize"  (sqlite3:database*) int)]
          [n (f (database-addr db))])
     (database-ptr-set! db #f)
     n))

 (define (sqlite3-next-stmt db)
   (check-database 'sqlite3-next-stmt db)
   (let* ([f (foreign-procedure "sqlite3_next_stmt" (sqlite3:database*) sqlite3:statement*)]
          [stmt* (f (database-addr db))])
     (make-statement (make-ftype-pointer sqlite3:statement* stmt*)
                     db "")))

 (define finalize!
   (case-lambda
    [(x)
     (finalize! x #f)]
    [(x finalize-statements?)
     (define sqlite3_finalize (foreign-procedure "sqlite3_finalize" (sqlite3:statement*) int))
     (cond
      [(database? x)
       (cond
	[(not (database-ptr x))
	 (void)]
	[(let loop ([stmt
		     (and
		      finalize-statements?
		      (sqlite3-next-stmt x))])
	   (if stmt
	       (or (sqlite3_finalize (statement-ptr stmt))
		   (loop (sqlite3-next-stmt (statement-database stmt))))
	       (let ([f (foreign-procedure "sqlite3_close" (sqlite3:database*) int)])
		 (f (database-addr x)))))
	 => (abort-sqlite3-error 'finalize! x x)])]
      [(statement? x)
       (cond
	[(not (statement-ptr x))
	 (void)]
	[ (sqlite3_finalize (statement-addr x))
	  => (abort-sqlite3-error 'finalize! (statement-database x) x)]
	[else
	 (statement-ptr-set! x #f)])]
      [else
       (errorf 'finalize! "database or statement ~d" x)])]))
     ;; #;(define finalize!
 ;;   (match-lambda*
 ;;    [((? database? db) . finalize-statements?)
 ;;      (cond
 ;;       [(not (database-ptr db))
 ;;       (void)]
 ;;       [(let loop ([stmt
 ;;                   (and
 ;;                     (optional finalize-statements? #f)
 ;;                     (sqlite3_next_stmt db #f))])
 ;;          (if stmt
 ;;              (or (sqlite3_finalize stmt) (loop (sqlite3_next_stmt db stmt)))
 ;;              ((foreign-safe-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)))
 ;;       => (abort-sqlite3-error 'finalize! db db)]
 ;;       [else
 ;;       (let ([id (pointer->address (database-ptr db))]
 ;;             [release-qns (lambda (_ info) (object-release (vector-ref info 0)))])
 ;;         (call-with/synch *collations*
 ;;                           (cute hash-table-tree-clear! <> id release-qns))
 ;;         (call-with/synch *functions*
 ;;                           (cute hash-table-tree-clear! <> id release-qns))
 ;;         (database-ptr-set! db #f)
 ;;         (database-busy-handler-set! db #f))])]
 ;;    [((? statement? stmt))
 ;;      (cond
 ;;       [(not (statement-ptr stmt))
 ;;       (void)]
 ;;       [(sqlite3_finalize (statement-ptr stmt))
 ;;       => (abort-sqlite3-error 'finalize! (statement-database stmt) stmt)]
 ;;       [else
 ;;       (statement-ptr-set! stmt #f)])]
 ;;    [(v . _)
 ;;      (error-argument-type 'finalize! v "database or statement")]))

;;; Statement interface
 (define sqlite3_prepare_v2 (foreign-procedure "sqlite3_prepare_v2"
                                               ( sqlite3:database* u8* int void* u8*) int))
 (define (alloc-statement*)
   (make-ftype-pointer sqlite3:statement**
                       (foreign-alloc (ftype-sizeof sqlite3:statement**))))

 ;; Create a new statement
 (define (prepare db sql)
   (check-database 'prepare db)
   (assert (and prepare (string? sql)))
   (let retry ([retries 0])
     (let* ([ptr (alloc-statement*)]
            [zSql (string->utf8 sql)]
            [nByte (bytevector-length zSql)]
            [e (sqlite3_prepare_v2 (database-addr db) zSql nByte (ftype-pointer-address ptr) #f)])
       (cond [(equal? e 0)
              (make-statement (ftype-&ref sqlite3:statement** (*) ptr) db sql)]
             [else
              (case (number->sqlite3:status e)
                #;[(busy)
                 (let ([h (database-busy-handler db)])
                   (cond
                    [(and h (h db retries))
                     (retry (fx+ retries 1))]
                    [else
                     ((abort-sqlite3-error 'prepare db db sql) e)]))]
                [else
                 ((abort-sqlite3-error 'prepare db db sql) e)])]))))

 ;; Retrieve the SQL source code of a statement
 (define (source-sql stmt)
   (check-statement 'source-sql stmt)
   (let* ([f (foreign-procedure "sqlite3_sql" (sqlite3:statement*) string)])
     (f (statement-addr stmt))))

 (define (finalize-statement! stmt)
   (check-statement 'finalize-statement! stmt)
   (let* ([f (foreign-procedure "sqlite3_finalize"  (sqlite3:statement*) int)]
          [n (f (statement-addr stmt))])
     (statement-ptr-set! stmt #f)
     n))

 ;; Reset an existing statement to process it again
 (define (reset! stmt)
   (check-statement 'reset! stmt)
   (cond [((foreign-procedure  "sqlite3_reset" (sqlite3:statement*) int)
           (statement-addr stmt))
          => (abort-sqlite3-error 'reset! (statement-database stmt) stmt)]))

 ;; Get number of bindable parameters
 (define (bind-parameter-count stmt)
   (check-statement 'bind-parameter-count stmt)
   ((foreign-procedure "sqlite3_bind_parameter_count" (sqlite3:statement*) int)
    (statement-addr stmt)))

 ;; Get index of a bindable parameter or #f if no parameter with the
 ;; given name exists
 (define (bind-parameter-index stmt name)
   (check-statement 'bind-parameter-index stmt)
   (let ([i ((foreign-procedure "sqlite3_bind_parameter_index"
                                (sqlite3:statement* string) int)
             (statement-addr stmt) name)])
     (if (zero? i)
         #f
         (fx- i 1))))

 ;; Get the name of a bindable parameter
 (define (bind-parameter-name stmt i)
   (check-statement 'bind-parameter-name stmt)
   ((foreign-procedure "sqlite3_bind_parameter_name" (sqlite3:statement* int) string)
    (statement-addr stmt) (fx+ i 1)))

 ;; Bind data as parameters to an existing statement

 (define SQLITE_TRANSIENT -1)
 (define (bind! stmt i v)
   (check-statement 'bind! stmt)
   (assert (and bind! (number? i) (>= i 0)))
   (cond
    [(bytevector? v)
     (cond [((foreign-procedure "sqlite3_bind_blob" (sqlite3:statement* int u8* int void*) int)
             (statement-addr stmt) (fx+ i 1) v (bytevector-length v) SQLITE_TRANSIENT)
            => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
    [(or (and (fixnum? v) v) (and (boolean? v) (if v 1 0)))
     => (lambda (v)
          (cond [((foreign-procedure "sqlite3_bind_int64"
                                     (sqlite3:statement* int integer-64) int)
                  (statement-addr stmt) (fx+ i 1) v)
                 => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)]))]
    [(flonum? v)
     (cond [((foreign-procedure "sqlite3_bind_double"
                                (sqlite3:statement* int double) int)
             (statement-addr stmt) (fx+ i 1) (exact->inexact v))
            => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
    [(or (string? v) (number? v))
     (let ([f (foreign-procedure "sqlite3_bind_text"
                                 (sqlite3:statement* int u8* int void*) int)]
           [s (if (string? v)
		  (string->utf8 v)
		  (number->string v))])
       (cond [(f (statement-addr stmt) (fx+ i 1) s (bytevector-length s) SQLITE_TRANSIENT)
              => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)]))]
    [(sql-null? v)
     (cond [((foreign-procedure "sqlite3_bind_null" (sqlite3:statement* int) int)
             (statement-addr stmt) (fx+ i 1))
            => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i)])]
    [else
     (error 'bind! "blob, number, boolean, string or sql-null" v)]))

                                        ; Helper

 (define (%bind-parameters! loc stmt params)
   (reset! stmt)
   (let ([cnt (bind-parameter-count stmt)]
         [vs (make-eq-hashtable)])
     (let loop ([i 0] [params params])
       (match params
         [((? symbol? k) v . rest)
          (cond
           [(bind-parameter-index stmt (string-append ":" (symbol->string k)))
            => (lambda (j)
                 (hashtable-set! vs j v)
                 (loop i rest))]
           [else
            (error loc "value or keyword matching a bind parameter name" k)])]
         [(v . rest)
          (hashtable-set! vs i v)
          (loop (fx+ i 1) rest)]
         [()
          (void)]))
     (if (= (hashtable-size vs) cnt)
         (unless (zero? cnt)
           (hashtable-walk vs (cut bind! stmt <> <>)))
         (raise
          (condition
           (make-who-condition loc)
           (make-message-condition (conc "bad parameter count - received " (hashtable-size vs) " but expected " cnt))
           (make-sqlite3-condition 'error))))))

 (define (bind-parameters! stmt . params)
   (%bind-parameters! 'bind-parameters! stmt params))

 ;; Single-step a prepared statement, return #t if data is available,
 ;; #f otherwise
 (define (step! stmt)
   (check-statement 'step! stmt)
   (let ([db (statement-database stmt)])
     (let retry ([retries 0])
       (let ([s ((foreign-procedure
                  "sqlite3_step" (sqlite3:statement*) int) (statement-addr stmt))])
         (case (number->sqlite3:status s)
           [(row)
            #t]
           [(done)
            #f]
           [(busy)
            (let ([h (database-busy-handler db)])
              (cond
               [(and h (h db retries))
                (retry (fx+ retries 1))]
               [else
                ((abort-sqlite3-error 'step! db stmt) s)]))]
           [else
            ((abort-sqlite3-error 'step! db stmt) s)])))))

 ;; Retrieve information from a prepared/stepped statement
 (define (column-count stmt)
   (check-statement 'column-count stmt)
   ((foreign-procedure "sqlite3_column_count" (sqlite3:statement*) int) (statement-addr stmt)))

 (define (column-type stmt i)
   (check-statement 'column-type stmt)
   (sqlite3:type-ref ((foreign-procedure  "sqlite3_column_type" (sqlite3:statement* int) int) (statement-addr stmt) i)))

 (define (column-declared-type stmt i)
   (check-statement 'column-declared-type stmt)
   ((foreign-procedure "sqlite3_column_decltype" (sqlite3:statement* int) string) (statement-addr stmt) i))

 (define (column-name stmt i)
   (check-statement 'column-name stmt)
   ((foreign-procedure "sqlite3_column_name" (sqlite3:statement* int) string) (statement-addr stmt) i))

 (define sqlite3_column_double
   (foreign-procedure "sqlite3_column_double" (sqlite3:statement* int) double))

 (define sqlite3_column_int64
   (foreign-procedure "sqlite3_column_int64" (sqlite3:statement* int) integer-64))

 (define sqlite3_column_boolean
   (foreign-procedure "sqlite3_column_int" (sqlite3:statement* int) boolean))

 (define (sqlite3-column-bytes stmt i)
   ((foreign-procedure "sqlite3_column_bytes" (sqlite3:statement* int) int)
    (statement-addr stmt) i))

 (define (void*->bytevector ptr len)
   (define-ftype byte-array (array 0 unsigned-8))
   (let ([arr (make-ftype-pointer byte-array ptr)]
         [bv  (make-bytevector len)])
     (let loop ((i 0))
       (when (< i len)
         (bytevector-u8-set! bv i (ftype-ref byte-array (i) arr))
         (loop (fx+ 1 i))))
     bv))

 (define (void*->string ptr len)
   (utf8->string (void*->bytevector ptr len)))

 (define (sqlite3-column-text stmt i)
   (let* ([ptr ((foreign-procedure "sqlite3_column_text" (sqlite3:statement* int) void*)
                (statement-addr stmt) i)]
          [len (sqlite3-column-bytes stmt i)])
     (void*->string ptr len)))

 (define (sqlite3-column-blob stmt i)
   (let* ([ptr ((foreign-procedure "sqlite3_column_blob" (sqlite3:statement* int) void*)
                (statement-addr stmt) i)]
          [len (sqlite3-column-bytes stmt i)])
     (void*->bytevector ptr len)))

 ;; Retrieve data from a stepped statement
 (define (column-data stmt i)
   (case (column-type stmt i)
     [(integer)
      (cond [(and-let* ([type (column-declared-type stmt i)])
	       (string-contains-ci type "bool"))
	     (sqlite3_column_boolean (statement-addr stmt) i)]
	    [else
	     (sqlite3_column_int64 (statement-addr stmt) i)])]
     [(float)
      (sqlite3_column_double (statement-addr stmt) i)]
     [(text)
      (sqlite3-column-text stmt i)]
     [(blob)
      (sqlite3-column-blob stmt i)]
     [else
      (sql-null)]))

;;; 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 (call-with-temporary-statements proc db . sqls)
   (check-database 'call-with-temporary-statements db)
   (let ([stmts #f] [exn #f])
     (dynamic-wind
       (lambda ()
         (unless stmts
           (set! stmts (map (cute prepare db <>) sqls))))
       (lambda ()
         (guard (e [else (set! exn e)])
                (apply proc stmts)))
       (lambda ()
         (and-let* ([s stmts])
                   (set! stmts #f)
                   (for-each finalize! s)) ;; leaks if error occurs before last stmt
         (and-let* ([e exn])
                   (set! exn #f)
                   (raise e))))))

 (define-syntax %define/statement+params
   (syntax-rules ()
     [(%define/statement+params ((name loc) (init ...) (stmt params))
                                body ...)
      (define name
        (let ([impl (lambda (init ... stmt params) body ...)])
          (lambda (init ... db-or-stmt . params)
            (cond
             [(database? db-or-stmt)
              (call-with-temporary-statements
               (cute impl init ... <> (cdr params))
               db-or-stmt (car params))]
             [(statement? db-or-stmt)
              (impl init ... db-or-stmt params)]
             [else
              (error loc "database or statement" db-or-stmt)]))))]
     [(%define/statement+params (name (init ...) (stmt params))
                                body ...)
      (%define/statement+params ((name 'name) (init ...) (stmt params))
                                body ...)]
     [(%define/statement+params (name stmt params)
                                body ...)
      (%define/statement+params ((name 'name) () (stmt params))
                                body ...)]))

                                        ; from chicken miscmacros.scm
 (define-syntax while
   (syntax-rules ()
     ((while test body ...)
      (let loop ()
        (if test
            (begin
              body ...
              (loop)))))))

 ;; Step through a statement and ignore possible results
 (define (%execute loc stmt params)
   (%bind-parameters! loc stmt params)
   (while (step! stmt))
   (void))

 (%define/statement+params (execute stmt params)
                           (%execute 'execute stmt params))

 ;; Step through a statement, ignore possible results and return the
 ;; count of changes performed by this statement
 (%define/statement+params (update stmt params)
                           (%execute 'update stmt params)
                           (change-count (statement-database stmt)))

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

 (%define/statement+params (first-result stmt params)
                           (%bind-parameters! 'first-result stmt params)
                           (if (step! stmt)
                               (let ([r (column-data stmt 0)])
                                 (reset! stmt)
                                 r)
                               (raise (make-no-data-condition 'first-result stmt params))))

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

 (%define/statement+params (first-row stmt params)
                           (%bind-parameters! 'first-row stmt params)
                           (if (step! stmt)
                               (map (cute column-data stmt <>)
                                    (iota (column-count stmt)))
                               (raise (make-no-data-condition 'first-row stmt params))))

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

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

 (define-syntax check-procedure
   (syntax-rules ()
     [(_ loc proc)
      (assert (and loc (procedure? proc)))]))

 (define (fold-row proc init db-or-stmt . params)
   (apply %fold-row 'fold-row proc init db-or-stmt params))

 ;; 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 db-or-stmt . params)
   (check-procedure fold-row proc)
   (apply %fold-row
          'for-each-row
          (lambda (acc . columns)
            (apply proc columns))
          (void)
          db-or-stmt params))

 ;; 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 db-or-stmt . params)
   (check-procedure 'map-row proc)
   (reverse!
    (apply %fold-row
           'map-row
           (lambda (acc . columns)
             (cons (apply proc columns) acc))
           '()
           db-or-stmt params)))

;;; 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 with-transaction
   (case-lambda
     ((db thunk) (with-transaction db thunk 'deferred))
     ((db thunk type)
      (check-database 'with-transaction db)
      (check-procedure 'with-transaction thunk)
      (unless (memq type '(deferred immediate exclusive))
        (error 'with-transaction  "bad argument: expected deferred, immediate or exclusive")
        type)
      (let ([success? #f] [exn #f])
        (dynamic-wind
          (lambda ()
            (execute db
                     (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
          (lambda ()
            (guard (e [else (begin
                              (print-error "with-transaction" exn)
                              (set! exn e))])
                   (set! success? (thunk))
                   success?))
          (lambda ()
            (execute db
                     (if success?
                         "COMMIT TRANSACTION;"
                         "ROLLBACK TRANSACTION;"))
            (and-let* ([e exn])
                      (set! exn #f)
                      (raise e))))))))

 ;; Check if the given string is a valid SQL statement
 (define sql-complete?
   (foreign-procedure "sqlite3_complete" (string) boolean))

 ;; Return a descriptive version string
 (define database-version
   (foreign-procedure "sqlite3_libversion" () string))

 ;; Return the amount of memory currently allocated by the database
 (define database-memory-used
   (foreign-procedure "sqlite3_memory_used" () int))

 ;; Return the maximum amount of memory allocated by the database since
 ;; the counter was last reset
 (define database-memory-highwater
   (case-lambda
     (() (database-memory-highwater #f))
     ((reset?) ((foreign-procedure "sqlite3_memory_highwater" (boolean) int) reset?))))

 ;; Enables (disables) the sharing of the database cache and schema data
 ;; structures between connections to the same database.
 (define (enable-shared-cache! enable?)
   (cond-expand
    [disable-shared-cache
     #f]
    [else
     (cond
      [((foreign-procedure "sqlite3_enable_shared_cache" (boolean) int) enable?)
       => (abort-sqlite3-error 'enable-shared-cache! #f)]
      [else
       enable?])]))

 ;; Enables (disables) the loading of native extensions using SQL statements.
 (define (enable-load-extension! db enable?)
   (cond-expand
    [disable-load-extension
     #f]
    [else
     (cond
      [((foreign-procedure "sqlite3_enable_load_extension" (sqlite3:database* boolean) int) (database-addr db) enable?)
       => (abort-sqlite3-error 'enable-load-extension! db)]
      [else
       enable?])]))

 (define (sqlite3-trace db func data)
   (check-database 'sqlite3-trace db)
   (let ([f (foreign-procedure "sqlite3_trace" (sqlite3:database* void* void*) void)])
     (f (database-addr db) func data)))

 (define (sqlite3-config-log func data)
   ;(check-database 'sqlite3-config-log db)
   (let ([f (foreign-procedure "sqlite3_config" (int void* void*) void)])
     (f 16 func data)))

 (record-writer
  (type-descriptor database)
  (lambda (r p wr)
    (wr
     (if (database-ptr r)
         "#<sqlite3:database>"
         "#<sqlite3:database zombie>")
     p)))
 (record-writer
  (type-descriptor statement)
  (lambda (r p wr)
    (wr
     (if (statement-ptr r)
         (format "#<sqlite3:statement sql=~s>" (statement-sql r))
         "#<sqlite3:statement zombie>")
     p)))


 ) ; library sqlite3