Coverage report: /development/source/library/com/dydra/gitlab/dydra-cgi/ffi/lisp/rdfcache/cursor.lisp

KindCoveredAll%
expression4238 1.7
branch02 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :rdfcache)
2
 
3
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4
 
5
 (defun count-matched-quads (transaction graph-id* subject-id predicate-id object-id
6
                             &key (offset nil) (limit nil))
7
   "Legacy compatibility wrapper for DYDRA-NDK:COUNT-MATCHED-QUADS."
8
   (declare (type foreign-pointer transaction)
9
            (type (or list fixnum) graph-id*)
10
            (type fixnum subject-id predicate-id object-id)
11
            (type (or integer null) offset limit))
12
   (let ((transaction-uuid (rdfcache:transaction-uuid-pointer transaction)))
13
     (dydra-ndk::count-matched-quads transaction-uuid
14
                                     graph-id* subject-id predicate-id object-id
15
                                     :offset offset :limit limit)))
16
 
17
 (export 'count-matched-quads)
18
 
19
 (defun make-quad-cursor (transaction graph-id* subject-id predicate-id object-id
20
                          &key (distinct nil) (ordered t) (graph nil)
21
                               (offset nil) (limit nil) (buffer nil))
22
   "Legacy compatibility wrapper for DYDRA-NDK:MAKE-QUAD-CURSOR."
23
   (declare (type foreign-pointer transaction)
24
            (type (or list fixnum) graph-id*)
25
            (type fixnum subject-id predicate-id object-id)
26
            (type boolean distinct ordered)
27
            (type (or fixnum null) graph)
28
            (type (or integer null) offset limit buffer))
29
   (let ((transaction-uuid (rdfcache:transaction-uuid-pointer transaction)))
30
     (dydra-ndk::make-quad-cursor transaction-uuid
31
                                  graph-id* subject-id predicate-id object-id
32
                                  :distinct distinct :ordered ordered
33
                                  :graph graph :offset offset :limit limit
34
                                  :buffer buffer)))
35
 
36
 (export 'make-quad-cursor)
37
 
38
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39
 
40
 ;;; Cursor API: Accessors
41
 
42
 (defmacro cursor-slot-pointer (cursor-var slot-name)
43
   `(foreign-slot-pointer ,cursor-var 'cursor ,slot-name))
44
 
45
 (defmacro cursor-slot-value (cursor-var slot-name)
46
   `(foreign-slot-value ,cursor-var 'cursor ,slot-name))
47
 
48
 ;; Cursor API: Thread-local state
49
 
50
 (defun init-thread () (%%thread-init))
51
 
52
 (defun exit-thread () (%%thread-exit))
53
 
54
 ;; Cursor API
55
 
56
 (defun close (cursor)
57
   (%close (pointer cursor)))
58
 
59
 ;;; Cursor API: Optimization hints
60
 
61
 (defun %cursor-term-options (term-options term-position)
62
   (let ((term-opt (case term-options
63
                         (:term-number 1)
64
                         (:term-identifier 2)
65
                         (:term 4)
66
                         (t 0))))
67
     (ash term-opt (* term-position 8))))
68
 
69
 (defun declare-terms (cursor context-options subject-options predicate-options object-options)
70
   (setf (cursor-slot-value cursor 'options)
71
         (+ (%cursor-term-options subject-options   0)
72
            (%cursor-term-options predicate-options 1)
73
            (%cursor-term-options object-options    2)
74
            (%cursor-term-options context-options   3))))
75
 
76
 ;;; Cursor API: Term retrieval
77
 
78
 (defun fetch-cursor-context (cursor)
79
   (declare (type foreign-pointer cursor)
80
            (optimize (speed 3)))
81
   (fetch-term (cursor-context-number cursor)
82
               (cursor-context-pointer cursor)))
83
 
84
 (defun fetch-cursor-subject (cursor)
85
   (declare (type foreign-pointer cursor)
86
            (optimize (speed 3)))
87
   (fetch-term (cursor-subject-number cursor)
88
               (cursor-subject-pointer cursor)))
89
 
90
 (defun fetch-cursor-predicate (cursor)
91
   (declare (type foreign-pointer cursor)
92
            (optimize (speed 3)))
93
   (fetch-term (cursor-predicate-number cursor)
94
               (cursor-predicate-pointer cursor)))
95
 
96
 (defun fetch-cursor-object (cursor)
97
   (declare (type foreign-pointer cursor)
98
            (optimize (speed 3)))
99
   (fetch-term (cursor-object-number cursor)
100
               (cursor-object-pointer cursor)))
101
 
102
 ;;; Cursor API: Iteration
103
 
104
 (defun rewind (cursor)
105
   (setf (cursor-slot-value (pointer cursor) 'position) 0))
106
 
107
 (defun skip (cursor count)
108
   (declare (type foreign-pointer cursor)
109
            (type fixnum count)
110
            (optimize (speed 3)))
111
   (the (values fixnum &optional) (%skip cursor count)))
112
 
113
 (defun next (cursor)
114
   (declare (type foreign-pointer cursor)
115
            (optimize (speed 3)))
116
   (not (zerop (the fixnum (%next cursor)))))
117
 
118
 #+rdfcache-compiler-macros
119
 (define-compiler-macro next (&whole whole cursor &environment env)
120
   (let* ((expanded (macroexpand-1 cursor env)))
121
     (multiple-value-bind (kind localp decls)
122
                          (when (symbolp expanded)
123
                            (variable-information expanded env))
124
       (declare (ignore kind localp))
125
       (let ((type (rest (assoc 'type decls))))
126
         (if (and type (subtypep type  'foreign-pointer))
127
           `(locally (declare (optimize (speed 3)))
128
              (not (zerop (the fixnum (%%next ,cursor)))))
129
           whole)))))
130
 
131
 ;;; Cursor API: Statistics accessors
132
 
133
 (defmacro cursor-count (cursor-var)
134
   `(cursor-slot-value ,cursor-var 'count))
135
 
136
 ;;; Cursor API: Quad accessors
137
 
138
 (defun cursor-quad-pointer (cursor)
139
   (with-checked-pointer (cursor)
140
     (cursor-slot-pointer cursor 'quad)))
141
 
142
 ;;; Cursor API: Context term accessors
143
 
144
 (defun cursor-context-number (cursor)
145
   (declare (type foreign-pointer cursor)
146
            (optimize (speed 3)))
147
   (the fixnum
148
     (foreign-slot-value (cursor-slot-value cursor 'term-numbers)
149
                         'term-numbers 'context-number)))
150
 
151
 #+rdfcache-compiler-macros
152
 (define-compiler-macro cursor-context-number (&whole whole cursor &environment env)
153
   (let* ((expanded (macroexpand-1 cursor env)))
154
     (multiple-value-bind (kind localp decls)
155
                          (when (symbolp expanded)
156
                            (variable-information expanded env))
157
       (declare (ignore kind localp))
158
       (let ((type (rest (assoc 'type decls))))
159
         (if (and type (subtypep type  'foreign-pointer))
160
           `(locally (declare (optimize (speed 3)))
161
              (the fixnum
162
                (foreign-slot-value (cursor-slot-value ,cursor 'term-numbers)
163
                                    'term-numbers 'context-number)))
164
           whole)))))
165
 
166
 (defun cursor-context-pointer (cursor)
167
   (with-checked-pointer (cursor)
168
     (cursor-slot-pointer cursor 'context)))
169
 
170
 (defun cursor-context-type (cursor)
171
   (term-type (cursor-context-pointer cursor)))
172
 
173
 (defun cursor-context-value (cursor)
174
   (term-value (cursor-context-pointer cursor)))
175
 
176
 (defun cursor-context-to-list (cursor)
177
   (term-to-list (cursor-context-pointer cursor)))
178
 
179
 (defun cursor-context-to-string (cursor)
180
   (term-to-string (cursor-context-pointer cursor)))
181
 
182
 ;;; Cursor API: Subject term accessors
183
 
184
 (defun cursor-subject-number (cursor)
185
   (declare (type foreign-pointer cursor)
186
            (optimize (speed 3)))
187
   (the fixnum
188
     (foreign-slot-value (cursor-slot-value cursor 'term-numbers)
189
                         'term-numbers 'subject-number)))
190
 
191
 #+rdfcache-compiler-macros
192
 (define-compiler-macro cursor-subject-number (&whole whole cursor &environment env)
193
   (let* ((expanded (macroexpand-1 cursor env)))
194
     (multiple-value-bind (kind localp decls)
195
                          (when (symbolp expanded)
196
                            (variable-information expanded env))
197
       (declare (ignore kind localp))
198
       (let ((type (rest (assoc 'type decls))))
199
         (if (and type (subtypep type  'foreign-pointer))
200
           `(locally (declare (optimize (speed 3)))
201
              (the fixnum
202
                (foreign-slot-value (cursor-slot-value ,cursor 'term-numbers)
203
                                    'term-numbers 'subject-number)))
204
           whole)))))
205
 
206
 (defun cursor-subject-pointer (cursor)
207
   (with-checked-pointer (cursor)
208
     (cursor-slot-pointer cursor 'subject)))
209
 
210
 (defun cursor-subject-type (cursor)
211
   (term-type (cursor-subject-pointer cursor)))
212
 
213
 (defun cursor-subject-value (cursor)
214
   (term-value (cursor-subject-pointer cursor)))
215
 
216
 (defun cursor-subject-to-list (cursor)
217
   (term-to-list (cursor-subject-pointer cursor)))
218
 
219
 (defun cursor-subject-to-string (cursor)
220
   (term-to-string (cursor-subject-pointer cursor)))
221
 
222
 ;;; Cursor API: Predicate term accessors
223
 
224
 (defun cursor-predicate-number (cursor)
225
   (declare (type foreign-pointer cursor)
226
            (optimize (speed 3)))
227
   (the fixnum
228
     (foreign-slot-value (cursor-slot-value cursor 'term-numbers)
229
                         'term-numbers 'predicate-number)))
230
 
231
 #+rdfcache-compiler-macros
232
 (define-compiler-macro cursor-predicate-number (&whole whole cursor &environment env)
233
   (let* ((expanded (macroexpand-1 cursor env)))
234
     (multiple-value-bind (kind localp decls)
235
                          (when (symbolp expanded)
236
                            (variable-information expanded env))
237
       (declare (ignore kind localp))
238
       (let ((type (rest (assoc 'type decls))))
239
         (if (and type (subtypep type  'foreign-pointer))
240
           `(locally (declare (optimize (speed 3)))
241
              (the fixnum
242
                (foreign-slot-value (cursor-slot-value ,cursor 'term-numbers)
243
                                    'term-numbers 'predicate-number)))
244
           whole)))))
245
 
246
 (defun cursor-predicate-pointer (cursor)
247
   (with-checked-pointer (cursor)
248
     (cursor-slot-pointer cursor 'predicate)))
249
 
250
 (defun cursor-predicate-type (cursor)
251
   (term-type (cursor-predicate-pointer cursor)))
252
 
253
 (defun cursor-predicate-value (cursor)
254
   (term-value (cursor-predicate-pointer cursor)))
255
 
256
 (defun cursor-predicate-to-list (cursor)
257
   (term-to-list (cursor-predicate-pointer cursor)))
258
 
259
 (defun cursor-predicate-to-string (cursor)
260
   (term-to-string (cursor-predicate-pointer cursor)))
261
 
262
 ;;; Cursor API: Object term accessors
263
 
264
 (defun cursor-object-number (cursor)
265
   (declare (type foreign-pointer cursor)
266
            (optimize (speed 3)))
267
   (the fixnum
268
     (foreign-slot-value (cursor-slot-value cursor 'term-numbers)
269
                         'term-numbers 'object-number)))
270
 
271
 #+rdfcache-compiler-macros
272
 (define-compiler-macro cursor-object-number (&whole whole cursor &environment env)
273
   (let* ((expanded (macroexpand-1 cursor env)))
274
     (multiple-value-bind (kind localp decls)
275
                          (when (symbolp expanded)
276
                            (variable-information expanded env))
277
       (declare (ignore kind localp))
278
       (let ((type (rest (assoc 'type decls))))
279
         (if (and type (subtypep type  'foreign-pointer))
280
           `(locally (declare (optimize (speed 3)))
281
              (the fixnum
282
                (foreign-slot-value (cursor-slot-value ,cursor 'term-numbers)
283
                                    'term-numbers 'object-number)))
284
           whole)))))
285
 
286
 (defun cursor-object-pointer (cursor)
287
   (with-checked-pointer (cursor)
288
     (cursor-slot-pointer cursor 'object)))
289
 
290
 (defun cursor-object-type (cursor)
291
   (term-type (cursor-object-pointer cursor)))
292
 
293
 (defun cursor-object-value (cursor)
294
   (term-value (cursor-object-pointer cursor)))
295
 
296
 (defun cursor-object-to-list (cursor)
297
   (term-to-list (cursor-object-pointer cursor)))
298
 
299
 (defun cursor-object-to-string (cursor)
300
   (term-to-string (cursor-object-pointer cursor)))
301
 
302
 ;;; Cursor API: Macros
303
 
304
 (defmacro with-cursor ((cursor-var) &body body)
305
   `(with-foreign-object (,cursor-var '(:struct cursor))
306
      (declare (type foreign-pointer ,cursor-var))
307
      (%clear-cursor ,cursor-var)
308
      (unwind-protect (progn ,@body)
309
        (rdfcache:close ,cursor-var))))
310
 
311
 (defmacro with-cursor-term ((cursor-var term-name term-type-var term-value-var) &body body)
312
   `(with-checked-pointer (,cursor-var)
313
      (let* ((.term-ptr.       (cursor-slot-pointer ,cursor-var ',term-name))
314
             (,term-type-var   (foreign-enum-value 'term-type (term-slot-value .term-ptr. 'type)))
315
             (.term-value-ptr. (term-slot-value .term-ptr. 'value))
316
             (.term-value-len. (%%utf8-get-length .term-value-ptr.))
317
             (,term-value-var  (make-string .term-value-len.)))
318
        (declare (type foreign-pointer ,cursor-var)
319
                 (type foreign-pointer .term-ptr. .term-value-ptr.)
320
                 (type fixnum ,term-type-var .term-value-len.)
321
                 (type simple-string ,term-value-var)
322
                 (dynamic-extent ,term-value-var))
323
        (dotimes (.term-value-pos. .term-value-len.)
324
          (let ((.term-value-chr. (%%utf8-get-char .term-value-ptr.)))
325
            (declare (type fixnum .term-value-pos. .term-value-chr.))
326
            (setf (char ,term-value-var .term-value-pos.)
327
                  (code-char .term-value-chr.)))
328
          (setq .term-value-ptr. (%%utf8-next-char .term-value-ptr.)))
329
        (locally ,@body))))
330
 
331
 ;;; Cursor API: Debugging
332
 
333
 (defun print-cursor (%cursor &optional (stream *standard-output*))
334
   (print-unreadable-object (%cursor stream :identity nil :type nil)
335
     (format stream "%cursor ~8,'0x: options ~s position ~s count ~s [~s ~s ~s ~s] segment ~s"
336
             (cffi:pointer-address %cursor)
337
             (cursor-slot-value %cursor 'options)
338
             (cursor-slot-value %cursor 'position)
339
             (cursor-count %cursor)
340
             (cursor-subject-number %cursor)
341
             (cursor-predicate-number %cursor)
342
             (cursor-object-number %cursor)
343
             (cursor-context-number %cursor)
344
             (cursor-slot-value %cursor 'segment))))