Changeset 8020 in project


Ignore:
Timestamp:
02/01/08 05:02:59 (12 years ago)
Author:
Kon Lovett
Message:

Bug fix & new procs.

Location:
release/3/sqlite3
Files:
6 added
10 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/3/sqlite3/tags/2.0.4/doc.scm

    r7981 r8020  
    88     (usage)
    99     (download "sqlite3.egg")
    10      (requires "synch" "tinyclos" "easyffi")
     10     (requires "synch" "tinyclos" "easyffi" "miscmacros")
    1111
    1212     (documentation
     
    145145           (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <number>)) => <void>")
    146146           (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <string>)) => <void>")
    147            (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <byte-vector>)) => <void>"))
     147           (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <blob>)) => <void>"))
    148148          (p "Can be applied to any statement to bind its free parameter number " (tt "i") " (counting from 0) to the given value. Scheme types of the value map to SQLite types as follows:"
    149149             (table
     
    154154              (tr (td (tt "<number>")) (td (tt "float")))
    155155              (tr (td (tt "<string>")) (td (tt "text")))
    156               (tr (td (tt "<byte-vector>")) (td (tt "blob")))))
     156              (tr (td (tt "<blob>")) (td (tt "blob")))))
    157157          (p "Unless there is internal trouble in SQLite3, this method should always succeeds and never throw an exception. For invalid parameter indices the method just silently does nothing."))
     158        (procedure
     159         "(sqlite3:bind-parameters! (stmt <sqlite3:statement>) . params) => <void>"
     160         (p "Binds the statement's free parameters."))
    158161        (procedure
    159162         "(sqlite3:step! (stmt <sqlite3:statement>)) => <boolean>"
     
    165168         (p "This procedure always succeeds and never throws an exception."))
    166169        (procedure
    167          "(sqlite3:column-data (stmt <sqlite3:statement>) (i <exact>)) => <void | exact | number | string | byte-vector>"
     170         "(sqlite3:column-data (stmt <sqlite3:statement>) (i <exact>)) => <void | exact | number | string | blob>"
    168171         (p "Can be applied to a statement that has just been stepped. Consults " (tt "sqlite3:column-type") " to determine the type of the indicated column and to return its data as an appropriate scheme object.")
    169172         (p "See " (tt "sqlite3:bind!") " for the mapping between Scheme and SQLite data types. Columns of type " (tt "null") " are returned as " (tt "<sqlite3:null-value>") ". Also keep in mind that CHICKEN's " (tt "<exact>") " datatype can only hold a subset of the values an SQLite " (tt "integer") " can store. Large integer values may therefore be returned as floating point numbers from the database, but they will still be of class " (tt "<integer>") ".")
     
    195198        (definition
    196199          (signatures
    197            (signature "method" "(sqlite3:first-result (stmt <sqlite3:statement>) . params) => <void | exact | number | string | byte-vector>")
    198            (signature "method" "(sqlite3:first-result (db <sqlite3:database>) (sql <string>) . params) => <void | exact | number | string | byte-vector>"))
     200           (signature "method" "(sqlite3:first-result (stmt <sqlite3:statement>) . params) => <void | exact | number | string | blob>")
     201           (signature "method" "(sqlite3:first-result (db <sqlite3:database>) (sql <string>) . params) => <void | exact | number | string | blob>"))
    199202          (p "(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning the value of the first column in the first result row. Resets the statement again just before returning.")
    200203          (p "If the given statement does not yield any results, an " (tt "(exn sqlite3)") " is thrown with the " (tt "status") "-property set to " (tt "done") "."))
     
    204207           (signature "method" "(sqlite3:first-row (db <sqlite3:database>) (sql <string>) . params) => <list>"))
    205208          (p "(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning all columns in the first result row as a list.")
    206           (p "If the given statement does not yield any results, an " (tt "(exn sqlite3)") " is thrown with the " (tt "status") "-property set to " (tt "done") "."))
     209          (p "If the given statement does not yield any results, an " (tt "(exn sqlite3)") " is thrown with the " (tt "status") "-property set to " (tt "done") "."))(definition
     210          (signatures
     211           (signature "method" "(sqlite3:fold-row (proc <procedure-class>) (stmt <sqlite3:statement>) initial . params) => <list>")
     212           (signature "method" "(sqlite3:fold-row (proc <procedure-class>) (db <sqlite3:database>) (sql <string>) initial . params) => <list>"))
     213          (p "(Compiles the given SQL), resets the statement, binds the statement's free parameters and executes it step by step. After each step, the column values of the current result row are retrieved and " (tt "proc") " is applied to the current folded value and the column values. The result of the application becomes the new folded value."))
    207214        (definition
    208215          (signatures
     
    239246
    240247     (history
     248      (version "2.0.4" "Added " (code "sqlite3:fold-row") " & " (code "sqlite3:bind-parameters!") ". Fix for introduced bug in " (code "sqlite3:changes") ". [Kon Lovett]")
    241249      (version "2.0.3" "Added " (code "sqlite3:null-value") ", " (code "sqlite3:null-value?") ", and " (code "sqlite3:null") ". [Kon Lovett]")
    242250      (version "2.0.2" "Use of extended " (tt "define-foreign-enum") ". Removed deprecated " (tt "pointer") " use. [Kon Lovett]")
  • release/3/sqlite3/tags/2.0.4/sqlite3.html

    r7981 r8020  
    164164<li>synch</li>
    165165<li>tinyclos</li>
    166 <li>easyffi</li></ul></div>
     166<li>easyffi</li>
     167<li>miscmacros</li></ul></div>
    167168<div class="section">
    168169<h3>Documentation</h3>
     
    341342<br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;number&gt;)) =&gt; &lt;void&gt;
    342343<br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;string&gt;)) =&gt; &lt;void&gt;
    343 <br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;byte-vector&gt;)) =&gt; &lt;void&gt;</dt>
     344<br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;blob&gt;)) =&gt; &lt;void&gt;</dt>
    344345<dd>
    345346<p>Can be applied to any statement to bind its free parameter number <tt>i</tt> (counting from 0) to the given value. Scheme types of the value map to SQLite types as follows:
     
    364365<td><tt>text</tt></td></tr>
    365366<tr>
    366 <td><tt>&lt;byte-vector&gt;</tt></td>
     367<td><tt>&lt;blob&gt;</tt></td>
    367368<td><tt>blob</tt></td></tr></table></p>
    368369<p>Unless there is internal trouble in SQLite3, this method should always succeeds and never throw an exception. For invalid parameter indices the method just silently does nothing.</p></dd>
     370<dt class="definition"><strong>procedure:</strong> (sqlite3:bind-parameters! (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void&gt;</dt>
     371<dd>
     372<p>Binds the statement's free parameters.</p></dd>
    369373<dt class="definition"><strong>procedure:</strong> (sqlite3:step! (stmt &lt;sqlite3:statement&gt;)) =&gt; &lt;boolean&gt;</dt>
    370374<dd>
     
    375379<p>The return value can be one of the symbols <tt>null</tt>, <tt>integer</tt>, <tt>float</tt>, <tt>text</tt> or <tt>blob</tt>.</p>
    376380<p>This procedure always succeeds and never throws an exception.</p></dd>
    377 <dt class="definition"><strong>procedure:</strong> (sqlite3:column-data (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;)) =&gt; &lt;void | exact | number | string | byte-vector&gt;</dt>
     381<dt class="definition"><strong>procedure:</strong> (sqlite3:column-data (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;)) =&gt; &lt;void | exact | number | string | blob&gt;</dt>
    378382<dd>
    379383<p>Can be applied to a statement that has just been stepped. Consults <tt>sqlite3:column-type</tt> to determine the type of the indicated column and to return its data as an appropriate scheme object.</p>
     
    401405<dd>
    402406<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and executes the specified statement ignoring possible results from it, returning the result of applying <tt>sqlite3:changes</tt> to the affected database after the execution of the statement instead.</p></dd>
    403 <dt class="definition"><strong>method:</strong> (sqlite3:first-result (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void | exact | number | string | byte-vector&gt;
    404 <br /><strong>method:</strong> (sqlite3:first-result (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) . params) =&gt; &lt;void | exact | number | string | byte-vector&gt;</dt>
     407<dt class="definition"><strong>method:</strong> (sqlite3:first-result (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void | exact | number | string | blob&gt;
     408<br /><strong>method:</strong> (sqlite3:first-result (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) . params) =&gt; &lt;void | exact | number | string | blob&gt;</dt>
    405409<dd>
    406410<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning the value of the first column in the first result row. Resets the statement again just before returning.</p>
     
    411415<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning all columns in the first result row as a list.</p>
    412416<p>If the given statement does not yield any results, an <tt>(exn sqlite3)</tt> is thrown with the <tt>status</tt>-property set to <tt>done</tt>.</p></dd>
     417<dt class="definition"><strong>method:</strong> (sqlite3:fold-row (proc &lt;procedure-class&gt;) (stmt &lt;sqlite3:statement&gt;) initial . params) =&gt; &lt;list&gt;
     418<br /><strong>method:</strong> (sqlite3:fold-row (proc &lt;procedure-class&gt;) (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) initial . params) =&gt; &lt;list&gt;</dt>
     419<dd>
     420<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and executes it step by step. After each step, the column values of the current result row are retrieved and <tt>proc</tt> is applied to the current folded value and the column values. The result of the application becomes the new folded value.</p></dd>
    413421<dt class="definition"><strong>method:</strong> (sqlite3:for-each-row (proc &lt;procedure-class&gt;) (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void&gt;
    414422<br /><strong>method:</strong> (sqlite3:for-each-row (proc &lt;procedure-class&gt;) (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) . params) =&gt; &lt;void&gt;</dt>
     
    440448<h3>Version</h3>
    441449<ul>
     450<li>2.0.4 Added <code>sqlite3:fold-row</code> &amp; <code>sqlite3:bind-parameters!</code>. Fix for introduced bug in <code>sqlite3:changes</code>. [Kon Lovett]</li>
    442451<li>2.0.3 Added <code>sqlite3:null-value</code>, <code>sqlite3:null-value?</code>, and <code>sqlite3:null</code>. [Kon Lovett]</li>
    443452<li>2.0.2 Use of extended <tt>define-foreign-enum</tt>. Removed deprecated <tt>pointer</tt> use. [Kon Lovett]</li>
  • release/3/sqlite3/tags/2.0.4/sqlite3.meta

    r4989 r8020  
    55 (category db)
    66 (eggdoc "doc.scm")
    7  (needs synch tinyclos easyffi)
     7 (needs synch tinyclos easyffi miscmacros)
    88 (license "BSD")
    99 (author "Thomas Chust")
  • release/3/sqlite3/tags/2.0.4/sqlite3.scm

    r7981 r8020  
    3131    sqlite3:bind-parameter-name
    3232    sqlite3:bind!
     33    sqlite3:bind-parameters!
    3334    sqlite3:step!
    3435    sqlite3:column-count
     
    4243    sqlite3:first-result
    4344    sqlite3:first-row
     45    sqlite3:fold-row
    4446    sqlite3:for-each-row
    4547    sqlite3:map-row
     
    6466    chicken_sqlite3_final_stub
    6567    chicken_sqlite3_step_stub )
    66   (import
     68  (bound-to-procedure
    6769    ##sys#expand-home-path
    68     #;##sys#pathname-resolution )
    69   (bound-to-procedure
     70    #;##sys#pathname-resolution
    7071    sqlite3:errmsg ) )
    7172
    7273#>#include <sqlite3.h><#
    7374
    74 (require-extension
    75  (srfi 1) (srfi 13) (srfi 18) (srfi 26)
    76  extras lolevel tinyclos synch)
     75(use srfi-1 srfi-12 srfi-13 srfi-18 srfi-26 extras lolevel)
     76(use tinyclos synch miscmacros)
     77
     78;;;
     79
     80;; Only works when the invoked object is a procedure.
     81;; Macros & values will not work.
     82(define-macro thunker cut)
    7783
    7884;;; Foreign types & values
     
    140146  (lambda (db)
    141147    (unless (slot-ref db 'this)
    142       (signal-null-error 'sqlite3:database->c-pointer db))
     148      (signal-sqlite3-null-error 'sqlite3:database->c-pointer db))
    143149    db))
    144150
     
    148154  (lambda (stmt)
    149155    (unless (slot-ref stmt 'this)
    150       (signal-null-error 'sqlite3:statement->c-pointer stmt))
     156      (signal-sqlite3-null-error 'sqlite3:statement->c-pointer stmt))
    151157    stmt))
    152158
    153159(define-method (initialize (this <sqlite3:statement>) initargs)
    154160  (call-next-method)
    155   (initialize-slots this initargs))
     161  (initialize-slots this initargs) )
    156162
    157163;;; Helpers
     
    161167  ##sys#expand-home-path
    162168  #; ;not needed, yet
    163   (cut ##sys#pathname-resolution <> identity))
     169  (cut ##sys#pathname-resolution <> identity) )
    164170
    165171;; Conditions
     
    176182    (make-sqlite3-condition sta)) )
    177183
    178 (define (make-no-data-condition stmt params)
    179   (make-sqlite3-error-condition 'sqlite3:first-result
     184(define (make-no-data-condition loc stmt params)
     185  (make-sqlite3-error-condition loc
    180186                                "the statement returned no data"
    181187                                'done
     
    184190;; Errors
    185191
    186 (define ((signal-error loc db . args) sta)
     192(define ((signal-sqlite3-error loc db . args) sta)
    187193  (signal
    188194   (apply make-sqlite3-error-condition loc
     
    191197                                       args)) )
    192198
    193 (define (signal-null-error loc obj)
    194   (signal
    195    (make-sqlite3-error-condition loc
    196                                  (format #f "bad ~A object, contained pointer is #f"
    197                                             (class-name (class-of obj)))
    198                                  'error
    199                                  obj)) )
    200 
    201 (define (check-type loc obj class)
     199(define (check-sqlite3-type loc obj class)
    202200  (unless (instance-of? obj class)
    203201    (abort
    204202     (make-composite-condition
    205203      (make-exn-condition loc
    206                           (format #f "bad argument type ~A, expected ~A"
    207                                      (class-name (class-of obj)) (class-name class))
     204                          (string-append
     205                           "bad argument type " (class-name (class-of obj))
     206                           ", expected " (class-name class))
    208207                          obj)
    209       (make-property-condition 'type)))) )
     208      (make-property-condition 'type)
     209      (make-sqlite3-condition 'error)))) )
     210
     211(define (signal-sqlite3-null-error loc obj)
     212  (signal
     213   (make-sqlite3-error-condition loc
     214                                 (string-append
     215                                  "bad " (class-name (class-of obj))
     216                                  " object, contained pointer is #f")
     217                                 'error
     218                                 obj)) )
     219(define (print-error msg obj)
     220  (print-error-message obj (current-error-port) (string-append "Error: " msg)) )
    210221
    211222;; Tree dictionary
     
    221232       (car keys)
    222233       (cut hash-table-tree-set! <> (cdr keys) value)
    223        (lambda () (make-hash-table))))
    224   ht-tree)
     234       (thunker make-hash-table)) )
     235  ht-tree )
    225236
    226237(define (hash-table-tree-delete! ht-tree keys)
     
    231242       (car keys)
    232243       (cut hash-table-tree-delete! <> (cdr keys))
    233        (lambda () (make-hash-table))))
    234   ht-tree)
     244       (thunker make-hash-table)) )
     245  ht-tree )
    235246
    236247(define (hash-table-tree-ref
    237248         ht-tree keys
    238          #!optional (thunk (lambda ()
    239                              (signal
    240                               (make-composite-condition
    241                                (make-exn-condition 'hash-table-tree-ref
    242                                                    "hash-table-tree does not contain path"
    243                                                    ht-tree keys)
    244                                (make-property-condition 'access))))))
    245   (call-with-current-continuation
    246    (lambda (q)
    247      (let loop ((ht ht-tree) (keys keys))
    248        (if (null? keys)
    249            ht
    250            (loop
    251             (hash-table-ref ht (car keys) (lambda () (q (thunk))))
    252             (cdr keys)))))))
     249         #!optional
     250         (thunk (thunker signal
     251                         (make-composite-condition
     252                          (make-exn-condition
     253                           'hash-table-tree-ref
     254                           "hash-table-tree does not contain path"
     255                           ht-tree keys)
     256                          (make-property-condition 'access)))))
     257  (let/cc return
     258    (let loop ((ht ht-tree)
     259               (keys keys))
     260      (if (null? keys)
     261          ht
     262          (loop (hash-table-ref ht (car keys) (thunker return (thunk)))
     263                (cdr keys)) ) ) ) )
    253264
    254265(define (hash-table-tree-ref/default ht-tree keys default)
    255   (hash-table-tree-ref ht-tree keys (lambda () default)))
     266  (hash-table-tree-ref ht-tree keys (lambda () default)) )
    256267
    257268(define (hash-table-tree-clear! htt id elt-clear)
     
    268279                                                 (c-pointer db))
    269280                 int
    270   (call-with-current-continuation
    271    (lambda (q)
    272      (let ((r #f))
    273        (dynamic-wind
    274            noop
    275            (lambda ()
    276              (handle-exceptions exn
    277                  (print-error-message
    278                   exn (current-error-port) "Error in collation function:")
    279                (let ((a (make-string la)) (b (make-string lb)))
    280                  (move-memory! da a la)
    281                  (move-memory! db b lb)
    282                  (set! r
    283                    ((vector-ref
    284                      (call-with/synch *sqlite3:collations*
    285                        (cut hash-table-tree-ref <> qn))
    286                      1)
    287                     a b)))))
    288            (lambda ()
    289              (if (and (integer? r) (exact? r))
    290                  (q r)
    291                  (begin
    292                    (format
    293                     (current-error-port)
    294                     "Error in collation function: invalid return value: ~S~%"
    295                     r)
    296                    (q 0)))))))))
     281  (let/cc return
     282    (let ((r #f))
     283      (dynamic-wind
     284        noop
     285        (lambda ()
     286          (handle-exceptions exn
     287                             (print-error "in collation function" exn)
     288            (let ((a (make-string la)) (b (make-string lb)))
     289              (move-memory! da a la)
     290              (move-memory! db b lb)
     291              (set! r
     292                    ((vector-ref (call-with/synch *sqlite3:collations*
     293                                   (cut hash-table-tree-ref <> qn))
     294                                 1)
     295                     a b)))))
     296        (lambda ()
     297          (if (and (integer? r) (exact? r))
     298              (return r)
     299              (begin
     300                (print-error "in collation function: invalid return value" (->string r))
     301                (return 0))))) ) ) )
    297302
    298303(define sqlite3_create_collation
     
    317322  (cond
    318323   ((sqlite3_create_collation db name #f)
    319     => (signal-error 'sqlite3:define-collation db name))
     324    => (signal-sqlite3-error 'sqlite3:define-collation db name))
    320325   (else
    321326    (let ((qn (list (pointer->address (slot-ref db 'this)) name)))
     
    326331            => (lambda (info)
    327332                 (hash-table-tree-delete! col qn)
    328                  (object-release (vector-ref info 0)))))))))))
     333                 (object-release (vector-ref info 0))))))) ) ) ) )
    329334
    330335(define-method (sqlite3:define-collation (db <sqlite3:database>)
     
    336341      => (lambda (s)
    337342           (object-release qn)
    338            ((signal-error 'sqlite3:define-collation db name proc) s)))
     343           ((signal-sqlite3-error 'sqlite3:define-collation db name proc) s)))
    339344     (else
    340345      (call-with/synch *sqlite3:collations*
    341         (cut hash-table-tree-set! <> qn (vector qn proc)))))))
     346        (cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )
    342347
    343348;;; SQL function interface
     
    382387            sqlite3:null-value))
    383388         (loop (add1 i)))
    384         '())))
     389        '() ) ) )
    385390
    386391(define-generic sqlite3:set-result!)
     
    389394                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    390395      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
    391    ctx v (blob-size v)))
     396   ctx v (blob-size v)) )
    392397
    393398; Deprecated
     
    396401                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    397402      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
    398    ctx v (byte-vector-length v)))
     403   ctx v (byte-vector-length v)) )
    399404
    400405(define-method (sqlite3:set-result! (ctx <pointer>) (v <exact>))
    401406  ((foreign-lambda void "sqlite3_result_int" sqlite3:context int)
    402    ctx v))
     407   ctx v) )
    403408
    404409(define-method (sqlite3:set-result! (ctx <pointer>) (v <number>))
    405410  ((foreign-lambda void "sqlite3_result_double" sqlite3:context double)
    406    ctx v))
     411   ctx v) )
    407412
    408413(define-method (sqlite3:set-result! (ctx <pointer>) (v <string>))
     
    410415                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    411416    "sqlite3_result_text(ctx, v, n, SQLITE_TRANSIENT);")
    412    ctx v (string-length v)))
     417   ctx v (string-length v)) )
    413418
    414419(define-method (sqlite3:set-result! (ctx <pointer>) (v <void>))
    415420  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
    416    ctx))
     421   ctx) )
    417422
    418423(define-method (sqlite3:set-result! (ctx <pointer>))
    419424  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
    420    ctx))
     425   ctx) )
    421426
    422427(define sqlite3_user_data
    423428  (foreign-lambda scheme-object "sqlite3_user_data" sqlite3:context))
    424429
    425 (define-external (chicken_sqlite3_function_stub (c-pointer ctx) (int n) (c-pointer args)) void
    426   (call-with-current-continuation
    427    (lambda (q)
    428      (dynamic-wind
    429          noop
    430          (lambda ()
    431            (handle-exceptions exn
    432                (print-error-message
    433                 exn (current-error-port) "Error in SQL function:")
    434              (sqlite3:set-result!
    435               ctx
    436               (apply
    437                (vector-ref
    438                 (call-with/synch *sqlite3:functions*
    439                  (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))
    440                 1)
    441                (sqlite3:parameter-data n args)))))
    442          (lambda ()
    443            (q (void)))))))
     430(define-external (chicken_sqlite3_function_stub (c-pointer ctx) (int n) (c-pointer args))
     431                 void
     432  (let/cc return
     433    (dynamic-wind
     434      noop
     435      (lambda ()
     436        (handle-exceptions exn
     437                           (print-error "in SQL function" exn)
     438          (sqlite3:set-result!
     439           ctx
     440           (apply
     441            (vector-ref
     442             (call-with/synch *sqlite3:functions*
     443              (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))
     444             1)
     445            (sqlite3:parameter-data n args)))))
     446     (lambda ()
     447       (return (void)))) ) )
    444448
    445449(define sqlite3_aggregate_context
     
    447451   "return((int)sqlite3_aggregate_context(ctx, 1));"))
    448452
    449 (define-external (chicken_sqlite3_step_stub (c-pointer ctx) (int n) (c-pointer args)) void
    450   (call-with-current-continuation
    451    (lambda (q)
    452      (dynamic-wind
    453          noop
     453(define-external (chicken_sqlite3_step_stub (c-pointer ctx) (int n) (c-pointer args))
     454                 void
     455  (let/cc return
     456    (dynamic-wind
     457      noop
     458      (lambda ()
     459        (handle-exceptions exn
     460                           (print-error "in step of SQL function" exn)
     461          (let ((info (call-with/synch *sqlite3:functions*
     462                       (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
     463            (call-with/synch *sqlite3:seeds*
     464             (cut hash-table-update!/default
     465                  <>
     466                  (sqlite3_aggregate_context ctx)
     467                  (lambda (seed)
     468                    (apply (vector-ref info 1) seed (sqlite3:parameter-data n args)))
     469                  (vector-ref info 2))))))
    454470         (lambda ()
    455            (handle-exceptions exn
    456                (print-error-message
    457                 exn (current-error-port) "Error in step of SQL function:")
    458              (let ((info (call-with/synch *sqlite3:functions*
    459                            (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
    460                (call-with/synch *sqlite3:seeds*
    461                  (cut hash-table-update!/default
    462                       <>
    463                       (sqlite3_aggregate_context ctx)
    464                       (lambda (seed)
    465                         (apply
    466                          (vector-ref info 1)
    467                          seed
    468                          (sqlite3:parameter-data n args)))
    469                       (vector-ref info 2))))))
    470          (lambda ()
    471            (q (void)))))))
    472 
    473 (define-external (chicken_sqlite3_final_stub (c-pointer ctx)) void
    474   (call-with-current-continuation
    475    (lambda (q)
    476      (let ((agc (sqlite3_aggregate_context ctx)))
    477        (dynamic-wind
    478            noop
    479            (lambda ()
    480              (handle-exceptions exn
    481                  (print-error-message
    482                   exn (current-error-port) "Error in final of SQL function:")
    483                (let ((info (call-with/synch *sqlite3:functions*
    484                              (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
    485                  (cond
    486                   (((vector-ref info 3)
    487                     (call-with/synch *sqlite3:seeds*
    488                       (cut hash-table-ref/default <> agc (vector-ref info 2))))
    489                    => (cut sqlite3:set-result! ctx <>))
    490                   (else
    491                    (sqlite3:set-result! ctx))))))
    492            (lambda ()
    493              (call-with/synch *sqlite3:seeds*
    494                (cut hash-table-delete! <> agc))
    495              (q (void))))))))
     471           (return (void)))) ) )
     472
     473(define-external (chicken_sqlite3_final_stub (c-pointer ctx))
     474                 void
     475  (let/cc return
     476    (let ((agc (sqlite3_aggregate_context ctx)))
     477      (dynamic-wind
     478        noop
     479        (lambda ()
     480          (handle-exceptions exn
     481                             (print-error "in final of SQL function" exn)
     482            (let ((info (call-with/synch *sqlite3:functions*
     483                         (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
     484              (cond
     485                (((vector-ref info 3)
     486                  (call-with/synch *sqlite3:seeds*
     487                   (cut hash-table-ref/default <> agc (vector-ref info 2))))
     488                 => (cut sqlite3:set-result! ctx <>))
     489                (else
     490                  (sqlite3:set-result! ctx))))))
     491        (lambda ()
     492          (call-with/synch *sqlite3:seeds*
     493           (cut hash-table-delete! <> agc))
     494          (return (void)))) ) ) )
    496495
    497496(define-generic sqlite3:define-function)
     
    517516      => (lambda (s)
    518517           (object-release qn)
    519            ((signal-error 'sqlite3:define-function db name n proc) s)))
     518           ((signal-sqlite3-error 'sqlite3:define-function db name n proc) s)))
    520519     (else
    521520      (call-with/synch *sqlite3:functions*
    522         (cut hash-table-tree-set! <> qn (vector qn proc)))))))
     521        (cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )
    523522
    524523(define-method (sqlite3:define-function (db <sqlite3:database>)
     
    528527                                         (seed <top>)
    529528                                         #!optional (final-proc identity))
    530   (check-type 'sqlite3:define-function final-proc <procedure-class>)
     529  (check-sqlite3-type 'sqlite3:define-function final-proc <procedure-class>)
    531530  (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    532531    (cond
     
    547546      => (lambda (s)
    548547           (object-release qn)
    549            ((signal-error
     548           ((signal-sqlite3-error
    550549              'sqlite3:define-function db name n step-proc seed final-proc)
    551550            s)))
    552551     (else
    553552      (call-with/synch *sqlite3:functions*
    554         (cut hash-table-tree-set! <> qn (vector qn step-proc seed final-proc)))))))
     553        (cut hash-table-tree-set! <> qn (vector qn step-proc seed final-proc))) ) ) ) )
    555554
    556555;;; Database interface
     
    558557;; Get any error message
    559558(define sqlite3:errmsg
    560   (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database))
     559  (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database) )
    561560
    562561;; Open a database
    563562(define (sqlite3:open path)
    564   (check-type 'sqlite3:open path <string>)
     563  (check-sqlite3-type 'sqlite3:open path <string>)
    565564  (let-location ((db c-pointer))
    566565    (cond
     
    568567                                      nonnull-c-string (c-pointer sqlite3:database))
    569568       (sqlite3:resolve-pathname path) (location db))
    570       => (signal-error 'sqlite3:open #f path))
     569      => (signal-sqlite3-error 'sqlite3:open #f path))
    571570     (else
    572       (make <sqlite3:database> 'this db)))))
     571      (make <sqlite3:database> 'this db) ) ) ) )
    573572
    574573;; Set a timeout until a busy error is thrown
    575574(define (sqlite3:set-busy-timeout! db #!optional (ms 0))
    576   (check-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
     575  (check-sqlite3-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
    577576  (cond
    578577   (((foreign-lambda sqlite3:status "sqlite3_busy_timeout" sqlite3:database int) db ms)
    579     => (signal-error 'sqlite3:set-busy-timeout! db db ms))))
     578    => (signal-sqlite3-error 'sqlite3:set-busy-timeout! db db ms))) )
    580579
    581580;; Cancel any running database operation as soon as possible
    582581(define (sqlite3:interrupt! db)
    583   (check-type 'sqlite3:interrupt! db <sqlite3:database>)
    584   ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db))
     582  (check-sqlite3-type 'sqlite3:interrupt! db <sqlite3:database>)
     583  ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db) )
    585584
    586585;; Check whether the database is in autocommit mode
    587586(define (sqlite3:auto-committing? db)
    588   (check-type 'sqlite3:auto-committing? db <sqlite3:database>)
    589   ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db))
     587  (check-sqlite3-type 'sqlite3:auto-committing? db <sqlite3:database>)
     588  ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db) )
    590589
    591590;; Get the number of changes made to the database
    592591(define (sqlite3:changes db #!optional (total #f))
    593   (check-type 'sqlite3:changes db <sqlite3:database>)
     592  (check-sqlite3-type 'sqlite3:changes db <sqlite3:database>)
    594593  (if total
    595       ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db))
    596       ((foreign-lambda number "sqlite3_changes" sqlite3:database) db))
     594      ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db)
     595      ((foreign-lambda number "sqlite3_changes" sqlite3:database) db) ) )
    597596
    598597;; Get the row ID of the last inserted row
    599598(define (sqlite3:last-insert-rowid db)
    600   (check-type 'sqlite3:last-insert-rowid db <sqlite3:database>)
    601   ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db))
     599  (check-sqlite3-type 'sqlite3:last-insert-rowid db <sqlite3:database>)
     600  ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db) )
    602601
    603602;; Close a database
     
    608607    (void))
    609608   (((foreign-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)
    610     => (signal-error 'sqlite3:finalize! db db))
     609    => (signal-sqlite3-error 'sqlite3:finalize! db db))
    611610   (else
    612611    (let ((id (pointer->address (slot-ref db 'this)))
     
    622621;; Create a new statement
    623622(define (sqlite3:prepare db sql)
    624   (check-type 'sqlite3:prepare db <sqlite3:database>)
    625   (check-type 'sqlite3:prepare sql <string>)
     623  (check-sqlite3-type 'sqlite3:prepare db <sqlite3:database>)
     624  (check-sqlite3-type 'sqlite3:prepare sql <string>)
    626625  (let-location ((stmt c-pointer) (tail c-string))
    627626    (cond
     
    631630                                      (c-pointer (const c-string)))
    632631       db sql (string-length sql) (location stmt) (location tail))
    633       => (signal-error 'sqlite3:prepare db db sql))
     632      => (signal-sqlite3-error 'sqlite3:prepare db db sql))
    634633     (else
    635634      (values
    636635       (make <sqlite3:statement> 'this stmt 'database db 'sql sql)
    637        tail)))))
     636       tail) ) ) ) )
    638637
    639638;; Recompile an existing statement and transfer all bindings
    640639(define (sqlite3:repair! stmt)
    641   (check-type 'sqlite3:repair! stmt <sqlite3:statement>)
     640  (check-sqlite3-type 'sqlite3:repair! stmt <sqlite3:statement>)
    642641  (let ((fresh (sqlite3:prepare
    643642                (slot-ref stmt 'database) (slot-ref stmt 'sql))))
     
    651650                                              c-pointer c-pointer)
    652651               old new)
    653               => (signal-error 'sqlite3:repair! (slot-ref stmt 'database) stmt))
     652              => (signal-sqlite3-error 'sqlite3:repair! (slot-ref stmt 'database) stmt))
    654653             (else
    655654              (slot-set! stmt 'this new)
    656655              (slot-set! fresh 'this old)))))
    657656        (lambda ()
    658           (sqlite3:finalize! fresh)))))
     657          (sqlite3:finalize! fresh))) ) )
    659658
    660659;; Discard an existing statement
     
    665664    (void))
    666665   (((foreign-lambda sqlite3:status "sqlite3_finalize" sqlite3:statement) stmt)
    667     => (signal-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt))
     666    => (signal-sqlite3-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt))
    668667   (else
    669     (slot-set! stmt 'this #f))))
     668    (slot-set! stmt 'this #f) ) ) )
    670669
    671670;; Reset an existing statement to process it again
     
    674673
    675674(define (sqlite3:reset! stmt)
    676   (check-type 'sqlite3:reset! stmt <sqlite3:statement>)
     675  (check-sqlite3-type 'sqlite3:reset! stmt <sqlite3:statement>)
    677676  (cond
    678677   ((sqlite3_reset stmt)
    679     => (signal-error 'sqlite3:reset! (slot-ref stmt 'database) stmt))))
     678    => (signal-sqlite3-error 'sqlite3:reset! (slot-ref stmt 'database) stmt))) )
    680679
    681680;; Get number of bindable parameters
    682681(define (sqlite3:bind-parameter-count stmt)
    683   (check-type 'sqlite3:bind-parameter-count stmt <sqlite3:statement>)
    684   ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt))
     682  (check-sqlite3-type 'sqlite3:bind-parameter-count stmt <sqlite3:statement>)
     683  ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt) )
    685684
    686685;; Get index of a bindable parameter or #f if no parameter with the
    687686;; given name exists
    688687(define (sqlite3:bind-parameter-index stmt name)
    689   (check-type 'sqlite3:bind-parameter-index stmt <sqlite3:statement>)
     688  (check-sqlite3-type 'sqlite3:bind-parameter-index stmt <sqlite3:statement>)
    690689  (let ((i ((foreign-lambda int "sqlite3_bind_parameter_index"
    691690                                sqlite3:statement nonnull-c-string)
    692691            stmt name)))
    693     (if (zero? i) #f (sub1 i))))
     692    (if (zero? i)
     693        #f
     694        (sub1 i) ) ) )
    694695
    695696;; Get the name of a bindable parameter
    696697(define (sqlite3:bind-parameter-name stmt i)
    697   (check-type 'sqlite3:bind-parameter-name stmt <sqlite3:statement>)
    698   ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int) stmt (add1 i)))
     698  (check-sqlite3-type 'sqlite3:bind-parameter-name stmt <sqlite3:statement>)
     699  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int) stmt (add1 i)) )
    699700
    700701;; Bind data as parameters to an existing statement
     
    708709      "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
    709710     stmt (add1 i) v (blob-size v))
    710     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     711    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
    711712
    712713; Deprecated
     
    718719      "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
    719720     stmt (add1 i) v (byte-vector-length v))
    720     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     721    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
    721722
    722723(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    726727                                    sqlite3:statement int int)
    727728     stmt (add1 i) v)
    728     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     729    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
    729730
    730731(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    734735                                    sqlite3:statement int double)
    735736     stmt (add1 i) v)
    736     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     737    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
    737738
    738739(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    743744      "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
    744745     stmt (add1 i) v (string-length v))
    745     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     746    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
    746747
    747748(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    749750  (cond
    750751   (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    751     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))))
     752    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )
    752753
    753754(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>))
    754755  (cond
    755756   (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    756     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))))
     757    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )
     758
     759; Helper
     760(define (bind-parameters! loc stmt params)
     761  (sqlite3:reset! stmt)
     762  (let ((cnt (sqlite3:bind-parameter-count stmt)))
     763    (unless (= cnt (length params))
     764      (abort
     765       (make-composite-condition
     766        (make-exn-condition loc "too few parameters" cnt params)
     767        (make-property-condition 'arity)
     768        (make-sqlite3-condition 'error))) )
     769    (for-each (cut sqlite3:bind! stmt <> <>) (iota cnt) params) ) )
     770
     771(define (sqlite3:bind-parameters! stmt . params)
     772  (bind-parameters! 'sqlite3:bind-parameters! stmt params) )
    757773
    758774;; Single-step a prepared statement, return #t if data is available,
    759775;; #f otherwise
    760776(define (sqlite3:step! stmt)
    761   (check-type 'sqlite3:step! stmt <sqlite3:statement>)
     777  (check-sqlite3-type 'sqlite3:step! stmt <sqlite3:statement>)
    762778  (let retry ()
    763779    (let ((s ((foreign-safe-lambda
     
    774790              (retry))
    775791             (else
    776               ((signal-error
     792              ((signal-sqlite3-error
    777793                'sqlite3:step! (slot-ref stmt 'database) stmt) s)))))
    778794        (else
    779          ((signal-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s))))))
     795         ((signal-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ) ) ) ) )
    780796
    781797;; Retrieve information from a prepared/stepped statement
    782798(define (sqlite3:column-count stmt)
    783   (check-type 'sqlite3:column-count stmt <sqlite3:statement>)
    784   ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt))
     799  (check-sqlite3-type 'sqlite3:column-count stmt <sqlite3:statement>)
     800  ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt) )
    785801
    786802(define (sqlite3:column-type stmt i)
    787   (check-type 'sqlite3:column-type stmt <sqlite3:statement>)
    788   ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i))
     803  (check-sqlite3-type 'sqlite3:column-type stmt <sqlite3:statement>)
     804  ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i) )
    789805
    790806(define (sqlite3:column-declared-type stmt i)
    791   (check-type 'sqlite3:column-declared-type stmt <sqlite3:statement>)
    792   ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i))
     807  (check-sqlite3-type 'sqlite3:column-declared-type stmt <sqlite3:statement>)
     808  ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i) )
    793809
    794810(define (sqlite3:column-name stmt i)
    795   (check-type 'sqlite3:column-name stmt <sqlite3:statement>)
    796   ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i))
     811  (check-sqlite3-type 'sqlite3:column-name stmt <sqlite3:statement>)
     812  ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i) )
    797813
    798814;; Retrieve data from a stepped statement
     
    816832      stmt i))
    817833    (else
    818      sqlite3:null-value)))
     834     sqlite3:null-value ) ) )
    819835
    820836;;; Easy statement interface
     
    823839;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
    824840(define (sqlite3:call-with-temporary-statements proc db . sqls)
    825   (check-type 'sqlite3:call-with-temporary-statements db <sqlite3:database>)
     841  (check-sqlite3-type 'sqlite3:call-with-temporary-statements db <sqlite3:database>)
    826842  (let ((stmts #f))
    827843    (dynamic-wind
     
    834850          (when stmts
    835851            (map sqlite3:finalize! stmts)
    836             (set! stmts #f))))))
     852            (set! stmts #f)))) ) )
    837853
    838854;; Step through a statement and ignore possible results
    839855(define-generic sqlite3:exec)
    840856(define-method (sqlite3:exec (stmt <sqlite3:statement>) . params)
    841   (sqlite3:reset! stmt)
    842   (for-each
    843    (cute sqlite3:bind! stmt <> <>)
    844    (iota (sqlite3:bind-parameter-count stmt)) params)
    845   (do () ((not (sqlite3:step! stmt)) sqlite3:null-value)))
     857  (bind-parameters! 'sqlite3:exec stmt params)
     858  (while (sqlite3:step! stmt))
     859  sqlite3:null-value )
    846860
    847861(define-method (sqlite3:exec (db <sqlite3:database>) (sql <string>) . params)
    848862  (sqlite3:call-with-temporary-statements
    849    (cute apply sqlite3:exec <> params)
    850    db sql))
     863   (cut apply sqlite3:exec <> params)
     864   db sql) )
    851865
    852866;; Step through a statement, ignore possible results and return the
     
    856870  (sqlite3:reset! stmt)
    857871  (apply sqlite3:exec stmt params)
    858   (sqlite3:changes (slot-ref stmt 'database)))
     872  (sqlite3:changes (slot-ref stmt 'database)) )
    859873
    860874(define-method (sqlite3:update (db <sqlite3:database>) (sql <string>) . params)
    861875  (apply sqlite3:exec db sql params)
    862   (sqlite3:changes db))
     876  (sqlite3:changes db) )
    863877
    864878;; Return only the first column of the first result row produced by this
     
    867881(define-generic sqlite3:first-result)
    868882(define-method (sqlite3:first-result (stmt <sqlite3:statement>) . params)
    869   (sqlite3:reset! stmt)
    870   (for-each
    871    (cute sqlite3:bind! stmt <> <>)
    872    (iota (sqlite3:bind-parameter-count stmt)) params)
     883  (bind-parameters! 'sqlite3:first-result stmt params)
    873884  (if (sqlite3:step! stmt)
    874885      (let ((r (sqlite3:column-data stmt 0)))
    875886        (sqlite3:reset! stmt)
    876         r)
    877       (signal (make-no-data-condition stmt params)) ) )
     887        r )
     888      (signal (make-no-data-condition 'sqlite3:first-result stmt params)) ) )
    878889
    879890(define-method (sqlite3:first-result
    880891                (db <sqlite3:database>) (sql <string>) . params)
    881892  (sqlite3:call-with-temporary-statements
    882    (cute apply sqlite3:first-result <> params)
    883    db sql))
     893   (cut apply sqlite3:first-result <> params)
     894   db sql) )
    884895
    885896;; Return only the first result row produced by this statement as a list
     
    887898(define-generic sqlite3:first-row)
    888899(define-method (sqlite3:first-row (stmt <sqlite3:statement>) . params)
    889   (sqlite3:reset! stmt)
    890   (for-each
    891    (cute sqlite3:bind! stmt <> <>)
    892    (iota (sqlite3:bind-parameter-count stmt)) params)
     900  (bind-parameters! 'sqlite3:first-row stmt params)
    893901  (if (sqlite3:step! stmt)
    894       (map
    895        (cute sqlite3:column-data stmt <>)
    896        (iota (sqlite3:column-count stmt)))
    897       (signal (make-no-data-condition stmt params)) ) )
     902      (map (cut sqlite3:column-data stmt <>)
     903           (iota (sqlite3:column-count stmt)))
     904      (signal (make-no-data-condition 'sqlite3:first-row stmt params)) ) )
    898905
    899906(define-method (sqlite3:first-row
    900907                (db <sqlite3:database>) (sql <string>) . params)
    901908  (sqlite3:call-with-temporary-statements
    902    (cute apply sqlite3:first-row <> params)
     909   (cut apply sqlite3:first-row <> params)
    903910   db sql))
     911
     912;; Apply a procedure to the values of the result columns for each result row
     913;; while executing the statement and accumulating results.
     914
     915(define (%fold-row loc proc stmt init params)
     916  (bind-parameters! loc stmt params)
     917  (let ((cl (iota (sqlite3:column-count stmt))))
     918    (let loop ((acc init))
     919      (if (sqlite3:step! stmt)
     920          (loop (apply proc acc (map (cut sqlite3:column-data stmt <>) cl)))
     921          acc ) ) ) )
     922
     923(define-generic sqlite3:fold-row)
     924(define-method (sqlite3:fold-row (proc <procedure-class>)
     925                                 (stmt <sqlite3:statement>)
     926                                 (init <object>) . params)
     927  (%fold-row 'sqlite3:fold-row proc stmt init params) )
     928
     929(define-method (sqlite3:fold-row (proc <procedure-class>)
     930                                 (db <sqlite3:database>)
     931                                 (sql <string>)
     932                                 (init <object>) . params)
     933  (sqlite3:call-with-temporary-statements
     934   (cut apply sqlite3:fold-row proc <> init params)
     935   db sql) )
    904936
    905937;; Apply a procedure to the values of the result columns for each result row
    906938;; while executing the statement and discard the results
    907939
     940(define (for-each-row-proc proc)
     941  (lambda (acc . cols)
     942    (apply proc cols)
     943    acc ) )
     944
    908945(define-generic sqlite3:for-each-row)
    909 (define-method (sqlite3:for-each-row
    910                 (proc <procedure-class>) (stmt <sqlite3:statement>) . params)
    911   (sqlite3:reset! stmt)
    912   (for-each
    913    (cute sqlite3:bind! stmt <> <>)
    914    (iota (sqlite3:bind-parameter-count stmt)) params)
    915   (do ((cl (iota (sqlite3:column-count stmt))))
    916       ((not (sqlite3:step! stmt)) sqlite3:null-value)
    917     (apply proc (map (cute sqlite3:column-data stmt <>) cl))))
    918 
    919 (define-method (sqlite3:for-each-row
    920                 (proc <procedure-class>)
    921                 (db <sqlite3:database>) (sql <string>) . params)
     946(define-method (sqlite3:for-each-row (proc <procedure-class>)
     947                                     (stmt <sqlite3:statement>) . params)
     948  (%fold-row 'sqlite3:for-each-row (for-each-row-proc proc) stmt (void) params) )
     949
     950(define-method (sqlite3:for-each-row (proc <procedure-class>)
     951                                     (db <sqlite3:database>)
     952                                     (sql <string>) . params)
    922953  (sqlite3:call-with-temporary-statements
    923    (cute apply sqlite3:for-each-row proc <> params)
    924    db sql))
     954   (cut apply sqlite3:for-each-row proc <> params)
     955   db sql) )
    925956
    926957;; Apply a procedure to the values of the result columns for each result row
    927958;; while executing the statement and accumulate the results in a list
    928959
     960(define (map-row-proc proc)
     961  (lambda (acc . cols)
     962    (cons (apply proc cols) acc) ) )
     963
    929964(define-generic sqlite3:map-row)
    930 (define-method (sqlite3:map-row
    931                 (proc <procedure-class>) (stmt <sqlite3:statement>) . params)
    932   (sqlite3:reset! stmt)
    933   (for-each
    934    (cute sqlite3:bind! stmt <> <>)
    935    (iota (sqlite3:bind-parameter-count stmt)) params)
    936   (let ((cl (iota (sqlite3:column-count stmt))))
    937     (let loop ()
    938       (if (sqlite3:step! stmt)
    939           (cons
    940            (apply proc (map (cute sqlite3:column-data stmt <>) cl))
    941            (loop))
    942           '()))))
    943 
    944 (define-method (sqlite3:map-row
    945                 (proc <procedure-class>)
    946                 (db <sqlite3:database>) (sql <string>) . params)
     965(define-method (sqlite3:map-row (proc <procedure-class>)
     966                                (stmt <sqlite3:statement>) . params)
     967  (reverse! (%fold-row 'sqlite3:map-row (map-row-proc proc) stmt '() params)) )
     968
     969(define-method (sqlite3:map-row (proc <procedure-class>)
     970                                (db <sqlite3:database>)
     971                                (sql <string>) . params)
    947972  (sqlite3:call-with-temporary-statements
    948    (cute apply sqlite3:map-row proc <> params)
    949    db sql))
     973   (cut apply sqlite3:map-row proc <> params)
     974   db sql) )
    950975
    951976;;; Utility procedures
     
    955980;; an exception
    956981(define (sqlite3:with-transaction db thunk #!optional (type 'deferred))
    957   (check-type 'sqlite3:with-transaction db <sqlite3:database>)
    958   (check-type 'sqlite3:with-transaction thunk <procedure-class>)
     982  (check-sqlite3-type 'sqlite3:with-transaction db <sqlite3:database>)
     983  (check-sqlite3-type 'sqlite3:with-transaction thunk <procedure-class>)
    959984  (unless (memq type '(deferred immediate exclusive))
    960985    (abort
    961986     (make-composite-condition
    962987      (make-exn-condition 'sqlite3:with-transaction
    963                           (format #f
    964                            "bad argument ~A, expected deferred, immediate or exclusive"
    965                            type)
     988                          "bad argument: expected deferred, immediate or exclusive"
    966989                          type)
    967       (make-property-condition 'type))))
     990      (make-property-condition 'type))) )
    968991  (let ((success? #f))
    969992    (dynamic-wind
    970993        (lambda ()
    971           (sqlite3:exec db (format #f "BEGIN ~a TRANSACTION;" type)))
     994          (sqlite3:exec db
     995           (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
    972996        (lambda ()
    973997          (set! success? (thunk)))
    974998        (lambda ()
    975           (sqlite3:exec
    976            db (if success?
    977                   "COMMIT TRANSACTION;"
    978                   "ROLLBACK TRANSACTION;"))))))
     999          (sqlite3:exec db
     1000           (if success?
     1001               "COMMIT TRANSACTION;"
     1002               "ROLLBACK TRANSACTION;")))) ) )
    9791003
    9801004;; Check if the given string is a valid SQL statement
     
    9841008;; Return a descriptive version string
    9851009(define sqlite3:library-version
    986   (foreign-lambda c-string "sqlite3_libversion"))
     1010  (foreign-lambda c-string "sqlite3_libversion") )
  • release/3/sqlite3/tags/2.0.4/sqlite3.setup

    r7981 r8020  
    1 (required-extension-version 'tinyclos "1.4" 'synch "1.3")
     1(required-extension-version 'tinyclos "1.4" 'synch "1.3" 'miscmacros "2.5")
    22
    33(define so-file "sqlite3.so")
     4
    45(compile
    56  -O2 -d0 -X easyffi -X tinyclos -s sqlite3.scm -lsqlite3
    67  -o ,so-file
    78  -check-imports -emit-exports "sqlite3.exports")
     9
    810(install-extension
    911  'sqlite3
    1012  `(,so-file
    1113    "sqlite3.html" "egg.jpg")
    12   '((version "2.0.3") (documentation "sqlite3.html")))
     14  '((version "2.0.4")
     15    (documentation "sqlite3.html")))
  • release/3/sqlite3/trunk/doc.scm

    r7981 r8020  
    88     (usage)
    99     (download "sqlite3.egg")
    10      (requires "synch" "tinyclos" "easyffi")
     10     (requires "synch" "tinyclos" "easyffi" "miscmacros")
    1111
    1212     (documentation
     
    145145           (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <number>)) => <void>")
    146146           (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <string>)) => <void>")
    147            (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <byte-vector>)) => <void>"))
     147           (signature "method" "(sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>) (v <blob>)) => <void>"))
    148148          (p "Can be applied to any statement to bind its free parameter number " (tt "i") " (counting from 0) to the given value. Scheme types of the value map to SQLite types as follows:"
    149149             (table
     
    154154              (tr (td (tt "<number>")) (td (tt "float")))
    155155              (tr (td (tt "<string>")) (td (tt "text")))
    156               (tr (td (tt "<byte-vector>")) (td (tt "blob")))))
     156              (tr (td (tt "<blob>")) (td (tt "blob")))))
    157157          (p "Unless there is internal trouble in SQLite3, this method should always succeeds and never throw an exception. For invalid parameter indices the method just silently does nothing."))
     158        (procedure
     159         "(sqlite3:bind-parameters! (stmt <sqlite3:statement>) . params) => <void>"
     160         (p "Binds the statement's free parameters."))
    158161        (procedure
    159162         "(sqlite3:step! (stmt <sqlite3:statement>)) => <boolean>"
     
    165168         (p "This procedure always succeeds and never throws an exception."))
    166169        (procedure
    167          "(sqlite3:column-data (stmt <sqlite3:statement>) (i <exact>)) => <void | exact | number | string | byte-vector>"
     170         "(sqlite3:column-data (stmt <sqlite3:statement>) (i <exact>)) => <void | exact | number | string | blob>"
    168171         (p "Can be applied to a statement that has just been stepped. Consults " (tt "sqlite3:column-type") " to determine the type of the indicated column and to return its data as an appropriate scheme object.")
    169172         (p "See " (tt "sqlite3:bind!") " for the mapping between Scheme and SQLite data types. Columns of type " (tt "null") " are returned as " (tt "<sqlite3:null-value>") ". Also keep in mind that CHICKEN's " (tt "<exact>") " datatype can only hold a subset of the values an SQLite " (tt "integer") " can store. Large integer values may therefore be returned as floating point numbers from the database, but they will still be of class " (tt "<integer>") ".")
     
    195198        (definition
    196199          (signatures
    197            (signature "method" "(sqlite3:first-result (stmt <sqlite3:statement>) . params) => <void | exact | number | string | byte-vector>")
    198            (signature "method" "(sqlite3:first-result (db <sqlite3:database>) (sql <string>) . params) => <void | exact | number | string | byte-vector>"))
     200           (signature "method" "(sqlite3:first-result (stmt <sqlite3:statement>) . params) => <void | exact | number | string | blob>")
     201           (signature "method" "(sqlite3:first-result (db <sqlite3:database>) (sql <string>) . params) => <void | exact | number | string | blob>"))
    199202          (p "(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning the value of the first column in the first result row. Resets the statement again just before returning.")
    200203          (p "If the given statement does not yield any results, an " (tt "(exn sqlite3)") " is thrown with the " (tt "status") "-property set to " (tt "done") "."))
     
    204207           (signature "method" "(sqlite3:first-row (db <sqlite3:database>) (sql <string>) . params) => <list>"))
    205208          (p "(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning all columns in the first result row as a list.")
    206           (p "If the given statement does not yield any results, an " (tt "(exn sqlite3)") " is thrown with the " (tt "status") "-property set to " (tt "done") "."))
     209          (p "If the given statement does not yield any results, an " (tt "(exn sqlite3)") " is thrown with the " (tt "status") "-property set to " (tt "done") "."))(definition
     210          (signatures
     211           (signature "method" "(sqlite3:fold-row (proc <procedure-class>) (stmt <sqlite3:statement>) initial . params) => <list>")
     212           (signature "method" "(sqlite3:fold-row (proc <procedure-class>) (db <sqlite3:database>) (sql <string>) initial . params) => <list>"))
     213          (p "(Compiles the given SQL), resets the statement, binds the statement's free parameters and executes it step by step. After each step, the column values of the current result row are retrieved and " (tt "proc") " is applied to the current folded value and the column values. The result of the application becomes the new folded value."))
    207214        (definition
    208215          (signatures
     
    239246
    240247     (history
     248      (version "2.0.4" "Added " (code "sqlite3:fold-row") " & " (code "sqlite3:bind-parameters!") ". Fix for introduced bug in " (code "sqlite3:changes") ". [Kon Lovett]")
    241249      (version "2.0.3" "Added " (code "sqlite3:null-value") ", " (code "sqlite3:null-value?") ", and " (code "sqlite3:null") ". [Kon Lovett]")
    242250      (version "2.0.2" "Use of extended " (tt "define-foreign-enum") ". Removed deprecated " (tt "pointer") " use. [Kon Lovett]")
  • release/3/sqlite3/trunk/sqlite3.html

    r7981 r8020  
    164164<li>synch</li>
    165165<li>tinyclos</li>
    166 <li>easyffi</li></ul></div>
     166<li>easyffi</li>
     167<li>miscmacros</li></ul></div>
    167168<div class="section">
    168169<h3>Documentation</h3>
     
    341342<br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;number&gt;)) =&gt; &lt;void&gt;
    342343<br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;string&gt;)) =&gt; &lt;void&gt;
    343 <br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;byte-vector&gt;)) =&gt; &lt;void&gt;</dt>
     344<br /><strong>method:</strong> (sqlite3:bind! (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;) (v &lt;blob&gt;)) =&gt; &lt;void&gt;</dt>
    344345<dd>
    345346<p>Can be applied to any statement to bind its free parameter number <tt>i</tt> (counting from 0) to the given value. Scheme types of the value map to SQLite types as follows:
     
    364365<td><tt>text</tt></td></tr>
    365366<tr>
    366 <td><tt>&lt;byte-vector&gt;</tt></td>
     367<td><tt>&lt;blob&gt;</tt></td>
    367368<td><tt>blob</tt></td></tr></table></p>
    368369<p>Unless there is internal trouble in SQLite3, this method should always succeeds and never throw an exception. For invalid parameter indices the method just silently does nothing.</p></dd>
     370<dt class="definition"><strong>procedure:</strong> (sqlite3:bind-parameters! (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void&gt;</dt>
     371<dd>
     372<p>Binds the statement's free parameters.</p></dd>
    369373<dt class="definition"><strong>procedure:</strong> (sqlite3:step! (stmt &lt;sqlite3:statement&gt;)) =&gt; &lt;boolean&gt;</dt>
    370374<dd>
     
    375379<p>The return value can be one of the symbols <tt>null</tt>, <tt>integer</tt>, <tt>float</tt>, <tt>text</tt> or <tt>blob</tt>.</p>
    376380<p>This procedure always succeeds and never throws an exception.</p></dd>
    377 <dt class="definition"><strong>procedure:</strong> (sqlite3:column-data (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;)) =&gt; &lt;void | exact | number | string | byte-vector&gt;</dt>
     381<dt class="definition"><strong>procedure:</strong> (sqlite3:column-data (stmt &lt;sqlite3:statement&gt;) (i &lt;exact&gt;)) =&gt; &lt;void | exact | number | string | blob&gt;</dt>
    378382<dd>
    379383<p>Can be applied to a statement that has just been stepped. Consults <tt>sqlite3:column-type</tt> to determine the type of the indicated column and to return its data as an appropriate scheme object.</p>
     
    401405<dd>
    402406<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and executes the specified statement ignoring possible results from it, returning the result of applying <tt>sqlite3:changes</tt> to the affected database after the execution of the statement instead.</p></dd>
    403 <dt class="definition"><strong>method:</strong> (sqlite3:first-result (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void | exact | number | string | byte-vector&gt;
    404 <br /><strong>method:</strong> (sqlite3:first-result (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) . params) =&gt; &lt;void | exact | number | string | byte-vector&gt;</dt>
     407<dt class="definition"><strong>method:</strong> (sqlite3:first-result (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void | exact | number | string | blob&gt;
     408<br /><strong>method:</strong> (sqlite3:first-result (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) . params) =&gt; &lt;void | exact | number | string | blob&gt;</dt>
    405409<dd>
    406410<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning the value of the first column in the first result row. Resets the statement again just before returning.</p>
     
    411415<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and single-steps the statement once returning all columns in the first result row as a list.</p>
    412416<p>If the given statement does not yield any results, an <tt>(exn sqlite3)</tt> is thrown with the <tt>status</tt>-property set to <tt>done</tt>.</p></dd>
     417<dt class="definition"><strong>method:</strong> (sqlite3:fold-row (proc &lt;procedure-class&gt;) (stmt &lt;sqlite3:statement&gt;) initial . params) =&gt; &lt;list&gt;
     418<br /><strong>method:</strong> (sqlite3:fold-row (proc &lt;procedure-class&gt;) (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) initial . params) =&gt; &lt;list&gt;</dt>
     419<dd>
     420<p>(Compiles the given SQL), resets the statement, binds the statement's free parameters and executes it step by step. After each step, the column values of the current result row are retrieved and <tt>proc</tt> is applied to the current folded value and the column values. The result of the application becomes the new folded value.</p></dd>
    413421<dt class="definition"><strong>method:</strong> (sqlite3:for-each-row (proc &lt;procedure-class&gt;) (stmt &lt;sqlite3:statement&gt;) . params) =&gt; &lt;void&gt;
    414422<br /><strong>method:</strong> (sqlite3:for-each-row (proc &lt;procedure-class&gt;) (db &lt;sqlite3:database&gt;) (sql &lt;string&gt;) . params) =&gt; &lt;void&gt;</dt>
     
    440448<h3>Version</h3>
    441449<ul>
     450<li>2.0.4 Added <code>sqlite3:fold-row</code> &amp; <code>sqlite3:bind-parameters!</code>. Fix for introduced bug in <code>sqlite3:changes</code>. [Kon Lovett]</li>
    442451<li>2.0.3 Added <code>sqlite3:null-value</code>, <code>sqlite3:null-value?</code>, and <code>sqlite3:null</code>. [Kon Lovett]</li>
    443452<li>2.0.2 Use of extended <tt>define-foreign-enum</tt>. Removed deprecated <tt>pointer</tt> use. [Kon Lovett]</li>
  • release/3/sqlite3/trunk/sqlite3.meta

    r4989 r8020  
    55 (category db)
    66 (eggdoc "doc.scm")
    7  (needs synch tinyclos easyffi)
     7 (needs synch tinyclos easyffi miscmacros)
    88 (license "BSD")
    99 (author "Thomas Chust")
  • release/3/sqlite3/trunk/sqlite3.scm

    r7981 r8020  
    3131    sqlite3:bind-parameter-name
    3232    sqlite3:bind!
     33    sqlite3:bind-parameters!
    3334    sqlite3:step!
    3435    sqlite3:column-count
     
    4243    sqlite3:first-result
    4344    sqlite3:first-row
     45    sqlite3:fold-row
    4446    sqlite3:for-each-row
    4547    sqlite3:map-row
     
    6466    chicken_sqlite3_final_stub
    6567    chicken_sqlite3_step_stub )
    66   (import
     68  (bound-to-procedure
    6769    ##sys#expand-home-path
    68     #;##sys#pathname-resolution )
    69   (bound-to-procedure
     70    #;##sys#pathname-resolution
    7071    sqlite3:errmsg ) )
    7172
    7273#>#include <sqlite3.h><#
    7374
    74 (require-extension
    75  (srfi 1) (srfi 13) (srfi 18) (srfi 26)
    76  extras lolevel tinyclos synch)
     75(use srfi-1 srfi-12 srfi-13 srfi-18 srfi-26 extras lolevel)
     76(use tinyclos synch miscmacros)
     77
     78;;;
     79
     80;; Only works when the invoked object is a procedure.
     81;; Macros & values will not work.
     82(define-macro thunker cut)
    7783
    7884;;; Foreign types & values
     
    140146  (lambda (db)
    141147    (unless (slot-ref db 'this)
    142       (signal-null-error 'sqlite3:database->c-pointer db))
     148      (signal-sqlite3-null-error 'sqlite3:database->c-pointer db))
    143149    db))
    144150
     
    148154  (lambda (stmt)
    149155    (unless (slot-ref stmt 'this)
    150       (signal-null-error 'sqlite3:statement->c-pointer stmt))
     156      (signal-sqlite3-null-error 'sqlite3:statement->c-pointer stmt))
    151157    stmt))
    152158
    153159(define-method (initialize (this <sqlite3:statement>) initargs)
    154160  (call-next-method)
    155   (initialize-slots this initargs))
     161  (initialize-slots this initargs) )
    156162
    157163;;; Helpers
     
    161167  ##sys#expand-home-path
    162168  #; ;not needed, yet
    163   (cut ##sys#pathname-resolution <> identity))
     169  (cut ##sys#pathname-resolution <> identity) )
    164170
    165171;; Conditions
     
    176182    (make-sqlite3-condition sta)) )
    177183
    178 (define (make-no-data-condition stmt params)
    179   (make-sqlite3-error-condition 'sqlite3:first-result
     184(define (make-no-data-condition loc stmt params)
     185  (make-sqlite3-error-condition loc
    180186                                "the statement returned no data"
    181187                                'done
     
    184190;; Errors
    185191
    186 (define ((signal-error loc db . args) sta)
     192(define ((signal-sqlite3-error loc db . args) sta)
    187193  (signal
    188194   (apply make-sqlite3-error-condition loc
     
    191197                                       args)) )
    192198
    193 (define (signal-null-error loc obj)
    194   (signal
    195    (make-sqlite3-error-condition loc
    196                                  (format #f "bad ~A object, contained pointer is #f"
    197                                             (class-name (class-of obj)))
    198                                  'error
    199                                  obj)) )
    200 
    201 (define (check-type loc obj class)
     199(define (check-sqlite3-type loc obj class)
    202200  (unless (instance-of? obj class)
    203201    (abort
    204202     (make-composite-condition
    205203      (make-exn-condition loc
    206                           (format #f "bad argument type ~A, expected ~A"
    207                                      (class-name (class-of obj)) (class-name class))
     204                          (string-append
     205                           "bad argument type " (class-name (class-of obj))
     206                           ", expected " (class-name class))
    208207                          obj)
    209       (make-property-condition 'type)))) )
     208      (make-property-condition 'type)
     209      (make-sqlite3-condition 'error)))) )
     210
     211(define (signal-sqlite3-null-error loc obj)
     212  (signal
     213   (make-sqlite3-error-condition loc
     214                                 (string-append
     215                                  "bad " (class-name (class-of obj))
     216                                  " object, contained pointer is #f")
     217                                 'error
     218                                 obj)) )
     219(define (print-error msg obj)
     220  (print-error-message obj (current-error-port) (string-append "Error: " msg)) )
    210221
    211222;; Tree dictionary
     
    221232       (car keys)
    222233       (cut hash-table-tree-set! <> (cdr keys) value)
    223        (lambda () (make-hash-table))))
    224   ht-tree)
     234       (thunker make-hash-table)) )
     235  ht-tree )
    225236
    226237(define (hash-table-tree-delete! ht-tree keys)
     
    231242       (car keys)
    232243       (cut hash-table-tree-delete! <> (cdr keys))
    233        (lambda () (make-hash-table))))
    234   ht-tree)
     244       (thunker make-hash-table)) )
     245  ht-tree )
    235246
    236247(define (hash-table-tree-ref
    237248         ht-tree keys
    238          #!optional (thunk (lambda ()
    239                              (signal
    240                               (make-composite-condition
    241                                (make-exn-condition 'hash-table-tree-ref
    242                                                    "hash-table-tree does not contain path"
    243                                                    ht-tree keys)
    244                                (make-property-condition 'access))))))
    245   (call-with-current-continuation
    246    (lambda (q)
    247      (let loop ((ht ht-tree) (keys keys))
    248        (if (null? keys)
    249            ht
    250            (loop
    251             (hash-table-ref ht (car keys) (lambda () (q (thunk))))
    252             (cdr keys)))))))
     249         #!optional
     250         (thunk (thunker signal
     251                         (make-composite-condition
     252                          (make-exn-condition
     253                           'hash-table-tree-ref
     254                           "hash-table-tree does not contain path"
     255                           ht-tree keys)
     256                          (make-property-condition 'access)))))
     257  (let/cc return
     258    (let loop ((ht ht-tree)
     259               (keys keys))
     260      (if (null? keys)
     261          ht
     262          (loop (hash-table-ref ht (car keys) (thunker return (thunk)))
     263                (cdr keys)) ) ) ) )
    253264
    254265(define (hash-table-tree-ref/default ht-tree keys default)
    255   (hash-table-tree-ref ht-tree keys (lambda () default)))
     266  (hash-table-tree-ref ht-tree keys (lambda () default)) )
    256267
    257268(define (hash-table-tree-clear! htt id elt-clear)
     
    268279                                                 (c-pointer db))
    269280                 int
    270   (call-with-current-continuation
    271    (lambda (q)
    272      (let ((r #f))
    273        (dynamic-wind
    274            noop
    275            (lambda ()
    276              (handle-exceptions exn
    277                  (print-error-message
    278                   exn (current-error-port) "Error in collation function:")
    279                (let ((a (make-string la)) (b (make-string lb)))
    280                  (move-memory! da a la)
    281                  (move-memory! db b lb)
    282                  (set! r
    283                    ((vector-ref
    284                      (call-with/synch *sqlite3:collations*
    285                        (cut hash-table-tree-ref <> qn))
    286                      1)
    287                     a b)))))
    288            (lambda ()
    289              (if (and (integer? r) (exact? r))
    290                  (q r)
    291                  (begin
    292                    (format
    293                     (current-error-port)
    294                     "Error in collation function: invalid return value: ~S~%"
    295                     r)
    296                    (q 0)))))))))
     281  (let/cc return
     282    (let ((r #f))
     283      (dynamic-wind
     284        noop
     285        (lambda ()
     286          (handle-exceptions exn
     287                             (print-error "in collation function" exn)
     288            (let ((a (make-string la)) (b (make-string lb)))
     289              (move-memory! da a la)
     290              (move-memory! db b lb)
     291              (set! r
     292                    ((vector-ref (call-with/synch *sqlite3:collations*
     293                                   (cut hash-table-tree-ref <> qn))
     294                                 1)
     295                     a b)))))
     296        (lambda ()
     297          (if (and (integer? r) (exact? r))
     298              (return r)
     299              (begin
     300                (print-error "in collation function: invalid return value" (->string r))
     301                (return 0))))) ) ) )
    297302
    298303(define sqlite3_create_collation
     
    317322  (cond
    318323   ((sqlite3_create_collation db name #f)
    319     => (signal-error 'sqlite3:define-collation db name))
     324    => (signal-sqlite3-error 'sqlite3:define-collation db name))
    320325   (else
    321326    (let ((qn (list (pointer->address (slot-ref db 'this)) name)))
     
    326331            => (lambda (info)
    327332                 (hash-table-tree-delete! col qn)
    328                  (object-release (vector-ref info 0)))))))))))
     333                 (object-release (vector-ref info 0))))))) ) ) ) )
    329334
    330335(define-method (sqlite3:define-collation (db <sqlite3:database>)
     
    336341      => (lambda (s)
    337342           (object-release qn)
    338            ((signal-error 'sqlite3:define-collation db name proc) s)))
     343           ((signal-sqlite3-error 'sqlite3:define-collation db name proc) s)))
    339344     (else
    340345      (call-with/synch *sqlite3:collations*
    341         (cut hash-table-tree-set! <> qn (vector qn proc)))))))
     346        (cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )
    342347
    343348;;; SQL function interface
     
    382387            sqlite3:null-value))
    383388         (loop (add1 i)))
    384         '())))
     389        '() ) ) )
    385390
    386391(define-generic sqlite3:set-result!)
     
    389394                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    390395      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
    391    ctx v (blob-size v)))
     396   ctx v (blob-size v)) )
    392397
    393398; Deprecated
     
    396401                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    397402      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
    398    ctx v (byte-vector-length v)))
     403   ctx v (byte-vector-length v)) )
    399404
    400405(define-method (sqlite3:set-result! (ctx <pointer>) (v <exact>))
    401406  ((foreign-lambda void "sqlite3_result_int" sqlite3:context int)
    402    ctx v))
     407   ctx v) )
    403408
    404409(define-method (sqlite3:set-result! (ctx <pointer>) (v <number>))
    405410  ((foreign-lambda void "sqlite3_result_double" sqlite3:context double)
    406    ctx v))
     411   ctx v) )
    407412
    408413(define-method (sqlite3:set-result! (ctx <pointer>) (v <string>))
     
    410415                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    411416    "sqlite3_result_text(ctx, v, n, SQLITE_TRANSIENT);")
    412    ctx v (string-length v)))
     417   ctx v (string-length v)) )
    413418
    414419(define-method (sqlite3:set-result! (ctx <pointer>) (v <void>))
    415420  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
    416    ctx))
     421   ctx) )
    417422
    418423(define-method (sqlite3:set-result! (ctx <pointer>))
    419424  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
    420    ctx))
     425   ctx) )
    421426
    422427(define sqlite3_user_data
    423428  (foreign-lambda scheme-object "sqlite3_user_data" sqlite3:context))
    424429
    425 (define-external (chicken_sqlite3_function_stub (c-pointer ctx) (int n) (c-pointer args)) void
    426   (call-with-current-continuation
    427    (lambda (q)
    428      (dynamic-wind
    429          noop
    430          (lambda ()
    431            (handle-exceptions exn
    432                (print-error-message
    433                 exn (current-error-port) "Error in SQL function:")
    434              (sqlite3:set-result!
    435               ctx
    436               (apply
    437                (vector-ref
    438                 (call-with/synch *sqlite3:functions*
    439                  (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))
    440                 1)
    441                (sqlite3:parameter-data n args)))))
    442          (lambda ()
    443            (q (void)))))))
     430(define-external (chicken_sqlite3_function_stub (c-pointer ctx) (int n) (c-pointer args))
     431                 void
     432  (let/cc return
     433    (dynamic-wind
     434      noop
     435      (lambda ()
     436        (handle-exceptions exn
     437                           (print-error "in SQL function" exn)
     438          (sqlite3:set-result!
     439           ctx
     440           (apply
     441            (vector-ref
     442             (call-with/synch *sqlite3:functions*
     443              (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))
     444             1)
     445            (sqlite3:parameter-data n args)))))
     446     (lambda ()
     447       (return (void)))) ) )
    444448
    445449(define sqlite3_aggregate_context
     
    447451   "return((int)sqlite3_aggregate_context(ctx, 1));"))
    448452
    449 (define-external (chicken_sqlite3_step_stub (c-pointer ctx) (int n) (c-pointer args)) void
    450   (call-with-current-continuation
    451    (lambda (q)
    452      (dynamic-wind
    453          noop
     453(define-external (chicken_sqlite3_step_stub (c-pointer ctx) (int n) (c-pointer args))
     454                 void
     455  (let/cc return
     456    (dynamic-wind
     457      noop
     458      (lambda ()
     459        (handle-exceptions exn
     460                           (print-error "in step of SQL function" exn)
     461          (let ((info (call-with/synch *sqlite3:functions*
     462                       (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
     463            (call-with/synch *sqlite3:seeds*
     464             (cut hash-table-update!/default
     465                  <>
     466                  (sqlite3_aggregate_context ctx)
     467                  (lambda (seed)
     468                    (apply (vector-ref info 1) seed (sqlite3:parameter-data n args)))
     469                  (vector-ref info 2))))))
    454470         (lambda ()
    455            (handle-exceptions exn
    456                (print-error-message
    457                 exn (current-error-port) "Error in step of SQL function:")
    458              (let ((info (call-with/synch *sqlite3:functions*
    459                            (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
    460                (call-with/synch *sqlite3:seeds*
    461                  (cut hash-table-update!/default
    462                       <>
    463                       (sqlite3_aggregate_context ctx)
    464                       (lambda (seed)
    465                         (apply
    466                          (vector-ref info 1)
    467                          seed
    468                          (sqlite3:parameter-data n args)))
    469                       (vector-ref info 2))))))
    470          (lambda ()
    471            (q (void)))))))
    472 
    473 (define-external (chicken_sqlite3_final_stub (c-pointer ctx)) void
    474   (call-with-current-continuation
    475    (lambda (q)
    476      (let ((agc (sqlite3_aggregate_context ctx)))
    477        (dynamic-wind
    478            noop
    479            (lambda ()
    480              (handle-exceptions exn
    481                  (print-error-message
    482                   exn (current-error-port) "Error in final of SQL function:")
    483                (let ((info (call-with/synch *sqlite3:functions*
    484                              (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
    485                  (cond
    486                   (((vector-ref info 3)
    487                     (call-with/synch *sqlite3:seeds*
    488                       (cut hash-table-ref/default <> agc (vector-ref info 2))))
    489                    => (cut sqlite3:set-result! ctx <>))
    490                   (else
    491                    (sqlite3:set-result! ctx))))))
    492            (lambda ()
    493              (call-with/synch *sqlite3:seeds*
    494                (cut hash-table-delete! <> agc))
    495              (q (void))))))))
     471           (return (void)))) ) )
     472
     473(define-external (chicken_sqlite3_final_stub (c-pointer ctx))
     474                 void
     475  (let/cc return
     476    (let ((agc (sqlite3_aggregate_context ctx)))
     477      (dynamic-wind
     478        noop
     479        (lambda ()
     480          (handle-exceptions exn
     481                             (print-error "in final of SQL function" exn)
     482            (let ((info (call-with/synch *sqlite3:functions*
     483                         (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
     484              (cond
     485                (((vector-ref info 3)
     486                  (call-with/synch *sqlite3:seeds*
     487                   (cut hash-table-ref/default <> agc (vector-ref info 2))))
     488                 => (cut sqlite3:set-result! ctx <>))
     489                (else
     490                  (sqlite3:set-result! ctx))))))
     491        (lambda ()
     492          (call-with/synch *sqlite3:seeds*
     493           (cut hash-table-delete! <> agc))
     494          (return (void)))) ) ) )
    496495
    497496(define-generic sqlite3:define-function)
     
    517516      => (lambda (s)
    518517           (object-release qn)
    519            ((signal-error 'sqlite3:define-function db name n proc) s)))
     518           ((signal-sqlite3-error 'sqlite3:define-function db name n proc) s)))
    520519     (else
    521520      (call-with/synch *sqlite3:functions*
    522         (cut hash-table-tree-set! <> qn (vector qn proc)))))))
     521        (cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )
    523522
    524523(define-method (sqlite3:define-function (db <sqlite3:database>)
     
    528527                                         (seed <top>)
    529528                                         #!optional (final-proc identity))
    530   (check-type 'sqlite3:define-function final-proc <procedure-class>)
     529  (check-sqlite3-type 'sqlite3:define-function final-proc <procedure-class>)
    531530  (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    532531    (cond
     
    547546      => (lambda (s)
    548547           (object-release qn)
    549            ((signal-error
     548           ((signal-sqlite3-error
    550549              'sqlite3:define-function db name n step-proc seed final-proc)
    551550            s)))
    552551     (else
    553552      (call-with/synch *sqlite3:functions*
    554         (cut hash-table-tree-set! <> qn (vector qn step-proc seed final-proc)))))))
     553        (cut hash-table-tree-set! <> qn (vector qn step-proc seed final-proc))) ) ) ) )
    555554
    556555;;; Database interface
     
    558557;; Get any error message
    559558(define sqlite3:errmsg
    560   (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database))
     559  (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database) )
    561560
    562561;; Open a database
    563562(define (sqlite3:open path)
    564   (check-type 'sqlite3:open path <string>)
     563  (check-sqlite3-type 'sqlite3:open path <string>)
    565564  (let-location ((db c-pointer))
    566565    (cond
     
    568567                                      nonnull-c-string (c-pointer sqlite3:database))
    569568       (sqlite3:resolve-pathname path) (location db))
    570       => (signal-error 'sqlite3:open #f path))
     569      => (signal-sqlite3-error 'sqlite3:open #f path))
    571570     (else
    572       (make <sqlite3:database> 'this db)))))
     571      (make <sqlite3:database> 'this db) ) ) ) )
    573572
    574573;; Set a timeout until a busy error is thrown
    575574(define (sqlite3:set-busy-timeout! db #!optional (ms 0))
    576   (check-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
     575  (check-sqlite3-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
    577576  (cond
    578577   (((foreign-lambda sqlite3:status "sqlite3_busy_timeout" sqlite3:database int) db ms)
    579     => (signal-error 'sqlite3:set-busy-timeout! db db ms))))
     578    => (signal-sqlite3-error 'sqlite3:set-busy-timeout! db db ms))) )
    580579
    581580;; Cancel any running database operation as soon as possible
    582581(define (sqlite3:interrupt! db)
    583   (check-type 'sqlite3:interrupt! db <sqlite3:database>)
    584   ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db))
     582  (check-sqlite3-type 'sqlite3:interrupt! db <sqlite3:database>)
     583  ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db) )
    585584
    586585;; Check whether the database is in autocommit mode
    587586(define (sqlite3:auto-committing? db)
    588   (check-type 'sqlite3:auto-committing? db <sqlite3:database>)
    589   ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db))
     587  (check-sqlite3-type 'sqlite3:auto-committing? db <sqlite3:database>)
     588  ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db) )
    590589
    591590;; Get the number of changes made to the database
    592591(define (sqlite3:changes db #!optional (total #f))
    593   (check-type 'sqlite3:changes db <sqlite3:database>)
     592  (check-sqlite3-type 'sqlite3:changes db <sqlite3:database>)
    594593  (if total
    595       ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db))
    596       ((foreign-lambda number "sqlite3_changes" sqlite3:database) db))
     594      ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db)
     595      ((foreign-lambda number "sqlite3_changes" sqlite3:database) db) ) )
    597596
    598597;; Get the row ID of the last inserted row
    599598(define (sqlite3:last-insert-rowid db)
    600   (check-type 'sqlite3:last-insert-rowid db <sqlite3:database>)
    601   ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db))
     599  (check-sqlite3-type 'sqlite3:last-insert-rowid db <sqlite3:database>)
     600  ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db) )
    602601
    603602;; Close a database
     
    608607    (void))
    609608   (((foreign-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)
    610     => (signal-error 'sqlite3:finalize! db db))
     609    => (signal-sqlite3-error 'sqlite3:finalize! db db))
    611610   (else
    612611    (let ((id (pointer->address (slot-ref db 'this)))
     
    622621;; Create a new statement
    623622(define (sqlite3:prepare db sql)
    624   (check-type 'sqlite3:prepare db <sqlite3:database>)
    625   (check-type 'sqlite3:prepare sql <string>)
     623  (check-sqlite3-type 'sqlite3:prepare db <sqlite3:database>)
     624  (check-sqlite3-type 'sqlite3:prepare sql <string>)
    626625  (let-location ((stmt c-pointer) (tail c-string))
    627626    (cond
     
    631630                                      (c-pointer (const c-string)))
    632631       db sql (string-length sql) (location stmt) (location tail))
    633       => (signal-error 'sqlite3:prepare db db sql))
     632      => (signal-sqlite3-error 'sqlite3:prepare db db sql))
    634633     (else
    635634      (values
    636635       (make <sqlite3:statement> 'this stmt 'database db 'sql sql)
    637        tail)))))
     636       tail) ) ) ) )
    638637
    639638;; Recompile an existing statement and transfer all bindings
    640639(define (sqlite3:repair! stmt)
    641   (check-type 'sqlite3:repair! stmt <sqlite3:statement>)
     640  (check-sqlite3-type 'sqlite3:repair! stmt <sqlite3:statement>)
    642641  (let ((fresh (sqlite3:prepare
    643642                (slot-ref stmt 'database) (slot-ref stmt 'sql))))
     
    651650                                              c-pointer c-pointer)
    652651               old new)
    653               => (signal-error 'sqlite3:repair! (slot-ref stmt 'database) stmt))
     652              => (signal-sqlite3-error 'sqlite3:repair! (slot-ref stmt 'database) stmt))
    654653             (else
    655654              (slot-set! stmt 'this new)
    656655              (slot-set! fresh 'this old)))))
    657656        (lambda ()
    658           (sqlite3:finalize! fresh)))))
     657          (sqlite3:finalize! fresh))) ) )
    659658
    660659;; Discard an existing statement
     
    665664    (void))
    666665   (((foreign-lambda sqlite3:status "sqlite3_finalize" sqlite3:statement) stmt)
    667     => (signal-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt))
     666    => (signal-sqlite3-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt))
    668667   (else
    669     (slot-set! stmt 'this #f))))
     668    (slot-set! stmt 'this #f) ) ) )
    670669
    671670;; Reset an existing statement to process it again
     
    674673
    675674(define (sqlite3:reset! stmt)
    676   (check-type 'sqlite3:reset! stmt <sqlite3:statement>)
     675  (check-sqlite3-type 'sqlite3:reset! stmt <sqlite3:statement>)
    677676  (cond
    678677   ((sqlite3_reset stmt)
    679     => (signal-error 'sqlite3:reset! (slot-ref stmt 'database) stmt))))
     678    => (signal-sqlite3-error 'sqlite3:reset! (slot-ref stmt 'database) stmt))) )
    680679
    681680;; Get number of bindable parameters
    682681(define (sqlite3:bind-parameter-count stmt)
    683   (check-type 'sqlite3:bind-parameter-count stmt <sqlite3:statement>)
    684   ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt))
     682  (check-sqlite3-type 'sqlite3:bind-parameter-count stmt <sqlite3:statement>)
     683  ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt) )
    685684
    686685;; Get index of a bindable parameter or #f if no parameter with the
    687686;; given name exists
    688687(define (sqlite3:bind-parameter-index stmt name)
    689   (check-type 'sqlite3:bind-parameter-index stmt <sqlite3:statement>)
     688  (check-sqlite3-type 'sqlite3:bind-parameter-index stmt <sqlite3:statement>)
    690689  (let ((i ((foreign-lambda int "sqlite3_bind_parameter_index"
    691690                                sqlite3:statement nonnull-c-string)
    692691            stmt name)))
    693     (if (zero? i) #f (sub1 i))))
     692    (if (zero? i)
     693        #f
     694        (sub1 i) ) ) )
    694695
    695696;; Get the name of a bindable parameter
    696697(define (sqlite3:bind-parameter-name stmt i)
    697   (check-type 'sqlite3:bind-parameter-name stmt <sqlite3:statement>)
    698   ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int) stmt (add1 i)))
     698  (check-sqlite3-type 'sqlite3:bind-parameter-name stmt <sqlite3:statement>)
     699  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int) stmt (add1 i)) )
    699700
    700701;; Bind data as parameters to an existing statement
     
    708709      "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
    709710     stmt (add1 i) v (blob-size v))
    710     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     711    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
    711712
    712713; Deprecated
     
    718719      "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
    719720     stmt (add1 i) v (byte-vector-length v))
    720     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     721    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
    721722
    722723(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    726727                                    sqlite3:statement int int)
    727728     stmt (add1 i) v)
    728     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     729    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
    729730
    730731(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    734735                                    sqlite3:statement int double)
    735736     stmt (add1 i) v)
    736     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     737    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
    737738
    738739(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    743744      "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
    744745     stmt (add1 i) v (string-length v))
    745     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     746    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
    746747
    747748(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     
    749750  (cond
    750751   (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    751     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))))
     752    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )
    752753
    753754(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>))
    754755  (cond
    755756   (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    756     => (signal-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))))
     757    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )
     758
     759; Helper
     760(define (bind-parameters! loc stmt params)
     761  (sqlite3:reset! stmt)
     762  (let ((cnt (sqlite3:bind-parameter-count stmt)))
     763    (unless (= cnt (length params))
     764      (abort
     765       (make-composite-condition
     766        (make-exn-condition loc "too few parameters" cnt params)
     767        (make-property-condition 'arity)
     768        (make-sqlite3-condition 'error))) )
     769    (for-each (cut sqlite3:bind! stmt <> <>) (iota cnt) params) ) )
     770
     771(define (sqlite3:bind-parameters! stmt . params)
     772  (bind-parameters! 'sqlite3:bind-parameters! stmt params) )
    757773
    758774;; Single-step a prepared statement, return #t if data is available,
    759775;; #f otherwise
    760776(define (sqlite3:step! stmt)
    761   (check-type 'sqlite3:step! stmt <sqlite3:statement>)
     777  (check-sqlite3-type 'sqlite3:step! stmt <sqlite3:statement>)
    762778  (let retry ()
    763779    (let ((s ((foreign-safe-lambda
     
    774790              (retry))
    775791             (else
    776               ((signal-error
     792              ((signal-sqlite3-error
    777793                'sqlite3:step! (slot-ref stmt 'database) stmt) s)))))
    778794        (else
    779          ((signal-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s))))))
     795         ((signal-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ) ) ) ) )
    780796
    781797;; Retrieve information from a prepared/stepped statement
    782798(define (sqlite3:column-count stmt)
    783   (check-type 'sqlite3:column-count stmt <sqlite3:statement>)
    784   ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt))
     799  (check-sqlite3-type 'sqlite3:column-count stmt <sqlite3:statement>)
     800  ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt) )
    785801
    786802(define (sqlite3:column-type stmt i)
    787   (check-type 'sqlite3:column-type stmt <sqlite3:statement>)
    788   ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i))
     803  (check-sqlite3-type 'sqlite3:column-type stmt <sqlite3:statement>)
     804  ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i) )
    789805
    790806(define (sqlite3:column-declared-type stmt i)
    791   (check-type 'sqlite3:column-declared-type stmt <sqlite3:statement>)
    792   ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i))
     807  (check-sqlite3-type 'sqlite3:column-declared-type stmt <sqlite3:statement>)
     808  ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i) )
    793809
    794810(define (sqlite3:column-name stmt i)
    795   (check-type 'sqlite3:column-name stmt <sqlite3:statement>)
    796   ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i))
     811  (check-sqlite3-type 'sqlite3:column-name stmt <sqlite3:statement>)
     812  ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i) )
    797813
    798814;; Retrieve data from a stepped statement
     
    816832      stmt i))
    817833    (else
    818      sqlite3:null-value)))
     834     sqlite3:null-value ) ) )
    819835
    820836;;; Easy statement interface
     
    823839;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
    824840(define (sqlite3:call-with-temporary-statements proc db . sqls)
    825   (check-type 'sqlite3:call-with-temporary-statements db <sqlite3:database>)
     841  (check-sqlite3-type 'sqlite3:call-with-temporary-statements db <sqlite3:database>)
    826842  (let ((stmts #f))
    827843    (dynamic-wind
     
    834850          (when stmts
    835851            (map sqlite3:finalize! stmts)
    836             (set! stmts #f))))))
     852            (set! stmts #f)))) ) )
    837853
    838854;; Step through a statement and ignore possible results
    839855(define-generic sqlite3:exec)
    840856(define-method (sqlite3:exec (stmt <sqlite3:statement>) . params)
    841   (sqlite3:reset! stmt)
    842   (for-each
    843    (cute sqlite3:bind! stmt <> <>)
    844    (iota (sqlite3:bind-parameter-count stmt)) params)
    845   (do () ((not (sqlite3:step! stmt)) sqlite3:null-value)))
     857  (bind-parameters! 'sqlite3:exec stmt params)
     858  (while (sqlite3:step! stmt))
     859  sqlite3:null-value )
    846860
    847861(define-method (sqlite3:exec (db <sqlite3:database>) (sql <string>) . params)
    848862  (sqlite3:call-with-temporary-statements
    849    (cute apply sqlite3:exec <> params)
    850    db sql))
     863   (cut apply sqlite3:exec <> params)
     864   db sql) )
    851865
    852866;; Step through a statement, ignore possible results and return the
     
    856870  (sqlite3:reset! stmt)
    857871  (apply sqlite3:exec stmt params)
    858   (sqlite3:changes (slot-ref stmt 'database)))
     872  (sqlite3:changes (slot-ref stmt 'database)) )
    859873
    860874(define-method (sqlite3:update (db <sqlite3:database>) (sql <string>) . params)
    861875  (apply sqlite3:exec db sql params)
    862   (sqlite3:changes db))
     876  (sqlite3:changes db) )
    863877
    864878;; Return only the first column of the first result row produced by this
     
    867881(define-generic sqlite3:first-result)
    868882(define-method (sqlite3:first-result (stmt <sqlite3:statement>) . params)
    869   (sqlite3:reset! stmt)
    870   (for-each
    871    (cute sqlite3:bind! stmt <> <>)
    872    (iota (sqlite3:bind-parameter-count stmt)) params)
     883  (bind-parameters! 'sqlite3:first-result stmt params)
    873884  (if (sqlite3:step! stmt)
    874885      (let ((r (sqlite3:column-data stmt 0)))
    875886        (sqlite3:reset! stmt)
    876         r)
    877       (signal (make-no-data-condition stmt params)) ) )
     887        r )
     888      (signal (make-no-data-condition 'sqlite3:first-result stmt params)) ) )
    878889
    879890(define-method (sqlite3:first-result
    880891                (db <sqlite3:database>) (sql <string>) . params)
    881892  (sqlite3:call-with-temporary-statements
    882    (cute apply sqlite3:first-result <> params)
    883    db sql))
     893   (cut apply sqlite3:first-result <> params)
     894   db sql) )
    884895
    885896;; Return only the first result row produced by this statement as a list
     
    887898(define-generic sqlite3:first-row)
    888899(define-method (sqlite3:first-row (stmt <sqlite3:statement>) . params)
    889   (sqlite3:reset! stmt)
    890   (for-each
    891    (cute sqlite3:bind! stmt <> <>)
    892    (iota (sqlite3:bind-parameter-count stmt)) params)
     900  (bind-parameters! 'sqlite3:first-row stmt params)
    893901  (if (sqlite3:step! stmt)
    894       (map
    895        (cute sqlite3:column-data stmt <>)
    896        (iota (sqlite3:column-count stmt)))
    897       (signal (make-no-data-condition stmt params)) ) )
     902      (map (cut sqlite3:column-data stmt <>)
     903           (iota (sqlite3:column-count stmt)))
     904      (signal (make-no-data-condition 'sqlite3:first-row stmt params)) ) )
    898905
    899906(define-method (sqlite3:first-row
    900907                (db <sqlite3:database>) (sql <string>) . params)
    901908  (sqlite3:call-with-temporary-statements
    902    (cute apply sqlite3:first-row <> params)
     909   (cut apply sqlite3:first-row <> params)
    903910   db sql))
     911
     912;; Apply a procedure to the values of the result columns for each result row
     913;; while executing the statement and accumulating results.
     914
     915(define (%fold-row loc proc stmt init params)
     916  (bind-parameters! loc stmt params)
     917  (let ((cl (iota (sqlite3:column-count stmt))))
     918    (let loop ((acc init))
     919      (if (sqlite3:step! stmt)
     920          (loop (apply proc acc (map (cut sqlite3:column-data stmt <>) cl)))
     921          acc ) ) ) )
     922
     923(define-generic sqlite3:fold-row)
     924(define-method (sqlite3:fold-row (proc <procedure-class>)
     925                                 (stmt <sqlite3:statement>)
     926                                 (init <object>) . params)
     927  (%fold-row 'sqlite3:fold-row proc stmt init params) )
     928
     929(define-method (sqlite3:fold-row (proc <procedure-class>)
     930                                 (db <sqlite3:database>)
     931                                 (sql <string>)
     932                                 (init <object>) . params)
     933  (sqlite3:call-with-temporary-statements
     934   (cut apply sqlite3:fold-row proc <> init params)
     935   db sql) )
    904936
    905937;; Apply a procedure to the values of the result columns for each result row
    906938;; while executing the statement and discard the results
    907939
     940(define (for-each-row-proc proc)
     941  (lambda (acc . cols)
     942    (apply proc cols)
     943    acc ) )
     944
    908945(define-generic sqlite3:for-each-row)
    909 (define-method (sqlite3:for-each-row
    910                 (proc <procedure-class>) (stmt <sqlite3:statement>) . params)
    911   (sqlite3:reset! stmt)
    912   (for-each
    913    (cute sqlite3:bind! stmt <> <>)
    914    (iota (sqlite3:bind-parameter-count stmt)) params)
    915   (do ((cl (iota (sqlite3:column-count stmt))))
    916       ((not (sqlite3:step! stmt)) sqlite3:null-value)
    917     (apply proc (map (cute sqlite3:column-data stmt <>) cl))))
    918 
    919 (define-method (sqlite3:for-each-row
    920                 (proc <procedure-class>)
    921                 (db <sqlite3:database>) (sql <string>) . params)
     946(define-method (sqlite3:for-each-row (proc <procedure-class>)
     947                                     (stmt <sqlite3:statement>) . params)
     948  (%fold-row 'sqlite3:for-each-row (for-each-row-proc proc) stmt (void) params) )
     949
     950(define-method (sqlite3:for-each-row (proc <procedure-class>)
     951                                     (db <sqlite3:database>)
     952                                     (sql <string>) . params)
    922953  (sqlite3:call-with-temporary-statements
    923    (cute apply sqlite3:for-each-row proc <> params)
    924    db sql))
     954   (cut apply sqlite3:for-each-row proc <> params)
     955   db sql) )
    925956
    926957;; Apply a procedure to the values of the result columns for each result row
    927958;; while executing the statement and accumulate the results in a list
    928959
     960(define (map-row-proc proc)
     961  (lambda (acc . cols)
     962    (cons (apply proc cols) acc) ) )
     963
    929964(define-generic sqlite3:map-row)
    930 (define-method (sqlite3:map-row
    931                 (proc <procedure-class>) (stmt <sqlite3:statement>) . params)
    932   (sqlite3:reset! stmt)
    933   (for-each
    934    (cute sqlite3:bind! stmt <> <>)
    935    (iota (sqlite3:bind-parameter-count stmt)) params)
    936   (let ((cl (iota (sqlite3:column-count stmt))))
    937     (let loop ()
    938       (if (sqlite3:step! stmt)
    939           (cons
    940            (apply proc (map (cute sqlite3:column-data stmt <>) cl))
    941            (loop))
    942           '()))))
    943 
    944 (define-method (sqlite3:map-row
    945                 (proc <procedure-class>)
    946                 (db <sqlite3:database>) (sql <string>) . params)
     965(define-method (sqlite3:map-row (proc <procedure-class>)
     966                                (stmt <sqlite3:statement>) . params)
     967  (reverse! (%fold-row 'sqlite3:map-row (map-row-proc proc) stmt '() params)) )
     968
     969(define-method (sqlite3:map-row (proc <procedure-class>)
     970                                (db <sqlite3:database>)
     971                                (sql <string>) . params)
    947972  (sqlite3:call-with-temporary-statements
    948    (cute apply sqlite3:map-row proc <> params)
    949    db sql))
     973   (cut apply sqlite3:map-row proc <> params)
     974   db sql) )
    950975
    951976;;; Utility procedures
     
    955980;; an exception
    956981(define (sqlite3:with-transaction db thunk #!optional (type 'deferred))
    957   (check-type 'sqlite3:with-transaction db <sqlite3:database>)
    958   (check-type 'sqlite3:with-transaction thunk <procedure-class>)
     982  (check-sqlite3-type 'sqlite3:with-transaction db <sqlite3:database>)
     983  (check-sqlite3-type 'sqlite3:with-transaction thunk <procedure-class>)
    959984  (unless (memq type '(deferred immediate exclusive))
    960985    (abort
    961986     (make-composite-condition
    962987      (make-exn-condition 'sqlite3:with-transaction
    963                           (format #f
    964                            "bad argument ~A, expected deferred, immediate or exclusive"
    965                            type)
     988                          "bad argument: expected deferred, immediate or exclusive"
    966989                          type)
    967       (make-property-condition 'type))))
     990      (make-property-condition 'type))) )
    968991  (let ((success? #f))
    969992    (dynamic-wind
    970993        (lambda ()
    971           (sqlite3:exec db (format #f "BEGIN ~a TRANSACTION;" type)))
     994          (sqlite3:exec db
     995           (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
    972996        (lambda ()
    973997          (set! success? (thunk)))
    974998        (lambda ()
    975           (sqlite3:exec
    976            db (if success?
    977                   "COMMIT TRANSACTION;"
    978                   "ROLLBACK TRANSACTION;"))))))
     999          (sqlite3:exec db
     1000           (if success?
     1001               "COMMIT TRANSACTION;"
     1002               "ROLLBACK TRANSACTION;")))) ) )
    9791003
    9801004;; Check if the given string is a valid SQL statement
     
    9841008;; Return a descriptive version string
    9851009(define sqlite3:library-version
    986   (foreign-lambda c-string "sqlite3_libversion"))
     1010  (foreign-lambda c-string "sqlite3_libversion") )
  • release/3/sqlite3/trunk/sqlite3.setup

    r7981 r8020  
    1 (required-extension-version 'tinyclos "1.4" 'synch "1.3")
     1(required-extension-version 'tinyclos "1.4" 'synch "1.3" 'miscmacros "2.5")
    22
    33(define so-file "sqlite3.so")
     4
    45(compile
    56  -O2 -d0 -X easyffi -X tinyclos -s sqlite3.scm -lsqlite3
    67  -o ,so-file
    78  -check-imports -emit-exports "sqlite3.exports")
     9
    810(install-extension
    911  'sqlite3
    1012  `(,so-file
    1113    "sqlite3.html" "egg.jpg")
    12   '((version "2.0.3") (documentation "sqlite3.html")))
     14  '((version "2.0.4")
     15    (documentation "sqlite3.html")))
Note: See TracChangeset for help on using the changeset viewer.