Ignore:
Timestamp:
02/23/08 17:16:34 (14 years ago)
Author:
Kon Lovett
Message:

Rel 2.0.5

Location:
release/3/sqlite3/tags/2.0.5
Files:
1 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/3/sqlite3/tags/2.0.5/sqlite3.scm

    r8020 r8688  
    4949    sqlite3:complete?
    5050    sqlite3:library-version
    51     ;; null type
    52     sqlite3:null
    53     sqlite3:null-value?
    54     sqlite3:null-value) )
     51    sqlite3:boolean-value ) )
    5552
    5653(declare
     
    6158  (disable-warning redef)
    6259  (unused
    63     ; global variable '...' is never used
     60    ; Stop annoying messages
    6461    chicken_sqlite3_function_stub
    6562    chicken_sqlite3_collation_stub
     
    6966    ##sys#expand-home-path
    7067    #;##sys#pathname-resolution
     68    abort-sqlite3-null-error
    7169    sqlite3:errmsg ) )
    7270
    7371#>#include <sqlite3.h><#
    7472
    75 (use srfi-1 srfi-12 srfi-13 srfi-18 srfi-26 extras lolevel)
     73#;(use srfi-1 srfi-12 srfi-13 srfi-18 srfi-26 srfi-69 extras lolevel)
     74(use (srfi 1 12 13 18 26 69) extras lolevel)
    7675(use tinyclos synch miscmacros)
    7776
     
    132131(define-foreign-type sqlite3:value (c-pointer "sqlite3_value"))
    133132
    134 (define sqlite3:null void)
    135 
    136 (define sqlite3:null-value (sqlite3:null))
    137 
    138 (define (sqlite3:null-value? obj)
    139   (eq? sqlite3:null-value obj) )
    140 
    141133;;; Classes for databases and statements
    142134
     
    146138  (lambda (db)
    147139    (unless (slot-ref db 'this)
    148       (signal-sqlite3-null-error 'sqlite3:database->c-pointer db))
     140      (abort-sqlite3-null-error 'sqlite3:database->c-pointer db))
    149141    db))
    150142
     
    154146  (lambda (stmt)
    155147    (unless (slot-ref stmt 'this)
    156       (signal-sqlite3-null-error 'sqlite3:statement->c-pointer stmt))
     148      (abort-sqlite3-null-error 'sqlite3:statement->c-pointer stmt))
    157149    stmt))
    158150
     
    167159  ##sys#expand-home-path
    168160  #; ;not needed, yet
    169   (cut ##sys#pathname-resolution <> identity) )
     161  (cute ##sys#pathname-resolution <> identity) )
    170162
    171163;; Conditions
     
    190182;; Errors
    191183
    192 (define ((signal-sqlite3-error loc db . args) sta)
    193   (signal
     184(define ((abort-sqlite3-error loc db . args) sta)
     185  (abort
    194186   (apply make-sqlite3-error-condition loc
    195187                                       (if db (sqlite3:errmsg db) (symbol->string sta))
     
    209201      (make-sqlite3-condition 'error)))) )
    210202
    211 (define (signal-sqlite3-null-error loc obj)
    212   (signal
     203(define (abort-sqlite3-null-error loc obj)
     204  (abort
    213205   (make-sqlite3-error-condition loc
    214206                                 (string-append
     
    228220  (if (null? (cdr keys))
    229221      (hash-table-set! ht-tree (car keys) value)
    230       (hash-table-update!
    231        ht-tree
    232        (car keys)
    233        (cut hash-table-tree-set! <> (cdr keys) value)
    234        (thunker make-hash-table)) )
     222      (hash-table-update! ht-tree
     223                          (car keys)
     224                          (cute hash-table-tree-set! <> (cdr keys) value)
     225                          (thunker make-hash-table)) )
    235226  ht-tree )
    236227
     
    238229  (if (null? (cdr keys))
    239230      (hash-table-delete! ht-tree (car keys))
    240       (hash-table-update!
    241        ht-tree
    242        (car keys)
    243        (cut hash-table-tree-delete! <> (cdr keys))
    244        (thunker make-hash-table)) )
     231      (hash-table-update! ht-tree
     232                          (car keys)
     233                          (cute hash-table-tree-delete! <> (cdr keys))
     234                          (thunker make-hash-table)) )
    245235  ht-tree )
    246236
     
    248238         ht-tree keys
    249239         #!optional
    250          (thunk (thunker signal
     240         (thunk (thunker abort
    251241                         (make-composite-condition
    252                           (make-exn-condition
    253                            'hash-table-tree-ref
    254                            "hash-table-tree does not contain path"
    255                            ht-tree keys)
     242                          (make-exn-condition 'hash-table-tree-ref
     243                                              "hash-table-tree does not contain path"
     244                                              ht-tree keys)
    256245                          (make-property-condition 'access)))))
    257246  (let/cc return
    258     (let loop ((ht ht-tree)
    259                (keys keys))
     247    (let loop ([ht ht-tree]
     248               [keys keys] )
    260249      (if (null? keys)
    261250          ht
     
    267256
    268257(define (hash-table-tree-clear! htt id elt-clear)
    269   (cond ((hash-table-ref/default htt id #f)
    270          => (cut hash-table-walk <> elt-clear)))
     258  (cond [(hash-table-ref/default htt id #f)
     259         => (cute hash-table-walk <> elt-clear) ] )
    271260  (hash-table-delete! htt id) )
    272261
     
    280269                 int
    281270  (let/cc return
    282     (let ((r #f))
     271    (let ([r #f])
    283272      (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))))) ) ) )
     273          noop
     274          (lambda ()
     275            (handle-exceptions exn
     276                               (print-error "in collation function" exn)
     277              (let ([a (make-string la)]
     278                    [b (make-string lb)] )
     279                (move-memory! da a la)
     280                (move-memory! db b lb)
     281                (set! r
     282                      ((vector-ref (call-with/synch *sqlite3:collations*
     283                                     (cute hash-table-tree-ref <> qn))
     284                                   1)
     285                       a b)))))
     286          (lambda ()
     287            (if (and (integer? r) (exact? r))
     288                (return r)
     289                (begin
     290                  (print-error "in collation function: invalid return value" (->string r))
     291                  (return 0))))) ) ) )
    302292
    303293(define sqlite3_create_collation
    304294  (foreign-lambda* sqlite3:status
    305295                  ((sqlite3:database db) (c-string name) (scheme-object qn))
    306 #<<END
     296#<<EOS
    307297  if (qn == C_SCHEME_FALSE)
    308298    return(sqlite3_create_collation(db, name, SQLITE_UTF8, NULL, NULL));
     
    314304                                               int, const void *))
    315305                                        &chicken_sqlite3_collation_stub));
    316 END
     306EOS
    317307  ))
    318308
     
    320310(define-method (sqlite3:define-collation (db <sqlite3:database>)
    321311                                         (name <string>))
    322   (cond
    323    ((sqlite3_create_collation db name #f)
    324     => (signal-sqlite3-error 'sqlite3:define-collation db name))
    325    (else
    326     (let ((qn (list (pointer->address (slot-ref db 'this)) name)))
    327       (call-with/synch *sqlite3:collations*
    328         (lambda (col)
    329           (cond
    330            ((hash-table-tree-ref/default col qn #f)
    331             => (lambda (info)
    332                  (hash-table-tree-delete! col qn)
    333                  (object-release (vector-ref info 0))))))) ) ) ) )
     312  (cond [(sqlite3_create_collation db name #f)
     313         => (abort-sqlite3-error 'sqlite3:define-collation db name) ]
     314        [else
     315         (let ([qn (list (pointer->address (slot-ref db 'this)) name)])
     316           (call-with/synch *sqlite3:collations*
     317             (lambda (col)
     318               (cond [(hash-table-tree-ref/default col qn #f)
     319                      => (lambda (info)
     320                           (hash-table-tree-delete! col qn)
     321                           (object-release (vector-ref info 0))) ] ) ) ) ) ] ) )
    334322
    335323(define-method (sqlite3:define-collation (db <sqlite3:database>)
    336324                                          (name <string>)
    337325                                          (proc <procedure-class>))
    338   (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    339     (cond
    340      ((sqlite3_create_collation db name qn)
    341       => (lambda (s)
    342            (object-release qn)
    343            ((signal-sqlite3-error 'sqlite3:define-collation db name proc) s)))
    344      (else
    345       (call-with/synch *sqlite3:collations*
    346         (cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )
     326  (let ([qn (object-evict (list (pointer->address (slot-ref db 'this)) name))])
     327    (cond [(sqlite3_create_collation db name qn)
     328           => (lambda (s)
     329                (object-release qn)
     330                ((abort-sqlite3-error 'sqlite3:define-collation db name proc) s)) ]
     331          [else
     332           (call-with/synch *sqlite3:collations*
     333        (cute hash-table-tree-set! <> qn (vector qn proc))) ] ) ) )
    347334
    348335;;; SQL function interface
     
    353340
    354341(define (sqlite3:parameter-data n args)
    355   (let loop ((i 0))
    356     (if (< i n)
    357         (cons
    358          (case ((foreign-lambda* sqlite3:type
    359                                  (((c-pointer sqlite3:value) args) (int i))
    360                  "return(sqlite3_value_type(args[i]));")
    361                 args i)
    362            ((integer)
    363             ((foreign-lambda* integer
    364                               (((c-pointer sqlite3:value) args) (int i))
    365               "return(sqlite3_value_double(args[i]));")
    366              args i))
    367            ((float)
    368             ((foreign-lambda* double
    369                               (((c-pointer sqlite3:value) args) (int i))
    370               "return(sqlite3_value_double(args[i]));")
    371              args i))
    372            ((text)
    373             ((foreign-primitive scheme-object
    374                                 (((c-pointer sqlite3:value) args) (int i))
    375               "int n = sqlite3_value_bytes(args[i]);"
    376               "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
    377               "return(C_string(&s, n, (char *)sqlite3_value_text(args[i])));")
    378              args i))
    379            ((blob)
    380             ((foreign-primitive scheme-object
    381                                 (((c-pointer sqlite3:value) args) (int i))
    382               "int n = sqlite3_value_bytes(args[i]);"
    383               "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
    384               "return(C_bytevector(&s, n, (char *)sqlite3_value_blob(args[i])));")
    385              args i))
    386            (else
    387             sqlite3:null-value))
    388          (loop (add1 i)))
    389         '() ) ) )
     342  (let loop ([i 0])
     343    (if (<= n i)
     344        '()
     345        (cons (case ((foreign-lambda* sqlite3:type
     346                                      (((c-pointer sqlite3:value) args) (int i))
     347                      "return(sqlite3_value_type(args[i]));")
     348                     args i)
     349                [(integer)
     350                 ((foreign-lambda* integer
     351                                   (((c-pointer sqlite3:value) args) (int i))
     352                   "return(sqlite3_value_double(args[i]));")
     353                  args i) ]
     354                [(float)
     355                 ((foreign-lambda* double
     356                                   (((c-pointer sqlite3:value) args) (int i))
     357                   "return(sqlite3_value_double(args[i]));")
     358                  args i) ]
     359                [(text)
     360                 ((foreign-primitive scheme-object
     361                                     (((c-pointer sqlite3:value) args) (int i))
     362                   "int n = sqlite3_value_bytes(args[i]);"
     363                   "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
     364                   "return(C_string(&s, n, (char *)sqlite3_value_text(args[i])));")
     365                  args i) ]
     366                [(blob)
     367                 ((foreign-primitive scheme-object
     368                                     (((c-pointer sqlite3:value) args) (int i))
     369                   "int n = sqlite3_value_bytes(args[i]);"
     370                   "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
     371                   "return(C_bytevector(&s, n, (char *)sqlite3_value_blob(args[i])));")
     372                  args i) ]
     373                [else
     374                 <void> ] )
     375              (loop (add1 i)) ) ) ) )
    390376
    391377(define-generic sqlite3:set-result!)
     
    432418  (let/cc return
    433419    (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)))) ) )
     420        noop
     421        (lambda ()
     422          (handle-exceptions exn
     423                             (print-error "in SQL function" exn)
     424            (sqlite3:set-result!
     425             ctx
     426             (apply (vector-ref
     427                     (call-with/synch *sqlite3:functions*
     428                      (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))
     429                     1)
     430                    (sqlite3:parameter-data n args) ) ) ) )
     431       (lambda ()
     432         (return (void)) ) ) ) )
    448433
    449434(define sqlite3_aggregate_context
     
    455440  (let/cc return
    456441    (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))))))
    470          (lambda ()
    471            (return (void)))) ) )
     442        noop
     443        (lambda ()
     444          (handle-exceptions exn
     445                             (print-error "in step of SQL function" exn)
     446            (let ([info (call-with/synch *sqlite3:functions*
     447                          (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
     448              (call-with/synch *sqlite3:seeds*
     449               (cute hash-table-update!/default
     450                     <>
     451                     (sqlite3_aggregate_context ctx)
     452                     (lambda (seed)
     453                       (apply (vector-ref info 1) seed (sqlite3:parameter-data n args)))
     454                     (vector-ref info 2)) ) ) ) )
     455           (lambda ()
     456             (return (void)) ) ) ) )
    472457
    473458(define-external (chicken_sqlite3_final_stub (c-pointer ctx))
    474459                 void
    475460  (let/cc return
    476     (let ((agc (sqlite3_aggregate_context ctx)))
     461    (let ([agc (sqlite3_aggregate_context ctx)])
    477462      (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)))) ) ) )
     463          noop
     464          (lambda ()
     465            (handle-exceptions exn
     466                               (print-error "in final of SQL function" exn)
     467              (let ([info (call-with/synch *sqlite3:functions*
     468                           (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
     469                (cond [((vector-ref info 3)
     470                 (call-with/synch *sqlite3:seeds*
     471                   (cute hash-table-ref/default <> agc (vector-ref info 2))))
     472                 => (cute sqlite3:set-result! ctx <>) ]
     473                [else
     474                 (sqlite3:set-result! ctx) ] ) ) ) )
     475          (lambda ()
     476            (call-with/synch *sqlite3:seeds*
     477             (cute hash-table-delete! <> agc))
     478            (return (void)) ) ) ) ) )
    495479
    496480(define-generic sqlite3:define-function)
     
    499483                                         (n <exact>)
    500484                                         (proc <procedure-class>))
    501   (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    502     (cond
    503      (((foreign-lambda* sqlite3:status
    504                         ((sqlite3:database db) (c-string name) (int n) (scheme-object qn))
    505 #<<END
     485  (let ([qn (object-evict (list (pointer->address (slot-ref db 'this)) name))])
     486    (cond [((foreign-lambda* sqlite3:status
     487                             ((sqlite3:database db)
     488                              (c-string name) (int n) (scheme-object qn))
     489#<<EOS
    506490        return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
    507491                                       (void *)qn,
     
    511495                                       NULL,
    512496                                       NULL));
    513 END
    514        )
    515        db name n qn)
    516       => (lambda (s)
    517            (object-release qn)
    518            ((signal-sqlite3-error 'sqlite3:define-function db name n proc) s)))
    519      (else
    520       (call-with/synch *sqlite3:functions*
    521         (cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )
     497EOS
     498            )
     499            db name n qn)
     500           => (lambda (s)
     501                (object-release qn)
     502                ((abort-sqlite3-error 'sqlite3:define-function db name n proc) s)) ]
     503          [else
     504           (call-with/synch *sqlite3:functions*
     505        (cute hash-table-tree-set! <> qn (vector qn proc))) ] ) ) )
    522506
    523507(define-method (sqlite3:define-function (db <sqlite3:database>)
     
    528512                                         #!optional (final-proc identity))
    529513  (check-sqlite3-type 'sqlite3:define-function final-proc <procedure-class>)
    530   (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    531     (cond
    532      (((foreign-lambda* sqlite3:status
    533                         ((sqlite3:database db) (c-string name) (int n) (scheme-object qn))
    534 #<<END
     514  (let ([qn (object-evict (list (pointer->address (slot-ref db 'this)) name))])
     515    (cond [((foreign-lambda* sqlite3:status
     516                             ((sqlite3:database db)
     517                              (c-string name) (int n) (scheme-object qn))
     518#<<EOS
    535519        return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
    536520                                       (void *)qn,
     
    541525                                       ((void (*)(sqlite3_context *))
    542526                                         &chicken_sqlite3_final_stub)));
    543 END
    544        )
    545        db name n qn)
    546       => (lambda (s)
    547            (object-release qn)
    548            ((signal-sqlite3-error
    549               'sqlite3:define-function db name n step-proc seed final-proc)
    550             s)))
    551      (else
    552       (call-with/synch *sqlite3:functions*
    553         (cut hash-table-tree-set! <> qn (vector qn step-proc seed final-proc))) ) ) ) )
     527EOS
     528            )
     529            db name n qn)
     530           => (lambda (s)
     531                (object-release qn)
     532                ((abort-sqlite3-error
     533                   'sqlite3:define-function db name n step-proc seed final-proc) s)) ]
     534          [else
     535           (call-with/synch *sqlite3:functions*
     536        (cute hash-table-tree-set! <> qn (vector qn step-proc seed final-proc))) ] ) ) )
    554537
    555538;;; Database interface
     
    562545(define (sqlite3:open path)
    563546  (check-sqlite3-type 'sqlite3:open path <string>)
    564   (let-location ((db c-pointer))
    565     (cond
    566      (((foreign-lambda sqlite3:status "sqlite3_open"
    567                                       nonnull-c-string (c-pointer sqlite3:database))
    568        (sqlite3:resolve-pathname path) (location db))
    569       => (signal-sqlite3-error 'sqlite3:open #f path))
    570      (else
    571       (make <sqlite3:database> 'this db) ) ) ) )
     547  (let-location ([db c-pointer])
     548    (cond [((foreign-lambda sqlite3:status "sqlite3_open"
     549                                           nonnull-c-string (c-pointer sqlite3:database))
     550            (sqlite3:resolve-pathname path) #$db)
     551           => (abort-sqlite3-error 'sqlite3:open #f path) ]
     552          [else
     553           (make <sqlite3:database> 'this db) ] ) ) )
    572554
    573555;; Set a timeout until a busy error is thrown
    574556(define (sqlite3:set-busy-timeout! db #!optional (ms 0))
    575557  (check-sqlite3-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
    576   (cond
    577    (((foreign-lambda sqlite3:status "sqlite3_busy_timeout" sqlite3:database int) db ms)
    578     => (signal-sqlite3-error 'sqlite3:set-busy-timeout! db db ms))) )
     558  (cond [((foreign-lambda sqlite3:status "sqlite3_busy_timeout" sqlite3:database int) db ms)
     559         => (abort-sqlite3-error 'sqlite3:set-busy-timeout! db db ms) ] ) )
    579560
    580561;; Cancel any running database operation as soon as possible
     
    603584(define-generic sqlite3:finalize!)
    604585(define-method (sqlite3:finalize! (db <sqlite3:database>))
    605   (cond
    606    ((not (slot-ref db 'this))
    607     (void))
    608    (((foreign-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)
    609     => (signal-sqlite3-error 'sqlite3:finalize! db db))
    610    (else
    611     (let ((id (pointer->address (slot-ref db 'this)))
    612           (release-qns (lambda (_ info) (object-release (vector-ref info 0)))))
    613       (call-with/synch *sqlite3:collations*
    614         (cut hash-table-tree-clear! <> id release-qns))
    615       (call-with/synch *sqlite3:functions*
    616         (cut hash-table-tree-clear! <> id release-qns)) )
    617     (slot-set! db 'this #f) ) ) )
     586  (cond [(not (slot-ref db 'this))
     587         (void) ]
     588        [((foreign-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)
     589         => (abort-sqlite3-error 'sqlite3:finalize! db db) ]
     590        [else
     591         (let ([id (pointer->address (slot-ref db 'this))]
     592               [release-qns (lambda (_ info) (object-release (vector-ref info 0)))] )
     593           (call-with/synch *sqlite3:collations*
     594             (cute hash-table-tree-clear! <> id release-qns))
     595           (call-with/synch *sqlite3:functions*
     596             (cute hash-table-tree-clear! <> id release-qns)) )
     597           (slot-set! db 'this #f) ] ) )
    618598
    619599;;; Statement interface
     
    623603  (check-sqlite3-type 'sqlite3:prepare db <sqlite3:database>)
    624604  (check-sqlite3-type 'sqlite3:prepare sql <string>)
    625   (let-location ((stmt c-pointer) (tail c-string))
    626     (cond
    627      (((foreign-lambda sqlite3:status "sqlite3_prepare"
    628                                       sqlite3:database scheme-pointer int
    629                                       (c-pointer sqlite3:statement)
    630                                       (c-pointer (const c-string)))
    631        db sql (string-length sql) (location stmt) (location tail))
    632       => (signal-sqlite3-error 'sqlite3:prepare db db sql))
    633      (else
    634       (values
    635        (make <sqlite3:statement> 'this stmt 'database db 'sql sql)
    636        tail) ) ) ) )
     605  (let-location ([stmt c-pointer] [tail c-string])
     606    (cond [((foreign-lambda sqlite3:status "sqlite3_prepare"
     607                                            sqlite3:database scheme-pointer int
     608                                            (c-pointer sqlite3:statement)
     609                                            (c-pointer (const c-string)))
     610            db sql (string-length sql) #$stmt #$tail)
     611           => (abort-sqlite3-error 'sqlite3:prepare db db sql) ]
     612          [else
     613           (values
     614            (make <sqlite3:statement> 'this stmt 'database db 'sql sql)
     615            tail) ] ) ) )
    637616
    638617;; Recompile an existing statement and transfer all bindings
    639618(define (sqlite3:repair! stmt)
    640619  (check-sqlite3-type 'sqlite3:repair! stmt <sqlite3:statement>)
    641   (let ((fresh (sqlite3:prepare
    642                 (slot-ref stmt 'database) (slot-ref stmt 'sql))))
     620  (let ([fresh (sqlite3:prepare
     621                (slot-ref stmt 'database) (slot-ref stmt 'sql))])
    643622    (dynamic-wind
    644623        noop
    645624        (lambda ()
    646           (let ((old (slot-ref stmt 'this))
    647                 (new (slot-ref fresh 'this)))
    648             (cond
    649              (((foreign-lambda sqlite3:status "sqlite3_transfer_bindings"
    650                                               c-pointer c-pointer)
    651                old new)
    652               => (signal-sqlite3-error 'sqlite3:repair! (slot-ref stmt 'database) stmt))
    653              (else
    654               (slot-set! stmt 'this new)
    655               (slot-set! fresh 'this old)))))
     625          (let ([old (slot-ref stmt 'this)]
     626                [new (slot-ref fresh 'this)] )
     627            (cond [((foreign-lambda sqlite3:status "sqlite3_transfer_bindings"
     628                                             c-pointer c-pointer)
     629              old new)
     630             => (abort-sqlite3-error 'sqlite3:repair! (slot-ref stmt 'database) stmt) ]
     631            [else
     632             (slot-set! stmt 'this new)
     633             (slot-set! fresh 'this old) ] ) ) )
    656634        (lambda ()
    657635          (sqlite3:finalize! fresh))) ) )
     
    660638;; (define-generic sqlite3:finalize!)
    661639(define-method (sqlite3:finalize! (stmt <sqlite3:statement>))
    662   (cond
    663    ((not (slot-ref stmt 'this))
    664     (void))
    665    (((foreign-lambda sqlite3:status "sqlite3_finalize" sqlite3:statement) stmt)
    666     => (signal-sqlite3-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt))
    667    (else
    668     (slot-set! stmt 'this #f) ) ) )
     640  (cond [(not (slot-ref stmt 'this))
     641         (void) ]
     642        [((foreign-lambda sqlite3:status "sqlite3_finalize" sqlite3:statement) stmt)
     643         => (abort-sqlite3-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt) ]
     644        [else
     645         (slot-set! stmt 'this #f) ] ) )
    669646
    670647;; Reset an existing statement to process it again
     
    674651(define (sqlite3:reset! stmt)
    675652  (check-sqlite3-type 'sqlite3:reset! stmt <sqlite3:statement>)
    676   (cond
    677    ((sqlite3_reset stmt)
    678     => (signal-sqlite3-error 'sqlite3:reset! (slot-ref stmt 'database) stmt))) )
     653  (cond [(sqlite3_reset stmt)
     654         => (abort-sqlite3-error 'sqlite3:reset! (slot-ref stmt 'database) stmt) ] ) )
    679655
    680656;; Get number of bindable parameters
     
    687663(define (sqlite3:bind-parameter-index stmt name)
    688664  (check-sqlite3-type 'sqlite3:bind-parameter-index stmt <sqlite3:statement>)
    689   (let ((i ((foreign-lambda int "sqlite3_bind_parameter_index"
     665  (let ([i ((foreign-lambda int "sqlite3_bind_parameter_index"
    690666                                sqlite3:statement nonnull-c-string)
    691             stmt name)))
     667            stmt name)])
    692668    (if (zero? i)
    693669        #f
     
    697673(define (sqlite3:bind-parameter-name stmt i)
    698674  (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)) )
     675  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int)
     676   stmt (add1 i)) )
    700677
    701678;; Bind data as parameters to an existing statement
     
    704681(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
    705682                              (v <blob>))
    706   (cond
    707    (((foreign-lambda* sqlite3:status
    708                       ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
    709       "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
    710      stmt (add1 i) v (blob-size v))
    711     => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
     683  (cond [((foreign-lambda* sqlite3:status
     684                           ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
     685           "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
     686          stmt (add1 i) v (blob-size v))
     687         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )
    712688
    713689; Deprecated
    714690(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
    715691                              (v <byte-vector>))
    716   (cond
    717    (((foreign-lambda* sqlite3:status
    718                       ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
    719       "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
    720      stmt (add1 i) v (byte-vector-length v))
    721     => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
     692  (cond [((foreign-lambda* sqlite3:status
     693                           ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
     694           "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
     695          stmt (add1 i) v (byte-vector-length v))
     696         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )
     697
     698(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
     699                              (v <boolean>))
     700  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int"
     701                                         sqlite3:statement int int)
     702          stmt (add1 i) (or (and v 1) 0))
     703         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )
    722704
    723705(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
    724706                              (v <exact>))
    725   (cond
    726    (((foreign-lambda sqlite3:status "sqlite3_bind_int"
    727                                     sqlite3:statement int int)
    728      stmt (add1 i) v)
    729     => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
     707  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int"
     708                                         sqlite3:statement int int)
     709          stmt (add1 i) v)
     710         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )
    730711
    731712(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
    732713                              (v <number>))
    733   (cond
    734    (((foreign-lambda sqlite3:status "sqlite3_bind_double"
    735                                     sqlite3:statement int double)
    736      stmt (add1 i) v)
    737     => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )
     714  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_double"
     715                                          sqlite3:statement int double)
     716          stmt (add1 i) v)
     717         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )
    738718
    739719(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
    740720                              (v <string>))
    741   (cond
    742    (((foreign-lambda* sqlite3:status
    743                       ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
    744       "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
    745      stmt (add1 i) v (string-length v))
    746     => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))
    747 
    748 (define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
    749                               (v <void>))
    750   (cond
    751    (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    752     => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )
     721  (cond [((foreign-lambda* sqlite3:status
     722                           ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
     723           "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
     724          stmt (add1 i) v (string-length v))
     725         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v) ] ) )
    753726
    754727(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>))
    755   (cond
    756    (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    757     => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )
     728  (cond [((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int)
     729         stmt (add1 i))
     730         => (abort-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i) ] ) )
    758731
    759732; Helper
     733
    760734(define (bind-parameters! loc stmt params)
    761735  (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) ) )
     736  (let ([cnt (sqlite3:bind-parameter-count stmt)])
     737    (if (= cnt (length params))
     738        (unless (zero? cnt)
     739          (for-each
     740           (lambda (i v)
     741             (if (eq? <void> v)
     742                 (sqlite3:bind! stmt i)
     743                 (sqlite3:bind! stmt i v) ) )
     744           (iota cnt) params) )
     745        (abort
     746         (make-composite-condition
     747          (make-exn-condition
     748           loc
     749           (conc "bad parameter count - received " (length params) " but expected " cnt))
     750          (make-property-condition 'arity)
     751          (make-sqlite3-condition 'error))) ) ) )
    770752
    771753(define (sqlite3:bind-parameters! stmt . params)
     
    777759  (check-sqlite3-type 'sqlite3:step! stmt <sqlite3:statement>)
    778760  (let retry ()
    779     (let ((s ((foreign-safe-lambda
     761    (let ([s ((foreign-safe-lambda
    780762               sqlite3:status "sqlite3_step" sqlite3:statement)
    781               stmt)))
     763              stmt)])
    782764      (case s
    783         ((row) #t)
    784         ((done) #f)
    785         ((error)
    786          (let ((s (sqlite3_reset stmt)))
     765        [(row)
     766         #t ]
     767        [(done)
     768         #f ]
     769        [(error)
     770         (let ([s (sqlite3_reset stmt)])
    787771           (case s
    788              ((schema)
     772             [(schema)
    789773              (sqlite3:repair! stmt)
    790               (retry))
    791              (else
    792               ((signal-sqlite3-error
    793                 'sqlite3:step! (slot-ref stmt 'database) stmt) s)))))
    794         (else
    795          ((signal-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ) ) ) ) )
     774              (retry) ]
     775             [else
     776              ((abort-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ] ) ) ]
     777        [else
     778         ((abort-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ] ) ) ) )
    796779
    797780;; Retrieve information from a prepared/stepped statement
     
    815798(define (sqlite3:column-data stmt i)
    816799  (case (sqlite3:column-type stmt i)
    817     ((integer)
    818      ((foreign-lambda integer "sqlite3_column_double" sqlite3:statement int) stmt i))
    819     ((float)
    820      ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i))
    821     ((text)
     800    [(integer)
     801     ((foreign-lambda integer "sqlite3_column_double" sqlite3:statement int) stmt i) ]
     802    [(float)
     803     ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i) ]
     804    [(text)
    822805     ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
    823806       "int n = sqlite3_column_bytes(stmt, i);"
    824807       "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
    825808       "return(C_string(&s, n, (char *)sqlite3_column_text(stmt, i)));")
    826       stmt i))
    827     ((blob)
     809      stmt i) ]
     810    [(blob)
    828811     ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
    829812       "int n = sqlite3_column_bytes(stmt, i);"
    830813       "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
    831814       "return(C_bytevector(&s, n, (char *)sqlite3_column_blob(stmt, i)));")
    832       stmt i))
    833     (else
    834      sqlite3:null-value ) ) )
     815      stmt i) ]
     816    [else
     817     <void> ] ) )
    835818
    836819;;; Easy statement interface
     
    840823(define (sqlite3:call-with-temporary-statements proc db . sqls)
    841824  (check-sqlite3-type 'sqlite3:call-with-temporary-statements db <sqlite3:database>)
    842   (let ((stmts #f))
     825  (let ([stmts #f])
    843826    (dynamic-wind
    844827        (lambda ()
    845828          (unless stmts
    846             (set! stmts (map (cut sqlite3:prepare db <>) sqls))))
     829            (set! stmts (map (cute sqlite3:prepare db <>) sqls))))
    847830        (lambda ()
    848831          (apply proc stmts))
     
    857840  (bind-parameters! 'sqlite3:exec stmt params)
    858841  (while (sqlite3:step! stmt))
    859   sqlite3:null-value )
     842  (void) )
    860843
    861844(define-method (sqlite3:exec (db <sqlite3:database>) (sql <string>) . params)
    862845  (sqlite3:call-with-temporary-statements
    863    (cut apply sqlite3:exec <> params)
     846   (cute apply sqlite3:exec <> params)
    864847   db sql) )
    865848
     
    883866  (bind-parameters! 'sqlite3:first-result stmt params)
    884867  (if (sqlite3:step! stmt)
    885       (let ((r (sqlite3:column-data stmt 0)))
     868      (let ([r (sqlite3:column-data stmt 0)])
    886869        (sqlite3:reset! stmt)
    887870        r )
    888       (signal (make-no-data-condition 'sqlite3:first-result stmt params)) ) )
     871      (abort (make-no-data-condition 'sqlite3:first-result stmt params)) ) )
    889872
    890873(define-method (sqlite3:first-result
    891874                (db <sqlite3:database>) (sql <string>) . params)
    892875  (sqlite3:call-with-temporary-statements
    893    (cut apply sqlite3:first-result <> params)
     876   (cute apply sqlite3:first-result <> params)
    894877   db sql) )
    895878
     
    900883  (bind-parameters! 'sqlite3:first-row stmt params)
    901884  (if (sqlite3:step! stmt)
    902       (map (cut sqlite3:column-data stmt <>)
     885      (map (cute sqlite3:column-data stmt <>)
    903886           (iota (sqlite3:column-count stmt)))
    904       (signal (make-no-data-condition 'sqlite3:first-row stmt params)) ) )
     887      (abort (make-no-data-condition 'sqlite3:first-row stmt params)) ) )
    905888
    906889(define-method (sqlite3:first-row
    907890                (db <sqlite3:database>) (sql <string>) . params)
    908891  (sqlite3:call-with-temporary-statements
    909    (cut apply sqlite3:first-row <> params)
     892   (cute apply sqlite3:first-row <> params)
    910893   db sql))
    911894
     
    915898(define (%fold-row loc proc stmt init params)
    916899  (bind-parameters! loc stmt params)
    917   (let ((cl (iota (sqlite3:column-count stmt))))
    918     (let loop ((acc init))
     900  (let ([cl (iota (sqlite3:column-count stmt))])
     901    (let loop ([acc init])
    919902      (if (sqlite3:step! stmt)
    920           (loop (apply proc acc (map (cut sqlite3:column-data stmt <>) cl)))
     903          (loop (apply proc acc (map (cute sqlite3:column-data stmt <>) cl)))
    921904          acc ) ) ) )
    922905
     
    932915                                 (init <object>) . params)
    933916  (sqlite3:call-with-temporary-statements
    934    (cut apply sqlite3:fold-row proc <> init params)
     917   (cute apply sqlite3:fold-row proc <> init params)
    935918   db sql) )
    936919
     
    952935                                     (sql <string>) . params)
    953936  (sqlite3:call-with-temporary-statements
    954    (cut apply sqlite3:for-each-row proc <> params)
     937   (cute apply sqlite3:for-each-row proc <> params)
    955938   db sql) )
    956939
     
    971954                                (sql <string>) . params)
    972955  (sqlite3:call-with-temporary-statements
    973    (cut apply sqlite3:map-row proc <> params)
     956   (cute apply sqlite3:map-row proc <> params)
    974957   db sql) )
    975958
     
    989972                          type)
    990973      (make-property-condition 'type))) )
    991   (let ((success? #f))
     974  (let ([success? #f])
    992975    (dynamic-wind
    993976        (lambda ()
     
    1009992(define sqlite3:library-version
    1010993  (foreign-lambda c-string "sqlite3_libversion") )
     994
     995;; Return a Scheme boolean for the usual SQLite column boolean values
     996(define (sqlite3:boolean-value v)
     997  (cond [(string? v)
     998         (or (string-ci=? "Y" v)
     999             (string-ci=? "YES" v)
     1000             (string=? "Yes" v)) ]
     1001        [(and (integer? v) (exact? v))
     1002         (not (zero? v)) ]
     1003        [else
     1004          #f ] ) )
Note: See TracChangeset for help on using the changeset viewer.